diff --git a/.gitignore b/.gitignore index 17f5c2b7e..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 @@ -413,3 +414,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/.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" diff --git a/.vscode/metarocq.code-workspace b/.vscode/metarocq.code-workspace index 35433b164..b9e9dbde2 100644 --- a/.vscode/metarocq.code-workspace +++ b/.vscode/metarocq.code-workspace @@ -8,86 +8,94 @@ // 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", - "-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", "test-suite/loop-checking/theories", "MetaRocq.LoopChecking", + "-I", "test-suite/loop-checking/src", + "-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", @@ -101,13 +109,53 @@ "**/.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, "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": false, + "coq-lsp.messages_follow_goal": false, + "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", + ], + "vsrocq.completion.enable": true, } } diff --git a/Makefile b/Makefile index 3c56fa4cc..ecbc42112 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 @@ -207,7 +206,9 @@ ci-quick: ci-opam: # Use -v so that regular output is produced - opam install --with-test -v -y . + 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 checktodos: diff --git a/common/_RocqProject.in b/common/_RocqProject.in index 0d0b0f701..760aa500a 100644 --- a/common/_RocqProject.in +++ b/common/_RocqProject.in @@ -1,7 +1,7 @@ -R theories MetaRocq.Common theories/Primitive.v -theories/uGraph.v +theories/UnivConstraintType.v theories/config.v theories/Kernames.v theories/Universes.v @@ -14,3 +14,15 @@ theories/EnvironmentTyping.v theories/EnvironmentReflect.v theories/EnvMap.v 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 +theories/LoopChecking/Deciders.v +theories/LoopChecking/UnivLoopChecking.v +theories/uGraph.v 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/Environment.v b/common/theories/Environment.v index 08d4dfe69..756b776e2 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 Σ Σ'. @@ -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 @@ -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 385f66397..728c69769 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). @@ -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,12 +256,12 @@ 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 => (* 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 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. } @@ -1279,16 +1279,11 @@ 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) φ). - (* 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 *) @@ -1297,9 +1292,8 @@ 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) - /\ satisfiable_udecl univs udecl - /\ valid_on_mono_udecl univs udecl. + /\ UnivConstraintSet.For_all (declared_univ_cstr_levels all_levels) (constraints_of_udecl 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. *) @@ -1417,30 +1411,35 @@ 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. + map (lift_universe 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 := - 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) := + 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' : 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, 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, @@ -1452,11 +1451,11 @@ 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 := 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. @@ -1568,7 +1567,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) }. @@ -1783,7 +1782,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. @@ -1799,15 +1798,11 @@ 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 => //. Qed. End GlobalMaps. diff --git a/common/theories/LoopChecking/Common.v b/common/theories/LoopChecking/Common.v new file mode 100644 index 000000000..4e9f66ca0 --- /dev/null +++ b/common/theories/LoopChecking/Common.v @@ -0,0 +1,341 @@ +(* Distributed under the terms of the MIT license. *) +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 NonEmptyLevelExprSet SemiLattice. + +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. + +#[program] Global Instance reflect_eq_Z : ReflectEq Z := { + eqb := Z.eqb + }. +Next Obligation. + destruct (Z.eqb_spec x y); constructor => //. +Qed. + +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. + +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. +Qed. + +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. + + +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. + +Notation min_opt := (option_map2 Z.min). + +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 -> + opt_le Z.le y z -> + opt_le Z.lt x z. +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_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 => //. +Qed. + +Lemma max_opt_of_r {A} {f : A -> A -> A} l : max_opt_of f None l = l. +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). +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. +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. + +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. + +Local Open Scope Z_scope. +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'. +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. + +#[export, refine] Instance ge_refl : Reflexive Z.ge := _. +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 new file mode 100644 index 000000000..b7e029b87 --- /dev/null +++ b/common/theories/LoopChecking/Deciders.v @@ -0,0 +1,3691 @@ +(* 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. +From MetaRocq.Utils Require Import utils MRClasses SemiLattice. + +From MetaRocq.Common Require UnivConstraintType. +From Equations Require Import Equations. + +From MetaRocq.Common.LoopChecking Require Import Common Interfaces HornClauses Model Models PartialLoopChecking InitialSemilattice HornSemilatticeEquiv. + +Set Equations Transparent. + +Module Type LoopCheckingItf (LS : LevelSets). + + (* Type of consistent models of a set of universe constraints *) + Parameter model : Type. + Parameter univ : Type. + + 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. *) + Parameter valuation : model -> LS.LevelMap.t nat. + + 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). + + (* 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. + +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. +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) := 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) : model + premises := +infer_model cls with loop (clauses_levels cls) LevelSet.empty cls (init_model cls) (init_model cls) _ := + | Loop v _ _ => inr v + | Model w vm heq => inl vm.(model_model). +Proof. + split. + - reflexivity. + - apply infer_obligation_2. + - apply is_update_of_empty. +Qed. + +Definition correct_model (cls : clauses) (m : model) := + enabled_clauses m cls /\ is_model m cls. + +(* Entailment *) + +Import I.Model.Model.Clauses.ISL. + +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 + | inl m => correct_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 m cls <-> 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. + +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 -[Z.add] in hleq. + rewrite min_premise_singleton /min_atom_value in hmin. + 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. rewrite /concl. 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. + 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 => //. + - intros [v [en clssem]]. + move: hi. + 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. + +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 + 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. + - intros l. rewrite LevelSet.union_spec. + rewrite -/(LevelMap.In l (premises_model (clauses_levels cls) None cl).2). + rewrite in_premises_model. intuition auto. + - apply is_update_of_empty. +Qed. + +Variant check_result {cls} := + | IsLooping (v : premises) (hincl : NES.levels v ⊂_lset clauses_levels cls) (islooping : loop_on_univ cls v) + | Invalid (m : model) + | Valid. +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 None (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_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 := + { | true => Valid + | false => Invalid v.(model_model) } + | exist None he' with valid_model_find v he' := {} + } + }. + +(* If a clause checks, then it is entailed (and will be valid in any extension of the model) *) +Theorem check_entails_entails {cls cl} : + check_entails cls cl = Valid -> entails cls cl. +Proof. + destruct cl as [prems [concl k]]. + 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. + 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. } + exact tr. +Qed. + + +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_entails cls cl) => //. +Qed. + +Lemma check_looping {cls cl 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_entails_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 m v vcls isl} : + is_model m cls -> + check_entails cls cl = IsLooping v vcls isl -> + defined_model_of (levels v) m -> False. +Proof. + move=> ism. + move/check_looping => ex hdef. apply ex. + 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. + apply consistent_no_loop. + exists (Z_valuation_of_model m). + split. apply valuation_of_model_pos. + eapply valid_clauses_model => //. +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. + +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. + +Definition updates cls m m' := exists W, is_update_of cls W m m'. + +Lemma updates_ext {cls m m'} : updates cls m m' -> m ⩽ m'. +Proof. + now move=> [W] /is_update_of_ext. +Qed. + +Instance updates_proper : Proper (Clauses.Equal ==> LevelMap.Equal ==> LevelMap.Equal ==> iff) updates. +Proof. + intros ? ? cls ? ? hm ?? hm'. unfold updates. + setoid_rewrite cls. setoid_rewrite hm. now setoid_rewrite hm'. +Qed. + +Definition minimal_above_updates cls minit m := + forall m', updates cls minit m' -> + is_model m' cls -> + updates cls m m'. + +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. + 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. + +Lemma levelset_is_empty_empty : LevelSet.is_empty LevelSet.empty. +Proof. + eapply LevelSet.is_empty_spec. lsets. +Qed. + +Lemma levelset_is_empty_singleton x : LevelSet.is_empty (LevelSet.singleton x) = false. +Proof. + rewrite levelset_not_Empty_is_empty. intros he; specialize (he x). lsets. +Qed. + + +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. + red. + now intros m'. +Qed. + +Lemma minimal_above_trans cls m m' m'' : minimal_above cls m m' -> minimal_above cls m' m'' -> + minimal_above cls m m''. +Proof. + 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' : + 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'. + now eapply minimal_above_trans; tea. +Qed. + +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. + +Theorem check_invalid {cls cl 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_entails 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 _ None _ 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) None 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 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. + +Definition is_total_model m cls := + Model.enabled_clauses m cls /\ is_model m 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 levels_of_model (m : model) := + LevelMap.fold (fun l _ acc => LevelSet.add l acc) m LevelSet.empty. + +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 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 join_assoc (join_comm (add _ x)). + rewrite eq -add_distr join_sub add_distr. + cbn. rewrite -eq. apply IHn. +Qed. + +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_entails cls (checking_clause cl) = Invalid mcheck -> + is_model mcheck (inverse_clauses (checking_clause cl)). +Proof. + 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. + +Lemma check_invalid_entails {cls cl m} : + 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). +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. + *) + + + Import Semilattice. + Import ISL. + + +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. + +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) + (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. + split; [|split]. + - lsets. + - lsets. + - eapply is_update_of_only_model_of. exact hincl. + eapply m. + now rewrite (clauses_conclusions_levels cls). +Qed. + +Section InitModels. + +Definition init_clause_of_level l := + (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 + else Clauses.In (init_clause_of_level l) cls. + + + Definition zero_declared m := + exists k, LevelMap.MapsTo Level.zero (Some (Z.of_nat (S 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]. + 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 := + 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. + +End InitModels. + +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; + model_updates : LevelSet.t; + clauses_declared : clauses_levels cls ⊂_lset V; + 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). + Coercion model_of : t >-> model. + + 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). + 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. + have hupd := I.model_updates x.(model_valid). + eapply is_update_of_ext in hupd. + 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 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 (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 -> + 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 := {| + 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 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. + 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. + + 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) + (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 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 := m.(model_model); + only_model_of_V := _; + model_updates := w; clauses_declared := _; + model_valid := {| model_model := m'.(model_model) |} |}. + Proof. + - have mupd := I.model_updates m. eapply is_update_of_ext in mupd. + eapply zero_declared_ext; tea. + - move=> l inv. + have mupd := I.model_updates m. eapply is_update_of_ext in mupd. + 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 => //. + 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. + - 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 (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' _ _ _ _). + 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. + - now apply m. + 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. + + 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 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 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. + - eapply enabled_clauses_ext; tea. + eapply is_update_of_ext, model_valid0. + - apply model_valid. + 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_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. + 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_nes_singleton //=. + 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. + 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 (Model.valuation_of_model (model_of m)) Level.zero) < (to_val (Model.valuation_of_model (model_of m)) l) + else + (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. + 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_nes_singleton //=. + 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. + 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 (Model.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_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. + 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 (Model.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 (Model.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. + Import CorrectModel. + Record t := + { levels : LevelSet.t; + clauses : Clauses.t; + correct_model :> CorrectModel.t levels clauses }. + + Program Definition init_model : t := + {| levels := LevelSet.singleton Level.zero; + clauses := Clauses.empty; + correct_model := CorrectModel.init_model |}. + + Lemma clauses_levels_declared m : clauses_levels (clauses m) ⊂_lset levels m. + Proof. + exact m.(correct_model).(CorrectModel.clauses_declared). + Qed. + + Lemma init_model_levels : + 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 : + 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. + 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). + 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 k : + ~ LevelSet.In l (clauses_levels clauses) -> + strictly_updates clauses W m 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']. + { 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. + { 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'. + - eapply trans_update; tea. + Qed. + + Lemma is_model_add clauses l k m : + ~ LevelSet.In l (clauses_levels clauses) -> + is_model m clauses -> + is_model (LevelMap.add l k m) clauses. + 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. + + 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) => //. + 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. + Hint Rewrite @levelexprset_singleton : set_specs. + 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)%levels. + 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 := Clauses.add (init_clause_of_level l) m.(clauses) |}. + 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. + { 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). + 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.(correct_model).(only_model_of_V) k. + firstorder; subst. all:rewrite /Level.eq. + * now eexists. + * exists x. right; split => //. intros ->. + apply LevelSetFact.not_mem_iff in hneq. contradiction. + - 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 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 => //. + Qed. + + Lemma declare_level_clauses {m l 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. + 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.(correct_model) cls := + | None => None + | Some (inl m') => Some (inl {| correct_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 _ _ (correct_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. + + 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) /\ + 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)). + Proof. + funelim (enforce_clauses m cls) => //=. + intros [= <-]. clear -u. + 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. + - eapply entails_ℋ_entails_L. + eapply to_entails_all. + 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 consistent_opt_val (val : Level.t -> option Z) (cls : Clauses.t) := + + clauses_sem val cls. + + Definition consistent_opt cls := + exists val : Level.t -> option Z, consistent_opt_val val cls. + + 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 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. + 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). + 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. exists (Z_valuation_of_model m); split. + - apply valuation_of_model_pos. + - apply model_valuation. + Qed. + + Definition inconsistent_opt cls := ~ (consistent_opt cls). + + Definition inconsistent cls := ~ (consistent cls). + + Lemma model_entails_loop m v : + clauses m ⊢a v → succ v -> False. + Proof. + 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)). + 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_loop {m cls u} : + enforce_clauses m cls = Some (inr u) -> + entails_loop m cls. + Proof. + now move/enforce_clauses_loop_simple. + Qed. + + Definition defined_valuation_of {A} V (v : Level.t -> option A) := + forall l, LevelSet.In l V -> exists x, v l = Some x. + + Instance proper_defined_valuation_of {A} : + Proper (LevelSet.Equal ==> Logic.eq ==> iff) (@defined_valuation_of A). + Proof. + intros x y ? ?? ->. + rewrite /defined_valuation_of. + now setoid_rewrite H. + Qed. + + Definition inconsistent_opt_ext m cls := + 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} : + 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 interp_expr_defined {model} le : + defined_model_of (LevelSet.singleton le.1) model -> + 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 /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. + rewrite /valuation_of_value. cbn. + intros h; specialize (h _ eq_refl). + 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. + - destruct x, y; cbn; try congruence. now noconf H. + - intros hr. destruct x, y; cbn; depelim hr; try congruence. + Qed. + + 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_nes_add (SL := Zopt_semi) v le u. + 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 (Z_valuation_of_model m) u). + Proof. + move: u. + apply: elim. + - intros [l k] => //= hin. + 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_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_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. + 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. + have [l|hd] := interp_nes_defined_val v loop. + { move/incl. apply def. } + congruence. *) + 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_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. + + 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'. + + 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_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 -> + 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]]. + 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. } + now cbn. + Qed. + + Lemma clauses_sem_def_equiv {model cls} : + defined_model_of (clauses_levels cls) model -> + 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. + 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. + + + 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. + 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_nes_ex mineq. + rewrite eqiprems in semcl. subst iprems. + 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. + move/opt_valuation_of_model_inv: evconcl => [mconcl [hmconcl eq]]. + subst vconcl. + rewrite /level_value_above. + 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 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 model cls. + 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 def_clause_sem_valid {model cl} : + defined_model_of (clause_levels cl) model -> + clause_sem (Z_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 (Z_valuation_of_model model) cls <-> is_model model cls. + Proof. + intros def. rewrite clauses_sem_def_equiv //. + apply clauses_sem_valid. + Qed. + + Theorem check_invalid_valuation {cls cl 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]. + Proof. + move/check_invalid=> [ism _ _ en inval]. + have hpos := opt_valuation_of_model_pos. + have semcls := valid_clauses_model_opt _ _ ism. + 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 => //. + move=> hmf [= eq]. subst y. now eexists. } + { move/clause_sem_valid. contradiction. } + 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 := 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. + Qed. + + 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_nes_add. + Qed. + + 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_nes_singleton interp_expr_opt. + - intros le x h nin. + rewrite interp_nes_add_opt_Z interp_expr_opt h //=. + f_equal. now rewrite interp_nes_add. + Qed. + + 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_nes_singleton. + now move/interp_expr_opt_inv. + - intros le x h nin z. + 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_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_nes_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 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_entails (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. intros ne. now right. + - move/check_entails_entails: ch. now left. + Qed. + + 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_clauses_Z cls cls' := + forall v : Level.t -> Z, + positive_valuation v -> + 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 _). + + Lemma contraP P Q : (P -> Q) -> (~ Q -> ~ P). + Proof. intros f hp q. apply (hp (f q)). Qed. + + 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 {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. + 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. + 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. 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) : + 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_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 -> + ~ 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. + 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 := + enforce_clauses m (inverse_clauses cl). + + 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 []; 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' => //. + - 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 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. + 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. + + 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. + + Instance con_nat : Consistent nat. + Proof. + intros x; cbn. lia. + Qed. + +Definition check_entailsb cls cl := + match check_entails cls cl with + | IsLooping _ _ _ => false + | Valid => true + | Invalid _ => false + end. + +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). + 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_entailsb (clauses m) cl <-> entails (clauses m) cl. +Proof. + 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_entails_entails: ec. +Qed. + +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_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_entails_entails: ec => ent. + intros _. + eapply entails_model_valid; tea. +Qed. + +Definition valid_model_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. + now rewrite -checkb_entails check_entails_model. +Qed. + +Definition valid_all_model_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 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. +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. + +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_entailsb. + funelim (check_entails (clauses m) cl) => //. + - clear H. symmetry in Heqcall. + now move/check_entails_model_looping: Heqcall. + - clear H H0. symmetry in Heqcall. split => //. + move/check_entails_entails: Heqcall => ent. + intros [m' []]; exfalso. + eapply entails_model_valid in ent; tea. contradiction. + - clear H H0. symmetry in Heqcall. split => //. + move/check_invalid: Heqcall => -[]. now eexists; split => //. +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 m' (clauses m), enabled_clause m' cl & ~ valid_clause m' cl]. +Proof. + rewrite -checkb_entails. + rewrite negb_iff /is_true negb_true_iff. + apply check_entails_neg_exists_model. +Qed. + +Definition consistent_clauses cls := + exists val : Level.t -> Z, positive_valuation val /\ clauses_sem val cls. + +(* The valution here is in 𝐙 + ∞: + - clauses max (∞, ...) >= x are trivially valid. + - clauses max ... >= ∞ are invalid. + + 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]. + 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 -> + clause_sem v cl. + +Definition valid_clauses_Zinf cls cls' := + forall v : Level.t -> option Z, + positive_opt_valuation v -> + clauses_sem v cls -> + clauses_sem v cls'. + +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_Zinf cls cl : valid_clause_Zinf cls cl -> valid_clause_Z cls cl. +Proof. + 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 valid_clause_Z_mon cls cls' cl : + Clauses.Subset cls cls' -> valid_clause_Zinf cls cl -> valid_clause_Zinf cls' cl. +Proof. + intros hsub vz v vpos clsem. + eapply vz => //. eapply clauses_sem_subset; tea. +Qed. + +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 hsub vz vz'. eapply valid_clause_Z_mon in vz'; tea. contradiction. +Qed. + +Lemma check_clause_invalid_Zinf m mcheck cl : + check_entails (clauses m) cl = Invalid mcheck -> ~ valid_clause_Zinf (clauses m) cl. +Proof. + move/check_invalid_valuation => [vpos csem hdef clsem]. + now move=> /(_ (opt_valuation_of_model mcheck) vpos csem). +Qed. + +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 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. + intros hwf. destruct (enforce_dec m (Clauses.singleton cl)) => //. + - 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 : + 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. + intros hwf; 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) }. +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. + +Definition check_entails_clauses (cls : Clauses.t) (cls' : Clauses.t) : bool := + Clauses.for_all (check_entailsb cls) cls'. + +Lemma check_entails_clauses_spec m cls' : + check_entails_clauses (clauses m) cls' <-> clauses m ⊢ℋ cls'. +Proof. + rewrite /check_entails_clauses. + rewrite [is_true _]Clauses.for_all_spec. + split. + move=> ha cl /ha. + rewrite -/(is_true (check_entailsb (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 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 //. +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. + +(** 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 := + ((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_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). + 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_entails eqn:ec. + - move/check_entails_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_entails_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_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). + 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_entails eqn:ec. + - move/check_entails_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. + +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_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). + 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_entails eqn:ec. + - move/check_entails_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_entails_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_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). + 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_entails eqn:ec. + - move/check_entails_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. + eapply (le_add (n := 1)). + rewrite !add_join !add_distr add_neutral join_comm. + exact hle. + - reflexivity. +Qed. + +End CounterExample2. + +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 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 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 total_model m : is_total_model (model m) (clauses m). +Proof. + split. apply model_enabled. apply model_ok. +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 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. + +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. + +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_wf. + 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 check_clause_valid m cl wf : + check_clause_wf m cl wf -> valid_clause_Z (clauses m) cl. +Proof. + 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)). + { 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_wf_spec m cl wf : + check_clause_wf m cl wf <-> valid_clause_Z (clauses m) cl. +Proof. + destruct (check_clause_wf m cl) eqn:ec. + - split => // _. + now apply check_clause_valid in ec. + - split => // hv. + apply check_clause_invalid in ec. + contradiction. +Qed. + +Lemma check_clause_undeclared m cl : + check_clause m cl = None <-> ~ clause_levels cl ⊂_lset (levels m). +Proof. + 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. + +Lemma check_clause_spec m cl : + forall b, check_clause m cl = Some b -> + b <-> valid_clause_Z (clauses m) cl. +Proof. + funelim (check_clause m cl) => //. + clear H Heqcall. intros b [= <-]. + apply check_clause_wf_spec. +Qed. + +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_clauseP {m cl} : reflect_opt + (~ clause_levels cl ⊂_lset (levels m)) + (valid_clause_Z (clauses m) cl) + (check_clause m cl). +Proof. + 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 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. + + +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 : + check_entailsb (clauses m) cl -> valid_clause_Z (clauses m) cl. +Proof. + apply check_entails_valid_Z. +Qed. + +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_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. + 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 -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 -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. + +Module LoopChecking (LS : LevelSets). + Module Impl := Deciders(LS). + Import Impl.CorrectModel. + Import Impl.I. + Import Impl.Abstract. + + Definition t := t. + + Definition model (x : t) : Model.model := model x. + + 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. + apply clauses_levels_declared. + Qed. + + Notation univ := NES.t. + + Import UnivConstraintType.ConstraintType (Le, Eq). + + Definition constraint := (univ * UnivConstraintType.ConstraintType.t * univ). + + Local Definition to_clauses (cstr : constraint) : Clauses.t := + let '(l, d, r) := cstr in + match d with + | 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 + | 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 => //=. + - 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. + 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 *) + 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' = Clauses.add (Impl.init_clause_of_level l) (Impl.Abstract.clauses m). + Proof. apply declare_level_clauses. Qed. + + 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 : t) c : option (t + 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. + + Import Semilattice. + 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_Z m (to_clauses cls). + Proof. + move/enforce_clauses_inconsistent. + intros incon v vpos clssem csem. + apply incon. red. exists v. split => //. + apply clauses_sem_union. split => //. + 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. + + 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_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_entails m c := + check_entails_model_clauses m (to_clauses c). + + (* Checking corresponds to entailment in the free semilattice *) + 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_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 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_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). + Proof. eapply zero_declared. Qed. + + 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). + Proof. + apply model_valuation. + 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/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 new file mode 100644 index 000000000..125a11ba8 --- /dev/null +++ b/common/theories/LoopChecking/HornClauses.v @@ -0,0 +1,2083 @@ +(* 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 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.Common Require Universes. +From MetaRocq.Common Require Import Common 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. + 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. + + Notation premises := NES.t. + Definition clause : Type := premises × LevelExpr.t. + + Module Clause. + + Definition t := clause. + + Definition eq : t -> t -> Prop := Logic.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 [n t0] [n0 t1]; cbn; repeat constructor. + destruct (LevelExprSet.compare_spec n n0); repeat constructor; tas. + 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. + + 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). + Module ClausesOrd := OrdProperties Clauses. + + Ltac clsets := ClausesDecide.fsetdec. + Infix "⊂_clset" := Clauses.Subset (at level 70). + Infix "=_clset" := Clauses.Equal (at level 70). + + 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. + 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 Logic.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 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. + + 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. + + #[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) := 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) := 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) := + 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. + 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_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. + 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. + + 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 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 = + 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. + 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 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. + + 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 t), a; cbn; constructor; lia. + * intros h; specialize (hle H h). depelim hle. cbn. + destruct (max_premise_of l t); 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. + + + 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 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 => //. + - move=> [inW ->]. exists (l, k'). rewrite levelexprset_of_levels_spec. + split => //. + 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/NES.levels_spec => [k]. + 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' => //=. 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. + 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. + * intros ->. exists (add_clause n cl); split => //. now apply add_clauses_spec. + apply clause_levels_spec. right. + destruct cl; cbn. destruct t0 => //. + Qed. + + Lemma add_clause_0 cl : add_clause 0 cl = cl. + Proof. + destruct cl as [prems [concl k]]; cbn. + 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, 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. + 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 NES.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)). + 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. + + Definition entails_clauses (cls cls' : Clauses.t) := + Clauses.For_all (entails cls) cls'. + + 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' : NES.t) := + cls ⊢a u → u' /\ cls ⊢a u' → u. + + 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' -> + in_pred_closure cls (prems, concl) -> in_pred_closure cls (prems', concl). + Proof. + intros eq. apply NES.equal_exprsets 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 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. + - 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. + 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)). + { apply NES.equal_exprsets. 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. + 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. + 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. + 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. + 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. + 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. + + + 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, 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 -> : n + (k + 1) = (n + k) + 1 by lia. + constructor. + Qed. + + (* 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 /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)) (NES.add_list (premises_of_level_set V) u) -> LevelExprSet.In (x, Z.of_nat (k + 1)) u. + Proof. + rewrite NES.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. + - 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 NES.add_comm. apply IHentails. + intros x; rewrite LevelExprSet.add_spec. firstorder. + Qed. + + 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.union concl' prem, concl). + Proof. + intros hyp. + move: concl'. + apply: NES.elim. + - intros le. rewrite union_comm union_add_singleton. + now apply entails_weak. + - intros le prems ih. + rewrite 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 (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 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 NES.add_comm. now eapply entails_weak. + exact H1. + Qed. + + Lemma entails_cumul_one {cls prems prems' concl} : + entails_all cls prems prems' -> + entails cls (union prems prems', concl) -> + entails cls (prems, concl). + Proof. + revert prems' prems concl. + apply: NES.elim. + - intros. specialize (H le). forward H by now apply LevelExprSet.singleton_spec. + cbn in H. + eapply entails_add; tea. + now rewrite -union_add_singleton. + - intros le prems ih _ prem concl' hadd 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. + Qed. + + Lemma entails_all_cumul {cls prems prems' concl} : + entails_all cls prems prems' -> + entails_all cls (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, 1 + k)) -> + entails cls (singleton (concl, k), (concl, Z.of_nat n + 1 + k)). + Proof. + induction n in k |- *; auto. + 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, 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 (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. + Qed. + + Lemma entails_all_concl_union {cls prems 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.union_spec. intros []. now apply l. now apply r. + - intros hu; split; + move=> le hin; move: (hu le) => /fwd //; + 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 union prems prems' → union concl concl'. + Proof. + move=> l r. + rewrite entails_all_concl_union. split. + rewrite 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. + 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; cbn -[Z.add]. + have -> : (- n + n = 0)%Z by lia. + now rewrite add_prems_0 //= add_expr_0. + 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_ℋ_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_lower cls (u : premises) l k : + (exists k', LevelExprSet.In (l, k') u /\ k <= k') -> + cls ⊢ u → (l, k). + Proof. + 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. + Qed. + Hint Resolve entails_all_tauto : entails. + + 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). + apply (entails_all_shift 1) in IHn. + 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. + + 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. + cbn -[Z.add]. + rewrite Z.add_comm. + apply entails_pred_closure_neg. + 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. 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. + 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, 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 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. + 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. + + Lemma entails_all_succ {cls s} : + cls ⊢a succ_prems s → s. + Proof. + intros cl hin. + 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. + + 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. + + 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 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 -> + 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. + 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. + + 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. + + 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. + 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. + + 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_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 union_comm; auto with entails. Qed. + + Lemma join_assoc {cls s t u} : + cls ⊢ℋ s ∨ t ∨ u ≡ s ∨ (t ∨ u). + Proof. + rewrite union_assoc; auto with entails. + Qed. + + Lemma join_left {cls s t} : + cls ⊢ℋ s ⋞ s ∨ t. + Proof. + eapply to_entails_all. + rewrite 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 n s t} : + cls ⊢ℋ add_prems n (s ∨ t) ≡ add_prems n s ∨ add_prems n t. + Proof. + rewrite NES.add_prems_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 union_comm [r ∨ _]union_comm. + now apply join_congr_left. + Qed. + + End Theory. + + Section prems_semi. + Obligation Tactic := idtac. + 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. + 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 apply Theory.succ_congr. + - 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. + - apply Theory.succ_join. + Defined. + End prems_semi. + + Import Semilattice. + Section Morphism. + 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); + 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 (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 x y) ≡ join (f y) (f x). + Proof. rewrite !of_join. apply join_comm. Qed. + + End Morphism. + +End Clauses. diff --git a/common/theories/LoopChecking/HornSemilatticeEquiv.v b/common/theories/LoopChecking/HornSemilatticeEquiv.v new file mode 100644 index 000000000..152f7b6b4 --- /dev/null +++ b/common/theories/LoopChecking/HornSemilatticeEquiv.v @@ -0,0 +1,939 @@ +(* 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 Import ISL := InitialSemilattice LS. + Import NES. + + 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 []. + + 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. + + 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_pres_clause p cl := + p ⊢ℒ singleton (concl cl) ≤ premise cl. + + Definition entails_L_pres_clauses 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'. + + 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_pres_clause (relations_of_clauses cls) cl. + Proof. + induction 1. + - rewrite /entails_L_pres_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_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_pres_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_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. + 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. + 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 : + 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_pres_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. + + 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. + 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. + + 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 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_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. + + + 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. + 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 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' -> + 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_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. + 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_impl 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_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. + + 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. + + + 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]%rel. + 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. + + 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), + 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. + + + 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. + 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_rels v p -> interp_nes v l ≡ interp_nes v r)%sl -> + p ⊢ℒ l ≡ r. + Proof. + intros SL hv. + specialize (hv (ids p) (interp_rels_init 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_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_syn. + intros v. red in hv. specialize (hv v). + rewrite -interp_rels_clauses_sem. move/hv. + 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_syn. + 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. diff --git a/common/theories/LoopChecking/InitialSemilattice.v b/common/theories/LoopChecking/InitialSemilattice.v new file mode 100644 index 000000000..6160942b7 --- /dev/null +++ b/common/theories/LoopChecking/InitialSemilattice.v @@ -0,0 +1,622 @@ +(* 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. + + 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. + + 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. + 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; + zero := NES.singleton (Level.zero, 0%Z); + 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_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 ?? ->. + 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 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. + split. + - 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. + 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 ⊢ℒ l ≤ r /\ cls ⊢ℒ r ≤ l) <-> cls ⊢ℒ l ≡ r. + Proof. + 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} : + 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_rel r := + let '(l, r) := r in + interp_nes v l ≡ interp_nes v r. + + Definition interp_rels c := + List.Forall interp_rel c. + + End interp. + + Definition valid_relation rels 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 (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 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 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_nes_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)). + - now apply add_join. + Qed. + + 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. + 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 ids (rs : rels) : Level.t -> t := (fun l : Level.t => singleton (l, zero)). + + 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_nes_singleton //= /ids //=. + rewrite add_prems_singleton //=. rewrite /add_expr //= comm neutral. + apply entails_refl. + - move=> [] l k x ih hnin. + 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)). + 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_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. + 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_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. + + (* 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. + + 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 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. + 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 (S:=S) 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 S SL V H0). + Qed. + + 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. + 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. + 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. + +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/Interfaces.v b/common/theories/LoopChecking/Interfaces.v new file mode 100644 index 000000000..9af357557 --- /dev/null +++ b/common/theories/LoopChecking/Interfaces.v @@ -0,0 +1,370 @@ +(* 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. +From MetaRocq.Utils Require Import utils NonEmptyLevelExprSet. + +From MetaRocq.Common Require Universes. +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. + 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 FMapOTInterface (E : UsualOrderedType). + Module OT := FMapOrderedType_from_UsualOrderedType E. + Include FMapInterface.Sfun OT. +End FMapOTInterface. + +Module Q <: Quantity. + Include OrdersEx.Z_as_OT. + Import CommutativeMonoid. + + 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. + + Program Instance add_inj_lt z : Injective (Z.add z) lt lt. + Next Obligation. lia. Qed. + + 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 : OrderedTypeWithLeibnizWithReflect. + Declare Module LevelSet : LevelSet_fun Level. + 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. + +Import NES.OfQ. +Import NES. + +#[export] Existing Instance Level.reflect_eq. +#[export] Existing Instance NES.reflect_eq. + +Module LevelSetFact := WFactsOn Level LevelSet. +Module LevelSetProp := WPropertiesOn Level LevelSet. +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. +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. +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 + 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. + +#[global] Instance levelexprset_eq_dec : Classes.EqDec LevelExprSet.t := Classes.eq_dec. + +Derive NoConfusion for NES.t. + +Module LevelExprSetDecide := WDecide (LevelExprSet). +Ltac lesets := LevelExprSetDecide.fsetdec. + +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. + +Lemma in_singleton l : LevelSet.In l (LevelSet.singleton l). +Proof. lsets. Qed. + +Lemma in_leset_levels le prems : LevelExprSet.In le prems -> LevelSet.In le.1 (leset_levels prems). +Proof. + destruct le. intros hin. + 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'. +Proof. + rewrite LevelSet.union_spec. firstorder. +Qed. + +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. + +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 levels_exprs_non_W_atoms {W prem} : + LevelSet.Equal (leset_levels (non_W_atoms W prem)) (LevelSet.diff (leset_levels prem) W). +Proof. + intros e. unfold non_W_atoms. + 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. + 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 (leset_levels x). +Proof. + split. + - intros he. + intros l hin. + 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. + +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. + +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. + +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. + + + +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 _ (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 _) |- _ ] => + 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/Model.v b/common/theories/LoopChecking/Model.v new file mode 100644 index 000000000..de4012c2f --- /dev/null +++ b/common/theories/LoopChecking/Model.v @@ -0,0 +1,3532 @@ +(* 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 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. + + 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). + + 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 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. + 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 𝐍). + + 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). + + 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] + 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 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.Common Require Universes. +From MetaRocq.Common Require Import Common Interfaces HornClauses HornSemilatticeEquiv. +From Equations Require Import Equations. +Set Equations Transparent. + +Module Model (LS : LevelSets). + Module Export Clauses := HornSemilattice (LS). + Import LS. + Export LS.NES. + 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. + + 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. + + 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)%opt (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 {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. + + 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. + 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). + + 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) := 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 (m : model) (cls : clauses) : 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. + + 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 (s : LevelSet.t) : model -> model -> Prop := + | 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'' -> + 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 + else strictly_updates cls upd minit m. + + #[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. + 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 ==> 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 ==> Logic.eq ==> Logic.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 ==> Logic.eq ==> Logic.eq ==> Logic.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'''. + split. + 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. + 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. + 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 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'. + 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 ==> 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), + strictly_updates cls ls m m' -> + P ls m m' -> + strictly_updates cls 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. + 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'' : + 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. + revert w m m'. + apply: strictly_updates_elim. + { solve_proper. } + - intros. + eapply update_trans; tea. 2:{ econstructor 1; tea. reflexivity. } + eapply update_one. 3:tea. auto. reflexivity. lsets. + - intros. + specialize (H2 _ H3 H4). + eapply update_trans; tea. 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. econstructor => //. 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 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. + - 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. + + #[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 is_model_proper : Proper (eq ==> Clauses.Equal ==> eq) is_model. + Proof. + 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. + Proof. + intros m m' hm ? ? -> ? ? ->. + unfold update_model. + 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. + + 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. + unfold eqwm; split. + - intros [] => //=. + - intros [] [] [] => //=. cbn in *. split; now symmetry. + - intros [] [] [] [] [] => //=; cbn in *. split. + now transitivity t2. now transitivity t3. + Qed. + + 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. + unfold eqwm; split. + - intros [] => //=. + - intros [] [] [] => //=. cbn in *. split; now symmetry. + - intros [] [] [] [] [] => //=; cbn in *. split. + now transitivity l0. now transitivity t1. + 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. + + 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. + 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) /\ + (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 => //. apply one_update. 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 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. + 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 => //. + 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. + 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''. + 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 => //. + 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: 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 t0 t1 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' =_lset 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 (t0 :: l)). split => //. + 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 m cls. + Proof. + induction 1. + - 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 H1. + - auto. + Qed. + + Lemma check_model_None {cls acc} : + check_model cls acc = None <-> is_model acc.2 cls. + 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 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'} : + 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 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. + 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. + move: H2. rewrite H0. move/LevelSet.singleton_spec => ->. split => //. + - 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 H1 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. + 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 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 -> + 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 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]]. + 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 => //. cbn -[Z.add]. 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 H1. + 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 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 []. + 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 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 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 (n + x)%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 (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 (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. + 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) /\ + (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. + + + 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 => //. 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. + + 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' = - premise_min s + k' + premise_min s by lia. + - move=> hin; exists (l, k + premise_min s). split; rewrite /add_expr => //. + 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) /\ + (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 -(notations) LevelExprSet. + + Definition max_premise_value (m : model) (l : premises) : option Z := + 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 : + 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 k m) l = 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. + + 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. + + 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 ->]]. + setoid_replace (LevelSet.union LevelSet.empty w') with w' => //. + intros x; lsets. + Qed. + + Lemma check_model_is_model {W cls m} : + check_model cls (W, m) = None <-> is_model m cls. + 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 m cls /\ 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 trans_update; 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. + 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. + 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. + + 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 -> + 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. 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 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 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. + + 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)/(_ (model_of_empty _)). + rewrite LevelSetProp.empty_union_1 //. 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. + 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 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 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. + + 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 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. + now left. now right. + + intros. eapply IHstrictly_updates2 in H2 as []. + left; lsets. + eapply IHstrictly_updates1 in H2 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 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 H2 as []. + left; lsets. + eapply IHstrictly_updates2 in H2 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 eq]]. + cbn. split. + - lsets. + - apply strictly_updates_incl in su. lsets. + - 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 su'. + depelim H2; rewrite ?H3. 2:{ rewrite H2; constructor. } + 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: 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. now rewrite eq. + 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 le0 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 trans_update; 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 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 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 : + min_premise (restrict_model W m) prems = Some v -> + min_premise m prems = Some v. + Proof. + 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' : + 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. + 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 su as [v [hmin above heq]]. + rewrite hm in hmin, above. + exists v. split => //. + eapply min_premise_restrict with W => //. + 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 incl as [inconcl inprems incls]. cbn in *. + elim ncl. exists k'. eapply restrict_model_spec. split => //. + + 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. + 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. + - 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: (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 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 su'. + intros l [k hin]. apply su' in hin as [k' []]. now exists k'. } + now rewrite eqm in h. + 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 trans_update; 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 m' (cls ⇂ W) -> + is_model (model_update m m') (cls ⇂ W). + 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 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 => //. + - rewrite H1. 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 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 m cls -> ~~ 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 : 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. + 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. + + 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 : model) : 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. + + 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 + 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 m (cls ↓ W) -> + strictly_updates cls W' m m' -> + exists l, LevelSet.In l W' /\ ~ LevelSet.In l W. + Proof. + 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 => //. + - move=> ls ls' m m' m'' su ihsu su' ihsu' vm. + destruct (ihsu 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 H1 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 =_lset LevelSet.union U W'. + Proof. + move/check_model_spec => [w'' [su eq]]. rw eq. 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. + 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. + 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. + 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. + 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 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. + + 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. + 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] + 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_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 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 := + 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 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 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_all_lower. + 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. + 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 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. + 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 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. + 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). + specialize (ihsu' 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. + 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. + + 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. + + 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. + + 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 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 (level prem) (clauses_levels cls). + { rewrite clauses_levels_spec. exists x; split => //. rewrite /clause_levels. + 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]. + 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 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. cbn -[Z.add]. lia. + Qed. + + Lemma entails_model_valid cls cl : entails cls cl -> + forall m, is_model m cls -> 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. + + 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 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 => ->. + 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 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. + 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. + + 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 m cls <-> + is_model (shift_model n m) cls. + 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 model cls -> + 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 model cls -> + 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/ModelValuation.v b/common/theories/LoopChecking/ModelValuation.v new file mode 100644 index 000000000..df47f8349 --- /dev/null +++ b/common/theories/LoopChecking/ModelValuation.v @@ -0,0 +1,92 @@ + + 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_nes prems). + + Definition clauses_sem (cls : clauses) : Prop := + Clauses.For_all clause_sem cls. + End Interpretation. + + + End Semantics. + + (* 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_nes_singleton. + cbn. red. rewrite -!add_distr. rewrite -add_join. + now rewrite join_sub. + Qed. + + + + 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_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_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. + cbn in *. lia. + Qed. + + Lemma clauses_sem_entails_all {cls prems concl} : + cls ⊢a prems → concl -> + (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_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). + - 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/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 new file mode 100644 index 000000000..97ce4ece4 --- /dev/null +++ b/common/theories/LoopChecking/Models.v @@ -0,0 +1,605 @@ +(* 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 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.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. + + + (* 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 => + LevelMap.add l (max_clause_premise_of l cls) acc) levels m. + + Definition zero_model n levels : model := + LevelSet.fold (fun l acc => LevelMap.add l n acc) levels (LevelMap.empty _). + + Definition premises_model V n cl : LevelSet.t * model := + let levels := LevelSet.union (clause_levels cl) V in + (levels, premises_model_map (zero_model n 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 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 i n} : LevelMap.MapsTo l n (zero_model i ls) <-> LevelSet.In l ls /\ n = i. + 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 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 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']]. + 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. + + 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 i} : + forall cl, Clauses.In cl cls -> + 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. + 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 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 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 levels_spec. now exists mink. + Qed. + + Lemma in_premises_model V i cl : + forall l, + 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. + 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 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 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 None 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 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 -> + 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.1 l.2 cls (prems, concl) hin. + forward hs. cbn. eapply LevelExprSet.elements_spec1; rewrite -H. + constructor. destruct l; reflexivity. depelim hs. + exists l.1, y. apply premises_model_map_spec. left. + split => //. + eapply clauses_premises_levels_spec. eexists; split; tea => //. + rewrite //= levels_spec. exists l.2. + setoid_rewrite <- LevelExprSet.elements_spec1. rewrite -H //=. + constructor. destruct l; reflexivity. + 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). + + Definition min_model_map (m : model) cls : model := + Clauses.fold min_model_clause cls m. + + 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).1 None a). + change (LevelExprSet.fold (fun '(l, k0) (acc : model) => add_max l (Some k0) acc) (premise cl) + (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).1). + { 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).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).1). + red. + destruct (LevelMap.find (concl cl).1 a) eqn:hl. + * apply LevelMap.find_2 in hl. + 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).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).1 (level_value a (concl cl).1)). + forward hext. rewrite add_max_spec. left. split => //. + destruct hext as [l' []]; exists l'; split => //. constructor. } + Qed. + + Lemma min_model_map_acc cls m : + let map := min_model_map m cls in + (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]. + split. + 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. + have [hm hnin] := min_model_clause_spec l x a. + specialize (hnin l k (or_introl ha)). + exact hnin. } + split; [|reflexivity]. + intros l 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 cls m : + let map := min_model_map m cls in + (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) /\ + m ⩽ map. + Proof. + cbn. + rewrite /min_model_map. + 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) + & 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 l k hm. specialize (hgen l 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 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).1 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 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. + 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 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 cls m. + specialize (hext l k inm). firstorder. + - 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]. + * apply incl. apply clauses_levels_spec. exists cl. split => //. + red in incl'. + apply clause_levels_spec. + clear -incl'. firstorder. subst. left. apply levels_spec. + firstorder. + * 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/OldPresentation.v b/common/theories/LoopChecking/OldPresentation.v new file mode 100644 index 000000000..e53bdf529 --- /dev/null +++ b/common/theories/LoopChecking/OldPresentation.v @@ -0,0 +1,266 @@ + 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. diff --git a/common/theories/LoopChecking/PartialLoopChecking.v b/common/theories/LoopChecking/PartialLoopChecking.v new file mode 100644 index 000000000..69c3366d6 --- /dev/null +++ b/common/theories/LoopChecking/PartialLoopChecking.v @@ -0,0 +1,1012 @@ +(* 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 + 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 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 Equations Require Import Equations. + +From MetaRocq.Common.LoopChecking Require Import Common Interfaces HornClauses Model Models. + +Set Equations Transparent. + +Module LoopCheckingImpl (LS : LevelSets). +(* 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. + +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 model_model cls; + }. +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. + +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. + +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). +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. + +(** 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' -> + 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. + +Local Open Scope Z_scope. + +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. + 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. + +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 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 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).1)%Z. +Proof. + intros hwv. unfold valid_clause. + 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. + 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. + unfold level_value_default. destruct (level_value m l) as [vl|] eqn:hl; revgoals. + { 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. + enough (k + z <= (v_minus_w_bound W m) + 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 (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. } + assert (y <= maxpreml - (premise_min preml))%Z. + { rewrite eqpminpre. rewrite H2 in eqminpre; symmetry in eqminpre. + 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]]. + 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)) = + (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.1. unfold levelexpr_value in eqmaxpre. + rewrite -eqmaxpre in vm. + have := (@levels_exprs_non_W_atoms W prem (level exmax)). + rewrite leset_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 := + match r with + | Model w m _ => Some m.(model_model) + | Loop v _ _ => None + end. + +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 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. + +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. + +Definition sum_W W (f : LevelSet.elt -> nat) : nat := + LevelSet.fold (fun w acc => acc + f w)%nat W 0%nat. + +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. + - move=> x a s' s'' inw nins' hadd + afx. + move/fwd; [lia|] => ih /hadd[] eq. now move: afx; rewrite eq. + now apply ih. +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 -> + let clsdiff := cls_diff cls W in + measure W cls m = 0%nat -> is_model m clsdiff. +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).1 = 0). lia. + rewrite /measure in hm. + 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. + +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 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 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_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 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. + + +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 := {}. + +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 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) + (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 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 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). *) + (* 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 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. + eapply strictly_updates_is_update_of_restrict in upd; tea. + 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). + 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). + { 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. } + 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. + - 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)). + { 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. } + eapply invalid_clause_measure in nvalid; tea. + exists (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 (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 {2}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. + +(* 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. + +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. + +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"] +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_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 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 (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 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 + conclusion is different. Clearly |W| < |V|, but |Wcls| is not + necessarily < |V| *) + | Loop u incl isloop := Loop u incl isloop + | Model Wvw mcls' hsub := Model Wvw {| model_model := model_model mcls' |} _ } } } + } + } + . +Proof. + 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. + 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. + - 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_init_map _ _). clearbody ne. + have hu := model_updates mwc. + eapply check_model_is_update_of in eqm as [eqm incl]; tea. + 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 (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_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 inclW : W ⊂_lset V. + { rewrite union_idem in eqm. + have incl' := strictly_updates_incl eqm. + etransitivity; tea. etransitivity; tea. } + eapply strictly_updates_is_update_of in eqm; tea. + rewrite union_idem 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. 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''. + 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:{ 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. + 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'. + 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 (level (concl cl)) W). + { intros hin. rewrite in_clauses_with_concl in H. intuition auto. } + exists (concl cl).1. split => //. } + 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. + 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. + +End LoopCheckingImpl. diff --git a/common/theories/LoopChecking/UnivLoopChecking.v b/common/theories/LoopChecking/UnivLoopChecking.v new file mode 100644 index 000000000..b2a556403 --- /dev/null +++ b/common/theories/LoopChecking/UnivLoopChecking.v @@ -0,0 +1,2075 @@ +(* 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 ∈ 𝐍, 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 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 Import UnivConstraintType 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. + + Definition zero := Level.lzero. + Definition is_global l := + match l with + | Level.lvar _ | Level.lzero => false + | Level.level _ => true + end. + + Lemma is_global_zero : ~~ is_global zero. + Proof. reflexivity. Qed. +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. + + 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. + +Module LS (* <: LevelSets *). + Module Level := MoreLevel. + Module LevelSet := LevelSet. + 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 := + 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. + +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. + +Module UnivLoopChecking. + Module LoopCheck := LoopChecking LS. + Import LoopCheck.Impl.Abstract. + Import LoopCheck.Impl.I. + Import Universes (valuation). + Import LoopCheck. + + 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. + 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. + + 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. + 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 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. + + 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 Classes.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. + Module ZUnivConstraintSetDecide := WDecide ZUnivConstraintSet. + Ltac zucsets := ZUnivConstraintSetDecide.fsetdec. + + 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, 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. + + 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. + + 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.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); + 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)); + repr_init : forall l c, LevelSet.In l (LoopCheck.levels model) -> init_constraint_of_level l = Some c -> UnivConstraintSet.In c constraints + }. + + Definition levels m := (LoopCheck.levels m.(model)). + + Lemma declared_zero (m : univ_model) : LevelSet.In Level.lzero (levels m). + Proof. + apply zero_declared_in_levels. + Qed. + + 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 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 levels_in_to_atoms l u : + LevelSet.In l (NES.levels (to_atoms u)) <-> Universes.LevelSet.In l (Universe.levels u). + Proof. + rewrite levels_spec. + rewrite /in_to_atoms. + split. + - move=> [] k. move/to_levelexprzset_spec_2 => [] 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. + + 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). + 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. + + 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_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). + 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 : Level.t -> S) 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_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. + - 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_nes_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 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_nes_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 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 |}. + 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. + + 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 _ := + 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: eq0. + rewrite /LoopCheck.clauses => ->. rewrite UnivConstraintSet.add_spec => -[]. + * move=> ->. clsets. + * move=> hin. + move: (repr_constraints m c' hin) => h. clsets. + - move/LoopCheck.enforce_clauses: eq0. + rewrite /LoopCheck.clauses => -> c'. + rewrite UnivLoopChecking.Clauses.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. + - 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) := + let '(l, d, r) := c in + LevelSet.union (Universe.levels l) (Universe.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 (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)) <-> + 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. + 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' []] 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 : + 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. + + 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: eq0. + - clear H Heqcall. reflexivity. + Qed. + + Definition valuation_to_Z (v : Universes.valuation) : Level.t -> Z := + fun l => Z.of_nat (val v l). + + Lemma positive_valuation_to_Z v : + positive_valuation (valuation_to_Z v). + Proof. + unfold positive_valuation, valuation_to_Z. intros; lia. + Qed. + + Existing Instance Zopt_semi. + + Lemma interp_nes_valuation_to_Z_to_atoms 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 //=. + rewrite /valuation_to_Z; cbn; lia_f_equal. + - intros [l k] x hx hnin. + rewrite to_atoms_add /valuation_to_Z !interp_nes_add_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_nes_valuation_to_Z_to_atoms. + split; cbn. + * constructor; lia. + * intros s; depelim s. lia. + - rewrite clauses_sem_eq !interp_nes_valuation_to_Z_to_atoms. + 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 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_nes_singleton //= val_singleton //=. + - intros [l k] x hx hnin. + rewrite !interp_nes_add_opt_Z //=. + destruct interp_nes => //. + 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. + 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. + { 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 := + 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. + + Lemma satisfies_singleton v x : satisfies v (UnivConstraintSet.singleton x) <-> satisfies0 v x. + 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 + | None => + (m = None) \/ (exists minit, m = Some minit /\ + (~ (declared_univ_cstrs_levels (levels minit) cstrs) \/ + ~ (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. + 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 : 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. + 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). + 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. + + 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. + + 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. + 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. + 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. + 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. + 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) -> + 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 + | 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) := + { | exist (Some model) eq with inspect (init_constraint_of_level l) := + { | exist (Some c) eqc => Some {| model := model; constraints := UnivConstraintSet.add c m.(constraints) |} + | exist None eqc => False_rect _ _ } ; + | exist None eqdecl := None }. + Proof. + (* - 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.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. + + - 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. + Qed. + + 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_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. + funelim (declare_level m l) => //. + - move=> [=] <-. cbn. + clear H H0 Heqcall. cbn. unfold levels. cbn. + 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. + + + + 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. 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 [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 : + 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. *) + + 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 : Universes.valuation) : LevelMap.t nat := + let add_val l := LevelMap.add l (val v l) in + LevelSet.fold add_val V (LevelMap.empty _). + + 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 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_nes_to_atoms {V v} (u : Universe.t) : + wf_valuation V v -> + LevelSet.Subset (Universe.levels u) V -> + 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_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_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. + cbn. rewrite eq. unfold Universes.LevelExpr.t. + lia. + Qed. + + 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_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. + + 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 (Impl.Abstract.levels m) /\ + Universe.levels r ⊂_lset (Impl.Abstract.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 : t) : wf_valuation (Impl.Abstract.levels m) (LoopCheck.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) : + satisfies (to_valuation (valuation m)) (constraints m). + Proof. + destruct m as [m cstrs repr repr_inv]. cbn. + 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 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 m). + Qed. + + 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 (Classes.eq_dec x l); firstorder. subst. now left. + Qed. + + Lemma interp_level_of_valuation {V v l} : + LevelSet.In l V -> + to_Z_val (to_val (of_valuation V v)) l = Z.of_nat (val v l). + Proof. + move=> hin. + 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. + + + 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 => //. + 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 => //. + 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'. + Proof. + move=> sub l /clauses_levels_spec; rewrite clauses_levels_spec. + firstorder. + Qed. + (* Lemma in_to_clauses_elem {l k a} : *) + + 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 -> + forall cl, LevelExprSet.Exists (fun lk : LevelExprSet.elt => cl = (to_atoms r, lk)) (to_levelexprzset l) -> + 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 -[le]. + erewrite interp_nes_to_atoms. + rewrite to_of_valuation_univ. + { intros ? hin; apply hlev. cbn. lsets. } + 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. + 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 : + LoopCheck.levels (UnivLoopChecking.model m) ⊂_lset V -> + satisfies v (constraints 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. + 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). + 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). + 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). + 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 (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. + erewrite !interp_nes_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'. + 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_nes v u). + Proof. + split; cbn. + - intros n x. rewrite interp_add_prems; cbn. lia. + - intros x y. rewrite interp_nes_union; cbn. lia. + Qed. + + Definition check (m : univ_model) (c : UnivConstraint.t) : bool := + LoopCheck.check_constraint m.(UnivLoopChecking.model) (to_constraint c). + Derive Signature for satisfies0. + + + 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_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. + + 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). + + Definition valid_constraint rels 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. + + Import Semilattice. + Import ISL. + + Definition model_val (m : univ_model) := 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)). + + 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). + 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_rel interp_nes_union. cbn in hrepr. + 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 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'. cbn in hv, hv' |- *. + unfold model_Z_val in *; lia. + Qed. + + (** The constraints in the model are already valid. *) + Lemma interp_univ_cstrs_of_m_Z m : + interp_univ_cstrs (model_Z_val m) (constraints m). + Proof. + intros uc hin. red. + have h := repr_constraints m _ hin. + 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)%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_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 => //. } + by []. + Qed. + + + 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 => //=. + cbn. lia. + Qed. + + Hint Rewrite Universe.levels_singleton : set_specs. + + (** Interpretation in the semilattice of natural numbers *) + Lemma interp_nes_val {V} (v : Level.t -> nat) (u : Universe.t) : + Universe.levels u ⊂_lset V -> + wf_valuation V v -> + Universe.interp_nes v u = Universes.val (to_valuation v) u. + Proof. + 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. + 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 {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. + move=> wfv. + destruct cl as [[l []] r] => //= decl; + 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 : + 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. + 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_Z m. + 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. + + Instance nat_opt_semi : Semilattice (option nat) nat := opt_semi Natsemilattice. + + 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. + + Infix "⊩Z" := valid_Z_model (at level 70, no associativity). + + 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 -> 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)). + + 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. + + 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. + 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. + 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 (to_Z_val (valuation m)) c. + Proof. + 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). + + Infix "⊩" := valid_model (at level 70, no associativity). + + Theorem check_any_completeness {m : univ_model} {c} : + check_entails (model m) (to_constraint c) <-> m ⊩ c. + Proof. + rewrite LoopCheck.check_entails_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 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 (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. + 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 : 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. + have [wfm wfc] := wf_valuation_union wfv. + move: (hv Z Zsemilattice (to_Z_val v)). + 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/Reflect.v b/common/theories/Reflect.v index 9a612fb0e..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. @@ -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 := @@ -223,6 +221,7 @@ 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 constraint_lt_ind_dep := Induction for UnivConstraint.lt_ Sort Prop. Derive Signature for UnivConstraint.lt_. @@ -254,10 +253,36 @@ 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 Stdlib 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. - f_equal. apply uip. Qed. From Stdlib Require Import RelationClasses. @@ -265,8 +290,8 @@ 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'. - now rewrite (lt_level_irrel l l4). + - 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'. @@ -276,7 +301,7 @@ Proof. - intros l'; depelim l'. now elim (irreflexivity l). now elim (irreflexivity l). - now rewrite (lt_level_irrel l l4). + now rewrite (lt_universe_irrel l l4). Qed. Module LevelSetsUIP. @@ -335,19 +360,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. @@ -359,10 +384,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. @@ -377,7 +402,7 @@ Module ConstraintSetsUIP. apply constraint_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]. 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 a11af0a6e..4bea21410 100644 --- a/common/theories/Universes.v +++ b/common/theories/Universes.v @@ -1,8 +1,8 @@ -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.Common Require Import BasicAst config. -From Stdlib Require Import ssreflect. +From MetaRocq.Utils Require Import utils MRMSets MRFSets NonEmptyLevelExprSet MRClasses. +From MetaRocq.Common Require Import BasicAst config UnivConstraintType. +From Stdlib Require Import ssreflect ssrfun. Local Open Scope nat_scope. Local Open Scope string_scope2. @@ -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 @@ -158,6 +173,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. + Defined. + End Level. Module LevelSet := MSetAVL.Make Level. @@ -171,7 +192,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). @@ -212,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 *) @@ -252,7 +287,14 @@ 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)). + 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). + + Definition level : t -> Level.t := fst. Definition get_level (e : t) : Level.t := fst e. @@ -276,7 +318,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 +373,19 @@ Module LevelExpr. End LevelExpr. -Module LevelExprSet := MSetList.MakeWithLeibniz LevelExpr. +Module LevelExprSet. + Include MSetList.MakeWithLeibniz LevelExpr. + + 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. Module LevelExprSetOrdProp := MSetProperties.OrdProperties LevelExprSet. Module LevelExprSetProp := LevelExprSetOrdProp.P. @@ -354,263 +408,49 @@ 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 }. - -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. + Import CommutativeMonoid. - Definition t := nonEmptyLevelExprSet. + Instance comm_monoid : IsCommMonoid nat := + {| zero := 0%nat; + one := 1%nat; + add := Nat.add |}. - (* 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. + Instance add_inj_eq n : Injective (add n) eq eq. + Proof. + red. intros x y; rewrite /eq /add //=. lia. + Qed. + + Instance add_inj_lt n : Injective (add n) lt lt. + Proof. + red. intros x y; rewrite /eq /add //=. lia. + Qed. + + Definition reflect_eq : ReflectEq t := _. + Definition eq_leibniz x y : eq x y -> x = y := fun e => e. + End Q. + + Module NES := NonEmptyLevelExprSet Level Q LevelSet LevelExpr LevelExprSet. + Include NES. #[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). - 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 (only parsing). + + Lemma make'_inj l l' : of_level l = of_level l' -> l = l'. Proof. destruct l, l' => //=; now inversion 1. Qed. @@ -619,11 +459,16 @@ 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). + 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. @@ -632,14 +477,17 @@ Module Universe. Definition is_level (u : t) : bool := (LevelExprSet.cardinal u =? 1)%nat && is_levels u. - (* Used for quoting. *) - Definition from_kernel_repr (e : Level.t * nat) (es : list (Level.t * nat)) : t - := add_list es (Universe.make e). + Definition zero := of_level 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 @@ -651,32 +499,151 @@ 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. 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. { intros ? H. apply irreflexivity in H; assumption. } { 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. + +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. @@ -684,8 +651,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. @@ -697,9 +664,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) @@ -716,10 +683,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) @@ -736,10 +703,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. @@ -771,7 +738,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]. @@ -797,6 +764,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 : @@ -807,92 +776,36 @@ 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 *. 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. *) - - -Module ConstraintType. - Inductive t_ : Set := Le (z : Z) | 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. - 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. - 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 n, Le m => Z.compare n m - | 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. - Qed. - - Lemma eq_dec x y : {eq x y} + {~ eq x y}. - Proof. - unfold eq. decide equality. apply Z.eq_dec. - Qed. -End ConstraintType. + revert l. apply: Universe.elim. + - intros le. rewrite val_singleton. lia. + - intros le x. rewrite val_add. lia. +Qed. Module UnivConstraint. - Definition t : Set := Level.t * ConstraintType.t * Level.t. + Definition t : Type := Universe.t * ConstraintType.t * Universe.t. Definition eq : t -> t -> Prop := eq. Definition eq_equiv : Equivalence eq := _. @@ -900,16 +813,17 @@ Module UnivConstraint. 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_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' t t' l2 l2' : Level.lt l1 l1' -> 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 Level.lt_strorder; eassumption). + try (eapply LevelExprSet.lt_strorder; eassumption). eapply ConstraintType.lt_strorder; eassumption. - intros ? ? ? X Y; invs X; invs Y; constructor; tea. etransitivity; eassumption. @@ -924,20 +838,25 @@ Module UnivConstraint. Definition compare : t -> t -> comparison := fun '(l1, t, l2) '(l1', t', l2') => - compare_cont (Level.compare l1 l1') + compare_cont (LevelExprSet.compare l1 l1') (compare_cont (ConstraintType.compare t t') - (Level.compare l2 l2')). + (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 (Level.compare_spec l1 l1'); cbn; repeat constructor; tas. - invs H. + 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 (Level.compare_spec l2 l2'); cbn; repeat constructor; tas. - invs H. reflexivity. + 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}. @@ -948,64 +867,69 @@ Module UnivConstraint. Definition eq_leibniz (x y : t) : eq x y -> x = y := id. End UnivConstraint. -Module ConstraintSet := MSetAVL.Make UnivConstraint. -Module ConstraintSetFact := WFactsOn UnivConstraint ConstraintSet. -Module ConstraintSetOrdProp := MSetProperties.OrdProperties ConstraintSet. -Module ConstraintSetProp := ConstraintSetOrdProp.P. -Module CS := ConstraintSet. -Module ConstraintSetDecide := ConstraintSetProp.Dec. -Module ConstraintSetExtraOrdProp := MSets.ExtraOrdProperties ConstraintSet ConstraintSetOrdProp. -Module ConstraintSetExtraDecide := MSetAVL.Decide UnivConstraint 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 : UnivConstraint.t) := +Module UnivConstraintSet := MSetAVL.Make UnivConstraint. +Module UnivConstraintSetFact := WFactsOn UnivConstraint UnivConstraintSet. +Module UnivConstraintSetOrdProp := MSetProperties.OrdProperties UnivConstraintSet. +Module UnivConstraintSetProp := UnivConstraintSetOrdProp.P. +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. + +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). + +Definition declared_univ_cstr_levels levels (cstr : UnivConstraint.t) := let '(l1,_,l2) := cstr in - LevelSet.In l1 levels /\ LevelSet.In l2 levels. + 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_cstr_levels levels (cstr : UnivConstraint.t) : bool := +Definition is_declared_univ_cstr_levels levels (cstr : UnivConstraint.t) : bool := let '(l1,_,l2) := cstr in - LevelSet.mem l1 levels && LevelSet.mem 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. (** {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 := @@ -1017,28 +941,49 @@ 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 arguments + 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. + + + 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 × (Instance.t × ConstraintSet.t). + Definition t := list name × (LevelInstance.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' : 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, ConstraintSet.empty)). + Definition empty : t := ([], (LevelInstance.empty, UnivConstraintSet.empty)). - Definition instance : t -> Instance.t := fun x => fst (snd x). - Definition constraints : t -> ConstraintSet.t := fun x => snd (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 * ConstraintSet.t) := fun x => x. + Definition dest : t -> list name * (LevelInstance.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)). @@ -1051,38 +996,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 /\ @@ -1090,13 +1035,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) /\ @@ -1104,20 +1049,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. @@ -1141,17 +1086,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 *) @@ -1188,116 +1133,222 @@ 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. 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) : 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'). + Derive Signature for satisfies0. -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 : UnivConstraintSet.t -> Prop := + UnivConstraintSet.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 (UCS.union φ1 φ2) + <-> (satisfies v φ1 /\ satisfies v φ2). + Proof. + unfold satisfies. split. + - 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. -Definition consistent ctrs := exists v, satisfies v ctrs. + Lemma satisfies_subset φ φ' val : + UnivConstraintSet.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. + 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 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 using Type. - split. - 2: move=> h v /h [v' [/satisfies_union [??] eqv']]; exists v'; split=> //. - 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. + Lemma subset_levels_exprs {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 Universe.levels, Universe.leset_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 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 := Universe.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 (Universe.levels le) levels -> + val v le = val v' le. + Proof. + move=> hl le /subset_levels_exprs sub. + rewrite !val_max. + 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. + 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 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. -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. + 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. -Definition leq_universe_n {cf} n φ (u u' : Universe.t) := - if check_univs then leq0_universe_n n φ u u' else True. + 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. -Definition lt_universe {cf} := leq_universe_n 1. -Definition leq_universe {cf} := leq_universe_n 0. + 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. -Definition eq0_universe φ (u u' : Universe.t) := - forall v, satisfies v φ -> val v u = val v u'. + Lemma val_plus v n l : val v (Universe.plus n l) = val v l + n. + Proof using Type. + 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_levelexpr_plus. eapply (val_In_le _ v) in inx'. rewrite <- eqv in inx'. + simpl in *. unfold LevelExprSet.elt, LevelExpr.t in *. lia. + exists (LevelExpr.add n max). split. apply H. + exists max; split; auto. + now rewrite val_levelexpr_plus. + Qed. -Definition eq_universe {cf} φ (u u' : Universe.t) := - if check_univs then eq0_universe φ u u' else True. + Lemma val_succ v l : val v (Universe.succ l) = val v l + 1. + Proof. by rewrite (val_plus v 1). Qed. -(* ctrs are "enforced" by φ *) + Definition leq0_universe φ (u u' : Universe.t) := + forall v, satisfies v φ -> val v u <= val v u'%Z. -Definition valid_constraints0 φ ctrs - := forall v, satisfies v φ -> satisfies v ctrs. + Definition leq_universe φ (u u' : Universe.t) := + if check_univs then leq0_universe φ u u' else True. -Definition valid_constraints {cf} φ ctrs - := if check_univs then valid_constraints0 φ ctrs else True. + Definition lt_universe ϕ l r := leq0_universe ϕ (Universe.succ l) r. -Definition compare_universe {cf} φ (pb : conv_pb) := - match pb with - | Conv => eq_universe φ - | Cumul => leq_universe φ - end. + 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. -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 - ). + (* ctrs are "enforced" by φ *) -Ltac unfold_univ_rel := - unfold eq_universe, leq_universe, lt_universe, leq_universe_n, valid_constraints in *; - destruct check_univs; [unfold_univ_rel0 | trivial]. + Definition valid_constraints0 φ ctrs + := forall v, satisfies v φ -> satisfies v ctrs. -Section Univ. - Context {cf}. + 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, 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, 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. @@ -1310,14 +1361,30 @@ Section Univ. (** **** 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. lia. + 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 φ). @@ -1326,37 +1393,62 @@ Section Univ. 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 leq_universe_n_trans n φ : Transitive (leq_universe_n (Z.of_nat n) φ). + Global Instance leq0_universe_trans φ : Transitive (leq0_universe φ). Proof using Type. - intros u u' u'' H1 H2; unfold_univ_rel. + intros u u' u'' H1 H2; unfold_univ_rel0. lia. Qed. Global Instance leq_universe_trans φ : Transitive (leq_universe φ). - Proof using Type. apply (leq_universe_n_trans 0). Qed. + Proof using Type. + intros u u' u'' H1 H2; unfold_univ_rel. + lia. + Qed. + + Global Instance leq0_universe_preorder ϕ : PreOrder (leq0_universe ϕ) := {}. - Global Instance lt_universe_trans φ : Transitive (lt_universe φ). - Proof using Type. apply (leq_universe_n_trans 1). Qed. + Global Instance eq0_universe_equivalence ϕ : Equivalence (eq0_universe ϕ) := {}. - Lemma eq0_leq0_universe φ u u' : - eq0_universe φ u u' <-> leq0_universe_n 0 φ u u' /\ leq0_universe_n 0 φ u' u. + Lemma eq0_universe_leq0_universe φ u u' : + eq0_universe φ u u' <-> leq0_universe φ u u' /\ leq0_universe φ u' u. Proof using Type. 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_univ_rel => //. - apply eq0_leq0_universe. + 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). @@ -1377,33 +1469,34 @@ Section Univ. 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. 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_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_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 φ). 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. @@ -1433,7 +1526,7 @@ Section Univ. 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. @@ -1443,17 +1536,32 @@ Section Univ. 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. + End Univ. +Ltac unfold_univ_rel0 := + unfold eq0_universe, leq0_universe, 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, valid_constraints in *; + destruct check_univs; [unfold_univ_rel0 | trivial]. + + Module Sort. Inductive t_ {univ} := sProp | sSProp | sType (_ : univ). @@ -1551,7 +1659,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) *) @@ -1746,7 +1854,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. @@ -1834,24 +1942,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. @@ -1880,26 +1986,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. @@ -1917,7 +2014,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. @@ -1926,51 +2023,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. @@ -1986,14 +2077,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. @@ -2057,7 +2143,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. @@ -2067,7 +2153,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. @@ -2098,7 +2184,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. @@ -2109,12 +2195,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. @@ -2219,7 +2305,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. @@ -2237,7 +2323,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 => //=. @@ -2270,14 +2356,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 := @@ -2342,7 +2428,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. @@ -2363,7 +2449,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 φ : @@ -2393,40 +2479,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' -> @@ -2434,7 +2487,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 : @@ -2467,7 +2520,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 @@ -2477,53 +2530,92 @@ 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_cstr : UnivSubst UnivConstraint.t := - fun u c => (subst_instance_level u c.1.1, c.1.2, subst_instance_level u c.2). +#[global] Instance subst_level_instance_level_instance : UnivLevelSubst LevelInstance.t := + fun u l => map (subst_level_instance_level u) l. -#[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_level_instance_level_expr : UnivLevelSubst LevelExpr.t := +fun u e => (subst_level_instance_level u e.1, e.2). -#[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. +Definition subst_instance_level (u : Instance.t) (l : Level.t) : Universe.t := + match l with + | Level.lzero + | Level.level _ => Universe.of_level l + | Level.lvar n => + match nth_error u n with + | 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). #[global] Instance subst_instance_universe : UnivSubst Universe.t := - fun u => 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 => (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. @@ -2565,82 +2657,266 @@ 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_instance_level_expr u e - : closedu_level_expr 0 e -> subst_instance_level_expr u e = e. + 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. 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 = Universe.make e. + Proof. + 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 + : 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 eq_univ'. - destruct t as [ts H1]. - unfold 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 LevelExprSet.for_all_spec in H; proper. - exact (H _ He'). - now subst. - - apply map_spec. exists e; split; tas. - symmetry; apply closedu_subst_instance_level_expr. - apply LevelExprSet.for_all_spec in H; proper. now apply H. - Qed. - - Lemma closedu_subst_instance u t + apply f_equal. unfold subst_instance. + now rewrite closedu_subst_instance_universe. + Qed. + + 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_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]. + move/subst_level_instance_level_closedu. cbn. + destruct l => //. + Qed. + + 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. + 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_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_level_expr 0 (subst_instance_level_expr u 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 [] Hl X; cbnr. - apply nth_error_In in Hl. + case_eq (nth_error u n); cbnr. intros u' Hl; cbnr. + apply nth_error_In in Hl. cbn in Hl. + intros hn. + rewrite -closedu_universe_plus. cbn. + destruct nth_error eqn:hnth => //. eapply forallb_forall in Hcl; tea. - discriminate. + now eapply nth_error_In. + unfold subst_instance_level_expr. cbn. + intros ->. now cbn. + 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 @@ -2649,12 +2925,7 @@ Section SubstInstanceClosed. intro H. destruct s as [| |t]; cbnr. destruct t as [l Hl]. - apply LevelExprSet.for_all_spec; proper. - intros e He. eapply map_spec in He. - destruct He as [e' [He' X]]; subst. - apply subst_instance_level_expr_closedu. - apply LevelExprSet.for_all_spec in H; proper. - now apply H. + now apply subst_instance_universe_closedu. Qed. Lemma subst_instance_closedu t : @@ -2662,35 +2933,46 @@ Section SubstInstanceClosed. 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 - | 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 : Universe.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 := +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). @@ -2704,20 +2986,20 @@ 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. 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 := @@ -2725,15 +3007,17 @@ 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. -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 '(l1, d, l2) := + string_of_level l1 ^ " " ^ + print_constraint_type d ^ " " ^ string_of_level l2. + +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 print_univ_constraint " /\ " (UnivConstraintSet.elements t). diff --git a/common/theories/UniversesDec.v b/common/theories/UniversesDec.v index f17bc7315..f0b3101ae 100644 --- a/common/theories/UniversesDec.v +++ b/common/theories/UniversesDec.v @@ -1,55 +1,26 @@ -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. -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). +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 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]. - 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 : ConstraintSet.In ?l ?c |- ?x \/ ?y ] - => first [ lazymatch x with context[LevelSet.In _ (ConstraintSet.fold _ c _)] => idtac end; - left - | lazymatch y with context[LevelSet.In _ (ConstraintSet.fold _ c _)] => idtac end; - right ] - end - | rewrite !LevelSet.union_spec - | progress rewrite <- ?ConstraintSet.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 +29,107 @@ 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 + + +(* 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 : 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) + : ~ 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 : ConstraintSet.elt) : ConstraintSet.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 - := 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 * ConstraintSet.t -> ContextSet.t * ConstraintSet.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)), - ConstraintSet.fold - (fun c => ConstraintSet.add (uniquify_constraint_for lvls true c)) - cs - ConstraintSet.empty), - ConstraintSet.fold - (fun c => ConstraintSet.add (uniquify_constraint_for lvls false c)) - cstr - ConstraintSet.empty). - -Definition declare_and_uniquify_and_combine_levels : ContextSet.t * ConstraintSet.t -> ContextSet.t * ConstraintSet.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)). - -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 - : 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). -Proof. - cbv [ConstraintSet.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]; - [ now firstorder idtac | ]. - rewrite ConstraintSet.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 - : 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). -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] - | 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). -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] - | 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 - : ConstraintSet.In c cstr - -> ConstraintSet.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] - | destruct ? - | rewrite ConstraintSet_In_fold_add - | rewrite ConstraintSet.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. -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] - | 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 ConstraintSet.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 ConstraintSet.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 ConstraintSet.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 ConstraintSet.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 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 *; - cbn [fst snd valuation_poly valuation_mono] in *. - revert Hv Hv' Hagree. - progress repeat setoid_rewrite ConstraintSet.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]. - 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 : ConstraintSet.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. +Definition levels_of_universe (u : Universe.t) : LevelSet.t := Universe.levels u. -Lemma global_uctx_invariants__declare_and_uniquify_and_combine_levels cs cstr - : global_uctx_invariants (declare_and_uniquify_and_combine_levels (cs, cstr)).1. +Lemma levels_of_universe_spec u cstr (lvls := levels_of_universe u) + : levels_declared (lvls, cstr) u. 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 *. - repeat first [ progress subst - | progress cbv [LevelSet.Exists ConstraintSet.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 : ConstraintSet.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 ]. + 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 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'). +Lemma declared_univ_cstrs_levels_spec cstrs : declared_univ_cstrs_levels (univ_constraints_levels cstrs) cstrs. 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 [ConstraintSet.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 [ConstraintSet.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. + intros cl hin. apply declared_univ_cstr_levels_spec. + intros l; rewrite univ_constraints_levels_spec. exists cl; split => //. 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. +Definition leq0_universe_dec (cf := config.default_checker_flags) ϕ u u' : {@leq0_universe ϕ u u'} + {~@leq0_universe ϕ u u'}. 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 ] ] ]. + 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. now exists v. Qed. -Definition consistent_extension_on_dec cs cstr : {@consistent_extension_on cs cstr} + {~@consistent_extension_on cs cstr}. +Definition leq_universe_dec cf ϕ u u' : {@leq_universe cf ϕ u u'} + {~@leq_universe cf ϕ u u'}. 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. + 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 +149,32 @@ 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. now exists v. +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 c97822819..38341f87f 100644 --- a/common/theories/uGraph.v +++ b/common/theories/uGraph.v @@ -1,3184 +1,648 @@ (* 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 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. From Equations Require Import Equations. Import ConstraintType. +Set Equations Transparent. -Import MRMonadNotation. +Import UnivLoopChecking. +Definition universe_model := UnivLoopChecking.univ_model. +Definition init_model : universe_model := UnivLoopChecking.init_model. -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 GoodConstraintSet. -Module GoodConstraintSetProp := WPropertiesOn GoodConstraint GoodConstraintSet. -Module GoodConstraintSetDecide := WDecide (GoodConstraintSet). -Module GCS := GoodConstraintSet. -Ltac gcsets := GoodConstraintSetDecide.fsetdec. - -Definition gcs_equal x y : Prop := - LevelSet.Equal x.1 y.1 /\ GoodConstraintSet.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). -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 - := GoodConstraintSet.add y (GoodConstraintSet.singleton x). - -Lemma GoodConstraintSet_pair_In x y z - : GoodConstraintSet.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 : GoodConstraintSet.t -> bool := - GoodConstraintSet.for_all (gc_satisfies0 v). - -Arguments GoodConstraintSet.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 (GoodConstraintSet.for_all _ _)]GoodConstraintSet.for_all_spec. - split. - - intros [sat1 sat2] x. - rewrite GoodConstraintSet.add_spec. move=> [->|] //. - rewrite GoodConstraintSet.singleton_spec => -> //. - - intros ha. split; apply ha; - rewrite GoodConstraintSet.add_spec; - rewrite GoodConstraintSet.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 : UnivConstraint.t) - : option GoodConstraintSet.t - := let empty := Some GoodConstraintSet.empty in - let singleton := fun x => Some (GoodConstraintSet.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 (GoodConstraintSet.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. - now subst. - - unfold gc_satisfies. - intros gc. - eapply GoodConstraintSet.for_all_spec in gc; auto. 2:proper. - specialize (gc c). - rewrite -> GoodConstraintSet.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 GoodConstraintSet.t) - := S1 <- S ;; - S2 <- gc_of_constraint uc ;; - ret (GoodConstraintSet.union S1 S2). - -Definition gc_of_constraints (ctrs : ConstraintSet.t) : option GoodConstraintSet.t - := ConstraintSet.fold add_gc_of_constraint - ctrs (Some GoodConstraintSet.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. - etransitivity. eapply iff_forall. - intro; eapply imp_iff_compat_r. eapply ConstraintSetFact.elements_iff. - set (l := ConstraintSet.elements ctrs). simpl. - transitivity ((forall uc, InA Logic.eq uc l -> satisfies0 v uc) /\ - (forall gc, GoodConstraintSet.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 uctx_invariants (uctx : ContextSet.t) - := ConstraintSet.For_all (declared_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 - | 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 * GoodConstraintSet.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) -: GoodConstraintSet.In gc ctrs - <-> ConstraintSet.Exists - (fun e => on_Some (GoodConstraintSet.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). - 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). - - 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 GoodConstraintSet.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 : GoodConstraintSet.In ?A GoodConstraintSet.empty |- _ - => apply GoodConstraintSetFact.empty_iff in HH; contradiction HH - | HH : GoodConstraintSet.In ?A (GoodConstraintSet.singleton ?B) |- _ - => apply GoodConstraintSetFact.singleton_1 in HH; subst gc - | HH : GoodConstraintSet.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) - 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 := - GoodConstraintSet.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. -Proof. - rewrite /add_cstrs GoodConstraintSet.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. - 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 !GoodConstraintSet.fold_spec. subst s'. - induction (GoodConstraintSet.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. -Proof. - intros s s' eq x y H. - red in H. intros e. - rewrite !add_cstrs_spec. - rewrite H. firstorder auto. -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). -Proof. - unfold make_graph. unfold wGraph.E. - simpl. - assert (XX: forall E, EdgeSet.In e (GoodConstraintSet.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) - \/ EdgeSet.In e E). { - intro E. rewrite GoodConstraintSet.fold_spec. - induction (GoodConstraintSet.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). - 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 GoodConstraintSet.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. - 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. -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. - -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. - -Global Instance invariants_proper_iff : Proper ((=_g) ==> iff) invariants. -Proof. - intros g g' eq. split. now rewrite eq. - now rewrite eq. -Qed. - -Global Instance acyclic_no_loop_proper : Proper ((=_g) ==> iff) acyclic_no_loop. -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. -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) := - ~~ check_univs - || (u1 == u2) - || leqb_universe_n_gen false u1 u2. - - Definition check_eqb_universe_gen (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 := - GoodConstraintSet.for_all check_gc_constraint_gen. - - Definition check_constraints_gen ctrs := - match gc_of_constraints ctrs with - | Some ctrs => check_gc_constraints_gen ctrs - | None => false - end. - - Definition eqb_univ_instance_gen (u1 u2 : Instance.t) : bool := - forallb2 (fun l1 l2 => check_eqb_universe_gen - (Universe.make' l1) (Universe.make' l2)) u1 u2. - - Definition leqb_sort_gen (s1 s2 : Sort.t) := - leqb_sort_n_ (fun _ => check_leqb_universe_gen) false s1 s2. - - Definition check_leqb_sort_gen (s1 s2 : Sort.t) := - (s1 == s2) - || leqb_sort_gen s1 s2. - - Definition check_eqb_sort_gen (s1 s2 : Sort.t) := - (s1 == s2) - || (leqb_sort_gen s1 s2 && leqb_sort_gen s2 s1). - -End CheckLeqProcedure. - -(* This section: specif in term of gc_uctx *) -Section CheckLeq. - Context {cf:checker_flags}. - - Context (G : universes_graph) - uctx (Huctx: global_gc_uctx_invariants uctx) (HC : gc_consistent uctx.2) - (HG : Equal_graph G (make_graph uctx)). - - Definition on_inl {A B : Type} (P : A -> Prop) (x : A + B) := - match x with - | inl x0 => P x0 - | inr _ => True - end. - - - Definition gc_level_declared l - := VSet.In l uctx.1. - - 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 gc_expr_declared e - := on_Some_or_None (fun l => VSet.In l uctx.1) (LevelExpr.get_noprop e). - - Definition gc_levels_declared (u : Universe.t) - := LevelExprSet.For_all gc_expr_declared u. - - 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. - - 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. - - 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. - - (** ** Check of leq ** *) - - 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. - - 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'). - 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. - 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 leqb_level_n n (l l' : Level.t) - := leqb_vertices G n l l'. - - 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 leqb_expr_n_spec := leqb_expr_n_spec_gen _ leqb_level_n_spec. - - Import NonEmptySetFacts. - - Definition leqb_expr_univ_n := (leqb_expr_univ_n_gen leqb_level_n). - - 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'. - 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 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. - - 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. - - 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. - - 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. - - 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. - Qed. - - Definition check_leqb_universe_spec := check_leqb_universe_spec_gen _ leqb_level_n_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. - - 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 := - GoodConstraintSet.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 GoodConstraintSet.for_all_spec. now intros x y []. - apply GoodConstraintSet.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 eqb_univ_instance := (eqb_univ_instance_gen leqb_level_n). - - Definition leqb_sort := (leqb_sort_gen leqb_level_n). - - Definition check_leqb_sort := (check_leqb_sort_gen leqb_level_n). - - 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. - Proof using Type. - unfold check_eqb_sort_gen; toProp; left. - apply eqb_refl. - Qed. +Definition uctx_invariants (uctx : ContextSet.t) + := declared_univ_cstrs_levels (LevelSet.add Level.lzero uctx.1) uctx.2. - Definition check_eqb_sort_refl := check_eqb_sort_refl_gen _ leqb_level_n_spec. +Definition global_uctx_invariants (uctx : ContextSet.t) + := ~ LevelSet.In Level.lzero uctx.1 /\ uctx_invariants uctx. + +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. + 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 + ~ (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 allcstrs) + | Some g' => + levels g' =_lset LevelSet.union uctx.1 (levels g) /\ + constraints g' =_ucset allcstrs + end. +Proof. + 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 -eql in hdecll. split => //. + now rewrite eqc hdeclc. + - move/enforce_constraints_None: ec. + 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. + +End Push. + +Import UnivLoopChecking. - 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. +(** ** Check of consistency ** *) - Definition gc_eq_sort φ := - eq_sort_ (fun u u' => if check_univs then gc_eq0_universe φ u u' else True). +Equations is_consistent (uctx : ContextSet.t) : bool := +is_consistent uctx := isSome (push_uctx init_model uctx). - Let levels_declared_sort (s : Sort.t) := - Sort.on_sort gc_levels_declared True s. +Lemma satisfies_init v ls : satisfies v (init_constraints_of_levels ls). +Proof. + move=> c /init_constraints_of_levels_spec_inv [l [inz eq]]. + destruct l; noconf eq. + constructor; cbn. lia. + constructor; cbn. lia. +Qed. - Lemma check_eqb_sort_spec_gen leqb_level_n_gen - (leqb_correct : leqb_level_n_spec_gen leqb_level_n_gen) - (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. - Proof. - unfold check_eqb_sort_gen, gc_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. +Lemma is_consistent_spec `{checker_flags} uctx (Huctx : global_uctx_invariants uctx) + : is_consistent uctx <-> consistent uctx.2. +Proof. + 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. + 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 => //. + 2:{ cbn. intros c. ucsets. } + apply satisfies_init. } +Qed. -End CheckLeq. +Section CheckLeqProcedure. -(* This section: specif in term of raw uctx *) -Section CheckLeq2. Context {cf:checker_flags}. + Context (check_cstr : UnivConstraint.t -> bool). - 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 × GoodConstraintSet.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 check_leqb_universe_gen (u1 u2 : Universe.t) := + ~~ check_univs + || (u1 == u2) + || check_cstr (u1, Le, u2). - 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_eqb_universe_gen (u1 u2 : Universe.t) := + ~~ check_univs + || (u1 == u2) + || check_cstr (u1, Eq, u2). - 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_constraint_gen (c : UnivConstraint.t) := + ~~ check_univs || check_cstr c. - 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_constraints_gen (c : UnivConstraintSet.t) := + ~~ check_univs || UnivConstraintSet.for_all check_cstr c. - 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 eqb_univ_instance_gen (u1 u2 : Instance.t) : bool := + forallb2 check_eqb_universe_gen u1 u2. - 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 : GoodConstraintSet.t) := - GoodConstraintSet.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 leqb_sort_gen (s1 s2 : Sort.t) := + leqb_sort_ (fun _ => check_leqb_universe_gen) false s1 s2. - 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_leqb_sort_gen (s1 s2 : Sort.t) := + (s1 == s2) + || leqb_sort_gen s1 s2. - 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_eqb_sort_gen (s1 s2 : Sort.t) := + (s1 == s2) + || (leqb_sort_gen s1 s2 && leqb_sort_gen s2 s1). - Definition check_gc_constraints_complete := - check_gc_constraints_complete_gen _ (leqb_level_n_spec _ _ Huctx' HC' HG'). +End CheckLeqProcedure. - Definition valid_gc_constraints_ext gc := - forall v, satisfies v uctx.2 -> gc_satisfies v gc. +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). - 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. +Definition leq0_universe ctrs (u u' : Universe.t) := + forall v, satisfies v ctrs -> val v u <= val v u'. - 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. +Definition leq_universe {cf : checker_flags} ctrs (u u' : Universe.t) := + if check_univs then leq0_universe ctrs u u' else True. - 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. +Definition eq0_universe φ (u u' : Universe.t) := + forall v, satisfies v φ -> val v u = val v u'. - 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 eq_universe {cf : checker_flags} φ (u u' : Universe.t) := + if check_univs then eq0_universe φ u u' else True. - 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 valid0_cstr φ (c : UnivConstraint.t) := + forall v, satisfies v φ -> satisfies0 v c. - Definition check_constraints_complete := - check_constraints_complete_gen _ (leqb_level_n_spec _ _ Huctx' HC' HG'). +Definition valid_cstr {cf : checker_flags} φ (c : UnivConstraint.t) := + if check_univs then valid0_cstr φ c else True. - Let levels_declared_sort (s : Sort.t) - := Sort.on_sort levels_declared True s. +Definition valid0_cstrs φ (c : UnivConstraintSet.t) := + forall v, satisfies v φ -> satisfies v c. - 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. +Definition valid_cstrs {cf : checker_flags} φ (c : UnivConstraintSet.t) := + if check_univs then valid0_cstrs φ c else True. - 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. +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. - 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. +(* This section: specif in term of gc_uctx *) +Section CheckLeq. + Context (m : universe_model) + uctx (Huctx: global_uctx_invariants uctx) + (HG : model_of_uctx m uctx). - 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 ->. - 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 level_declared l := LevelSet.In l uctx.1. - 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. + Lemma level_declared_model (l : Level.t) : + level_declared l -> LevelSet.In l (levels m). + Proof using HG. + intros Hl;subst. apply HG. + red in Hl; lsets. 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 × GoodConstraintSet.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' : GoodConstraintSet.Empty s' -> - GoodConstraintSet.Equal (GoodConstraintSet.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. + Definition expr_declared (e : LevelExpr.t) + := LevelSet.In e.1 (LevelSet.add Level.lzero uctx.1). - Lemma add_cstrs_union g ctrs1 ctrs2 : - EdgeSet.Equal (add_cstrs (GoodConstraintSet.union ctrs1 ctrs2) g) (add_cstrs ctrs1 (add_cstrs ctrs2 g)). - Proof. - intros e. - rewrite !add_cstrs_spec. - setoid_rewrite GoodConstraintSet.union_spec. - firstorder eauto. - Qed. + Definition levels_declared (u : Universe.t) + := LevelExprSet.For_all expr_declared u. - 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. + Definition levels_declared_sort (s : Sort.t) + := Sort.on_sort levels_declared True s. - 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. + Definition leqb_universe u u' := check m (u, Le, u'). + Definition eqb_universe u u' := check m (u, Eq, u'). - 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. + Definition checkb := check m. - 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. + Definition check_spec (check: UnivConstraint.t -> bool) := + forall c, declared_univ_cstr_levels (LevelSet.add Level.lzero uctx.1) c -> + check c <-> valid0_cstr uctx.2 c. - 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. + Import C (clauses_sem). - Lemma Nbar_max_spec n m v : - Nbar.max n m = v -> - (Nbar.le n m /\ v = m) \/ (Nbar.le m n /\ v = n). + Lemma declared_incl c : + declared_univ_cstr_levels (LevelSet.add Level.lzero uctx.1) c -> + declared_univ_cstr_levels (levels m) c. Proof. - destruct n, m; cbn; firstorder. - destruct (Z.max_spec_le z z0); firstorder; try lia. - left. split; auto. congruence. - right. split; auto. congruence. + 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. - Lemma Nbar_max_spec' n m : - Nbar.le n m -> Nbar.max m n = m. + 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. - destruct n, m; cbn; firstorder. f_equal. lia. + rewrite /interp_cstrs /UnivConstraintSet.For_all. + setoid_rewrite UnivConstraintSet.union_spec. + firstorder. Qed. - Lemma Nbar_max_spec'' n m : - Nbar.le n m -> Nbar.max n m = m. + Lemma interp_nes_val (v : valuation) (u : Universe.t) : + Universe.interp_nes (val v) u = Universes.val v u. Proof. - destruct n, m; cbn; firstorder. f_equal. 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 Nbar_max_le n m k : Nbar.le (Nbar.max n m) k -> - Nbar.le n k /\ Nbar.le m k. + Lemma satisfies0_interp_cstr (v : valuation) c : + satisfies0 v c <-> interp_nat_cstr (val v) c. 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. + 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 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. + 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. + + 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 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. + 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 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_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_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. + - 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. + - 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. + + 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 (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 => _ -> _ -> + 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. + { 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. 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. + Proof. + intros hfw hdecl. + destruct c as [[l d] r]; cbn. + 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) (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]]. + apply H0 in hin. + apply declared_univ_cstr_levels_spec in hin. now apply hin. + Qed. + + Lemma checkb_spec : check_spec checkb. + Proof. + intros c decl. + rewrite /checkb. + 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; 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 [iu ii]. + specialize (hv (to_valuation (shift_valuation v))). + 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. + 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_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_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}. - 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. + Definition check_leqb_universe := (check_leqb_universe_gen checkb). + Definition check_eqb_universe := (check_eqb_universe_gen checkb). - 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. + Lemma check_leqb_universe_spec_gen check + (check_correct : check_spec check) + (l l' : Universe.t) + (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). + 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 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. + Definition check_leqb_universe_spec := check_leqb_universe_spec_gen _ checkb_spec. - 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. + Lemma check_eqb_universe_spec_gen check + (check_correct : check_spec check) + (l l' : Universe.t) + (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). + 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. - 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. + Definition check_eqb_universe_spec := check_eqb_universe_spec_gen _ checkb_spec. - 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. + Lemma fold_left_false {A} l : fold_left (B:=A) (fun _ : bool => xpred0) l false = false. + Proof using Type. + induction l; simpl; eauto. 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. + Definition check_constraints := (check_constraints_gen checkb). + Definition eqb_univ_instance := (eqb_univ_instance_gen checkb). - #[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. + Definition leqb_sort := (leqb_sort_gen checkb). - 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)). - 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. + Definition check_leqb_sort := (check_leqb_sort_gen checkb). - 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. + Definition check_eqb_sort := (check_eqb_sort_gen checkb). - 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. + 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 gc_result_eq (x y : option GoodConstraintSet.t) := - match x, y with - | Some x, Some y => GoodConstraintSet.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. + Definition check_eqb_sort_refl := check_eqb_sort_refl_gen _ checkb_spec. - 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. + (* Let levels_declared_sort (s : Sort.t) := + Sort.on_sort gc_levels_declared True s. *) - 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'. + Lemma levels_declared_uctx u : levels_declared u -> LevelSet.Subset (Universe.levels u) (LevelSet.add Level.lzero uctx.1). 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. + move=> hu l. hnf in hu. + rewrite Universe.levels_spec. + move=> -[k /hu hin]. apply hin. Qed. - Variant gc_of_constraints_view {cf:checker_flags} (s : ConstraintSet.t) : option GoodConstraintSet.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) -> - gc_of_constraints_view s (Some l) - | gc_of_constraints_none : - (exists c, ConstraintSet.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). + 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 check u1 u2 <-> eq_sort uctx.2 u1 u2. Proof. - unfold gc_of_constraints. - rewrite ConstraintSet.fold_spec. - destruct fold_left eqn:eq. - - constructor. - + intros. - setoid_rewrite ConstraintSetFact.elements_iff. setoid_rewrite InA_In_eq. - transitivity ((exists (c : UnivConstraint.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. - revert eq. - generalize (GCS.empty). - induction (ConstraintSet.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 (ConstraintSet.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 (ConstraintSet.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. + unfold check_eqb_sort_gen, eq_sort. + destruct u1, u2; cbnr; split; intuition auto. + - now destruct prop_sub_type. + - toProp. destruct H. + apply (@elimP _ _ (eqb_spec _ _)) in H. noconf H. + reflexivity. + 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. - Lemma gc_of_constraints_union {cf:checker_flags} S S' : - gc_result_eq (gc_of_constraints (ConstraintSet.union S S')) - (S1 <- gc_of_constraints S ;; - S2 <- gc_of_constraints S' ;; - ret (GoodConstraintSet.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]]]. - simpl. - - intros gc. - rewrite HSS' GCS.union_spec HS HS'. - setoid_rewrite ConstraintSet.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. - 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']]]. - cbn. - specialize (HSS'0 c). - rewrite -> ConstraintSet.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']]]. - cbn. - specialize (HSS'0 c). - rewrite -> ConstraintSet.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). + 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 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]. + 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. -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 ((=_cset) ==> R_opt GoodConstraintSet.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 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. + Definition check_eqb_sort_spec := check_eqb_sort_spec_gen _ checkb_spec. -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. + 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. +(* 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' -> @@ -3228,75 +692,213 @@ 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). +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. - 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. + 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_consistent_spec2 `{cf : checker_flags} [gph gctx] : - is_graph_of_uctx gph gctx -> is_consistent gctx <-> wGraph.is_acyclic gph. +Lemma push_uctx_model `{cf : checker_flags} [m uctx uctx' m'] : + push_uctx m uctx' = Some m' -> + model_of_uctx m uctx -> + model_of_uctx m' (ContextSet.union uctx' uctx). Proof. - unfold is_consistent. by move=> /on_SomeP [? [-> <-]]. + move=> he; have := push_uctx_spec m uctx'. rewrite he. + move=> [hlev hcstrs]. unfold 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 MetaRocq.Utils Require Import MRUtils. +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 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). +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 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 (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 (levels 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. + - have hm := is_model_of_uctx m. + eapply push_uctx_model in hp; tea. + split => //. + elim. exists (to_valuation (model_val u)). + 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 hm := is_model_of_uctx m. + have := push_uctx_spec m uctx. + cbn. rewrite hp. + intros [[l [hin hsing]]|[ndecl|nsat]]. + * now apply (proj1 inv l). + * destruct inv. rewrite LevelSetProp.union_sym in ndecl. contradiction. + * apply nsat. exists v. + 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 := {}. + +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. - cbv [global_uctx_invariants uctx_invariants ConstraintSet.For_all declared_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 ] ]. + intros P Q hp hnq p. firstorder. 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). +Instance union_subset_proper : + Proper (LevelSet.Subset ==> LevelSet.Subset ==> LevelSet.Subset) LevelSet.union. Proof. - cbv [global_gc_uctx_invariants uctx_invariants GoodConstraintSet.For_all declared_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 ] ]. + solve_proper. Qed. -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 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. - 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 ] ]. + 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. 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". 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/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/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. diff --git a/erasure/theories/ErasureFunction.v b/erasure/theories/ErasureFunction.v index 20c93e754..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) ==> 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. -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. 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/demo.v b/examples/demo.v index da6939013..9406fa1fd 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; @@ -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/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 8630a8ec6..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), ConstraintSet.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/examples/typing_correctness.v b/examples/typing_correctness.v index 5ce32eea2..4621eae64 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 @@ -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,14 +156,14 @@ 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 = ({| 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/oldLoopChecking.v b/oldLoopChecking.v new file mode 100644 index 000000000..df5f2e5a5 --- /dev/null +++ b/oldLoopChecking.v @@ -0,0 +1,7095 @@ +(* 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 * 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 : LevelSet_fun 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) (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 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 union_spec u u' l : + LevelExprSet.In l (u ∪ u') <-> + LevelExprSet.In l u \/ LevelExprSet.In l u'. + Proof. + destruct u, u'; unfold union; cbn. + apply LevelExprSet.union_spec. + Qed. + + Lemma union_add_singleton u le : union u (singleton le) = add le u. + Proof. + apply eq_univ_equal. + intros x. rewrite union_spec LevelExprSet.singleton_spec add_spec. + intuition auto. + Qed. + + Lemma union_comm {u u'} : u ∪ u' = union u' u. + Proof. + apply eq_univ_equal. + intros x. rewrite !union_spec. + intuition auto. + Qed. + + Lemma union_add_distr {le u u'} : union (add le u) u' = add le (u ∪ u'). + Proof. + apply eq_univ_equal. + intros x. rewrite !union_spec !add_spec !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. + + 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). + +Definition model := LevelMap.t nat. + +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) : option Z := + let '(l, k) := atom in + match level_value m l with + | None => None + | 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 := + 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 * nat) : 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 + (k0 None + | Some k0 => + if (k0 (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, (0 <= v)%Z, ~~ level_value_above m l (k + Z.to_nat v) & + m' =m (LevelMap.add l (k + Z.to_nat 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 => //. + destruct Z.ltb; + unfold level_value_above; + destruct level_value => //. + destruct Nat.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 => //. + elim: Z.ltb_spec => // leq. + 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 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. +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 + Z.to_nat 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 => 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. + +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 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'. + +#[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 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 Nat.le) (at level 70). (* \leqslant *) + +Infix "⩹" := (model_rel Nat.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 => //. + destruct Z.ltb => //. + unfold level_value_above. + destruct level_value => //. + destruct Nat.leb => //. +Qed. + +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. + +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 => //. +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 hlt 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 + 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'. +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)%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). + +(* + 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 nat := + let (hd, tl) := NonEmptySetFacts.to_nonempty_list l in + 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. + +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. + 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)%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_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. + 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 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 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_nat. + 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 (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. + + 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 ≤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. + 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 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. 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 Nat.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')%nat. +Proof. + unfold level_value_above. + destruct level_value eqn:hl => //. + 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 -> (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 Nat.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 <= (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. +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. + +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. +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 n. 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. 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%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 + (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 -> + 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 (Z.of_nat 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', + 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. + 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 => //. + 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. + set (clsdiff := Clauses.diff _ _). + set (bound := v_minus_w_bound W m). + 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. + { 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. + unfold gain; cbn. + 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 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 <= 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. + 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 <= 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). + 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 + (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 + (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)). + 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)%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 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: 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_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)%nat, (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 Nat.add_1_r. } + 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. + 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. + + +Derive Signature for entails. + +Open Scope nat_scope. +Lemma entails_pred_closure {cls prems concl k} : + cls ⊢ prems → (concl, 1 + k) -> 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_equal. 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_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 (union concl' prem, concl). +Proof. + intros hyp. + move: concl'. + apply: nonEmptyLevelExprSet_elim. + - intros le. rewrite union_comm union_add_singleton. + now apply entails_weak. + - intros le prems ih. + rewrite 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 (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 (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 (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 -union_add_singleton. + - intros le prems ih _ prem concl' hadd 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. +Qed. + +Lemma entails_all_cumul {cls prems prems' concl} : + entails_all cls prems prems' -> + entails_all cls (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. + +Lemma entails_all_concl_union {cls prems concl concl'} : + cls ⊢a prems → concl -> + cls ⊢a prems → concl' -> + cls ⊢a prems → union concl concl'. +Proof. + intros l r. + rewrite /entails_all. + 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 union prems prems' → union concl concl'. +Proof. + intros l r. + apply entails_all_concl_union. + rewrite 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 : 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. + + +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. 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 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 + max_gain clsdiff) ≤ level_value m w)%nat 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. + 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]. + 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 (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'. + 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 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 + Z.to_nat (gain (preml, (l, k))))%nat. + 2:lia. + unfold gain. cbn -[max_premise_value premise_min]. + 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. + 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')%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. + 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 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. + 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 Nat.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 nat -> 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 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 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. + + 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 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. + + 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 = 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 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) := (interp_level l + k)%nat. + 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_nes 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 => Nat.min acc k) m 0%nat. + +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. + 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 + 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)%nat in + LevelMap.MapsTo l v (valuation_of_model m). +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 -> + 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 hlt 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 /\ Nat.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. 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%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 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 = + 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 Nat.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 hlt 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 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 (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/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 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 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_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 n. split => //. +Qed. + +Definition hyps_map (hyps : univ) 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 0 ≤ 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. 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 := n)). + now constructor. +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 (Z.of_nat 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 -> 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. + 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''. rewrite H4 //=. clear H3. + 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. + +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 hlt 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 (n - mink)%nat): entailscl. cbn. move => entailscl. + eapply (entails_all_one (concl := add_prems (n - mink) prems)) => //. + eapply level_value_MapsTo' in hminprem. + 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). + 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 := 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. + +(* 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 Nat.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 Nat.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 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 + [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) : nat := + LevelExprSet.fold (fun '(l', k) acc => if eqb l l' then Nat.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 => Nat.max (max_premise_of l (premise cl)) acc) cls 0%nat. + +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 (option Z)) := + let list := LevelMap.elements m in + 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 + | 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" + | 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_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 /\ (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 := + 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 hge]]. + have hp := min_premise_pres (premise cl) hext. + rewrite heq in hp. depelim hp. exists y. split => //; lia. +Qed. + +Lemma interp_nes_ge v (prems : nonEmptyLevelExprSet) : + forall prem, LevelExprSet.In prem prems -> + interp_expr v prem <= interp_nes v prems. +Proof. + intros. + unfold interp_nes. + 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. + +(** 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' []]. 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 => //. + 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 _ - _)) 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 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. + 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. + 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 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_nes_nat V e := LevelExprSet.fold (fun e acc => NatSet.add (interp_expr V e) acc) e NatSet.empty. + +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_nes. + 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_nes V (add_prems n e) = n + interp_nes V e. +Proof. + 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. + { 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_nes_singleton V e : + interp_nes V (singleton e) = interp_expr V e. +Proof. + rewrite /interp_nes. + 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_nes_singleton. + cbn. lia. +Qed. + +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_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. + 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_nes V u' >= interp_nes V u. +Proof. + intros hsub V. + rewrite !interp_nes_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_nes_ge v prems _ H. + - move=> V Hcls. + move: {IHentails} (IHentails _ Hcls). + unfold clause_sem. unfold ge => 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. +Qed. + +Lemma clauses_sem_entails_all {cls prems concl} : + cls ⊢a prems → 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_nes_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. + 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 = (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 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. + 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. + +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. + +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. + + +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 = 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/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 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. + have tr := entails_all_trans of_lset ent. + 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 := + 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 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, 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_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. 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..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.make'_inj in e. + destruct X as (hty & hdef & harr). destruct a, a'; cbn in *. f_equal; intuition eauto. apply All2_eq. solve_all. Qed. @@ -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/Conversion/PCUICUnivSubstitutionConv.v b/pcuic/theories/Conversion/PCUICUnivSubstitutionConv.v index 4e443e15a..276428b74 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 @@ -23,14 +23,72 @@ Create HintDb univ_subst. Local Ltac aa := rdest; eauto with univ_subst. -Import NonEmptySetFacts. +Import Universe.NES. +Import Universes. -Lemma subst_instance_level_val u l v v' +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 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 => //. +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 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. 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' + (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 +99,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 +114,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 +125,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 +146,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 : - subst_instance_universe u (Universe.make' l) - = Universe.make' (subst_instance u l). +(* 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 +170,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. - now rewrite /subst_instance !subst_instance_universe_make in HH. + - apply (hRe a u1 u2 H). - exact (IHu u1 u2 H). Qed. @@ -180,12 +207,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 φ). @@ -197,22 +229,19 @@ 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 *. 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. - 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] @@ -226,29 +255,20 @@ 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 *. lia. + 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. - 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] @@ -279,41 +299,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_level u1 (subst_instance_level u2 l) - = subst_instance_level (subst_instance u1 u2) l. -Proof. - destruct l; cbn; try reflexivity. - unfold subst_instance. - rewrite <- (map_nth (subst_instance_level u1)); reflexivity. -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 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 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. + destruct l; simpl; auto. 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 plus_plus n m u : Universe.plus n (Universe.plus m u) = Universe.plus (n + m) u. 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 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_universe_sup i (u u' : Universe.t) : + (u ∪ u')@[i]%nes = (u@[i] ∪ u'@[i])%nes. +Proof. + 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. @@ -327,10 +424,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. @@ -349,7 +448,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) : @@ -363,68 +462,103 @@ 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 : - 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_univ_cstr u c' /\ UCS.In c' ctrs. Proof. unfold subst_instance_cstrs. - rewrite CS.fold_spec. - transitivity (CS.In c CS.empty \/ - exists c', c = subst_instance_cstr u c' - /\ In c' (CS.elements ctrs)). - - generalize (CS.elements ctrs), CS.empty. + rewrite UCS.fold_spec. + transitivity (UCS.In c UCS.empty \/ + exists c', c = subst_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_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_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 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)). + - 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 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_univ_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. 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. @@ -456,16 +590,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 : @@ -476,9 +601,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]. @@ -500,13 +625,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. @@ -516,13 +641,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 @@ -559,9 +684,9 @@ 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 Σ) - -> LS.In c.1.1 (global_levels Σ) - /\ LS.In c.2 (global_levels Σ). + UCS.In c (global_constraints Σ) + -> 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). @@ -569,56 +694,157 @@ Proof. Qed. Lemma levels_global_ext_constraint {cf : checker_flags} Σ φ (hΣ : wf_ext_wk (Σ, φ)) c : - CS.In c (global_ext_constraints (Σ, φ)) - -> LS.In c.1.1 (global_ext_levels (Σ, φ)) - /\ LS.In c.2 (global_ext_levels (Σ, φ)). + UCS.In c (global_ext_constraints (Σ, φ)) + -> LS.Subset (levels c.1.1) (global_ext_levels (Σ, φ)) + /\ LS.Subset (levels 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). - 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 monomorphic_univ (ls : Universe.t) := + LevelSet.for_all (fun b => negb (Level.is_var b)) (levels ls). + Definition is_monomorphic_cstr (c : UnivConstraint.t) - := negb (Level.is_var c.1.1) && negb (Level.is_var c.2). + := monomorphic_univ c.1.1 && monomorphic_univ 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. 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} Σ (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. 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 : 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_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. - destruct c as [[[] ?] []]; cbnr; discriminate. + destruct c as [[l ?] r]; cbnr. + rewrite /subst_instance_univ_cstr //= !monomorphic_univ_subst //. 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 +854,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 Σ). @@ -689,22 +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. - 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 *. @@ -747,8 +982,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. @@ -759,7 +994,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 φ) -> @@ -822,9 +1057,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' @@ -833,18 +1066,12 @@ 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 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' : @@ -898,10 +1125,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 Σ φ). @@ -936,39 +1160,13 @@ 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 /\ x = subst_instance u x'). -Proof. - unfold subst_instance; cbn. - unfold subst_instance_universe. - now rewrite map_spec. -Qed. - 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. - 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. + destruct l; cbnr. + - 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 : @@ -979,21 +1177,35 @@ 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)). + 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; 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. @@ -1636,7 +1848,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. @@ -1690,27 +1902,32 @@ Lemma wf_universe_subst_instance {cf : checker_flags} (Σ : global_env_ext) univ 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 : @@ -1733,7 +1950,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). @@ -1742,12 +1959,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. @@ -1755,9 +1999,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 : @@ -1789,7 +2039,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. @@ -1804,6 +2054,105 @@ 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 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 -> @@ -1815,9 +2164,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. @@ -1825,11 +2176,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(CS.Equal (subst_instance_cstrs (unfold #|univs| Level.lvar) cst) cst). - { unfold CS.Equal; intros a. - unfold subst_instance_cstrs. + assert(UCS.Equal (subst_level_instance_cstrs (unfold #|univs| Level.lvar) cst) cst). + { unfold UCS.Equal; intros a. + unfold subst_level_instance_cstrs. red in wf_glob_ext. destruct wf_glob_ext as [_ wfext]. unfold on_udecl_prop in wfext. @@ -1839,7 +2190,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. @@ -1849,16 +2200,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. - rewrite !CS.add_spec. + 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. @@ -1870,73 +2223,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 : @@ -1946,19 +2295,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 : @@ -1970,6 +2308,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. @@ -2094,16 +2433,16 @@ 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. + * 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.make'] in b. - rewrite /subst_instance subst_instance_universe_make in b. - now injection b as e. + cbn -[Universe.of_level] in b. + rewrite [subst_instance_universe _ _]subst_abs_universe //. + apply subset_levels, wfl. Qed. Lemma typed_subst_abstract_instance Σ Γ t T : 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/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/PCUICAlpha.v b/pcuic/theories/PCUICAlpha.v index 26fb12cf3..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.make'_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/PCUICAst.v b/pcuic/theories/PCUICAst.v index 37d32c787..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. @@ -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. @@ -951,15 +951,15 @@ Proof. destruct p as [? []] => //. 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 -> +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 : - l =1 l' -> (forall x, P x -> f x = g x) -> +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. 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. @@ -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)) -> @@ -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/PCUICConfluence.v b/pcuic/theories/PCUICConfluence.v index 0b55e1340..ad274fbfa 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. @@ -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.make'_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/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/PCUICConversion.v b/pcuic/theories/PCUICConversion.v index bbaa90404..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. @@ -850,7 +849,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 +3908,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/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/PCUICCumulativitySpec.v b/pcuic/theories/PCUICCumulativitySpec.v index ceab06392..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.make' 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.make' 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.make' 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 9d7ab1ddf..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.make'). + 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.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' := @@ -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'. + 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/PCUICExpandLetsCorrectness.v b/pcuic/theories/PCUICExpandLetsCorrectness.v index 12ad1d217..17efab243 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. @@ -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. @@ -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 : @@ -3908,7 +3907,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. @@ -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/PCUICGlobalEnv.v b/pcuic/theories/PCUICGlobalEnv.v index 04ddceffc..a3eb2f976 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,19 +136,24 @@ 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. - 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. - + 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} : @@ -156,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/PCUICInductiveInversion.v b/pcuic/theories/PCUICInductiveInversion.v index fc1fadd5e..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. @@ -1802,7 +1850,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, @@ -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,12 +1890,12 @@ 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 : 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. @@ -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,21 +1966,13 @@ 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 : 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. @@ -1910,49 +1981,49 @@ 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. 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. + - rewrite UnivConstraintSetFact.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 +2032,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. @@ -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,33 +2054,33 @@ 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 : - 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_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' : - 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; @@ -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 //. @@ -2086,14 +2159,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'). @@ -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' Γ' Γ : @@ -3372,7 +3445,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/PCUICNormal.v b/pcuic/theories/PCUICNormal.v index 31276b85e..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.make'_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/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..bdce09bf4 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 @@ -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. @@ -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/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/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..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. @@ -2206,7 +2208,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 +2521,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 09991947d..994a52e10 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. @@ -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/PCUICTyping.v b/pcuic/theories/PCUICTyping.v index db055d011..c9554ee6c 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.make' a.(array_level))) - (hty : typing Σ Γ a.(array_type) (tSort (sType (Universe.make' 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 := @@ -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/pcuic/theories/PCUICUnivLevels.v b/pcuic/theories/PCUICUnivLevels.v index a13f96b96..1fca95dea 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. @@ -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. @@ -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/PCUICValidity.v b/pcuic/theories/PCUICValidity.v index 14af1c961..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.make' (array_level 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_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. - 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. 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 19fa4f1aa..f0cfd0b5d 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). @@ -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,8 +67,15 @@ 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 Σ Σ') - : ConstraintSet.Subset (global_ext_constraints (Σ, φ)) + : UnivConstraintSet.Subset (global_ext_constraints (Σ, φ)) (global_ext_constraints (Σ', φ)). Proof. destruct H as [sub _]. @@ -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. @@ -216,11 +231,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,10 +249,10 @@ 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. - destruct c as [[l1 eq] l2]. intuition auto. + intros sub; unfold declared_univ_cstr_levels. + 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 ConstraintSet.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. - destruct d as [[? ? []]|[? ? ? ? []]]; simpl in *; tas; - now apply ConstraintSet.empty_spec in Hc. - -- apply ConstraintSet.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 ConstraintSet.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]; - simpl in *. - -- apply H2 in Hc. apply ConstraintSet.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.*) + * 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) := @@ -564,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. diff --git a/pcuic/theories/PCUICWfUniverses.v b/pcuic/theories/PCUICWfUniverses.v index 0cc6e9130..0cdab243c 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,18 @@ 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. + 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 -> wf_level (Σ, univs) u. @@ -199,6 +229,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 +245,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 +265,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 +277,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 +297,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 p.(puinst), forallb (on_universes fu fc) p.(pparams) , test_context (fc #|p.(puinst)|) p.(pcontext) , on_universes fu fc p.(preturn) , @@ -317,31 +308,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.make' 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.make' 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.make' 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 +337,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 +417,7 @@ Qed. Qed. End WfUniverses. - Arguments wf_universe_reflect {Σ u}. + Arguments wf_universeP {Σ u}. Ltac to_prop := repeat match goal with @@ -441,8 +427,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 @@ -460,51 +446,30 @@ 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. - - 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 +506,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.make' : simpl never. - Lemma test_primu_test_primu_tPrimProp {P : term -> Type} {pu put} {pu' : Level.t -> bool} {put' : term -> bool} p : + Arguments Universe.of_level : simpl never. + 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 +536,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 +610,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 +683,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 +762,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,10 +927,10 @@ 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.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. @@ -974,30 +943,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 +1223,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/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/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..9baef4abc 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)). @@ -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. @@ -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. @@ -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/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 3251a22fe..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. @@ -857,9 +858,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 +976,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/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/Typing/PCUICUnivSubstitutionTyp.v b/pcuic/theories/Typing/PCUICUnivSubstitutionTyp.v index 9b74bfd94..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 [? []] => //=. @@ -210,7 +209,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. @@ -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.make'] 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. 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/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/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/quotation/theories/ToPCUIC/Common/Universes.v b/quotation/theories/ToPCUIC/Common/Universes.v index d12097a97..35308de7f 100644 --- a/quotation/theories/ToPCUIC/Common/Universes.v +++ b/quotation/theories/ToPCUIC/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) QuoteConstraintSet. 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,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. @@ -103,7 +94,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 +114,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/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 10199900c..af747bf21 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. - MetaRocq Run (tmMakeQuotationOfModule everything None "ConstraintSet"). +Module qConstraintSet <: MSetAVL.QuotationOfMake UnivConstraint UnivConstraintSet. + 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 685944dba..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 ConstraintSet.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 748f13b1e..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 ConstraintSet.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 abd0c2823..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 ConstraintSet.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/Common/Universes.v b/quotation/theories/ToTemplate/Common/Universes.v index eeacee94b..e8872dc5b 100644 --- a/quotation/theories/ToTemplate/Common/Universes.v +++ b/quotation/theories/ToTemplate/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) QuoteConstraintSet. +Module QuoteConstraintSet := MSets.QuoteMSetAVL UnivConstraint UnivConstraintSet UnivConstraintSetOrdProp UnivConstraintSetExtraOrdProp UnivConstraintSetExtraDecide qUnivConstraint qConstraintSet qConstraintSetOrdProp qConstraintSetExtraOrdProp qConstraintSetExtraDecide. +Export (hints) QuoteUnivConstraintSet. 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,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 (@ConstraintSet.Raw.MX.lt_dec x y). - #[export] Hint Unfold UnivConstraint.lt : quotation. End UnivConstraint. Export (hints) UnivConstraint. @@ -123,7 +111,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/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 760597d3e..866d4f662 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. - MetaRocq Run (tmMakeQuotationOfModule everything None "ConstraintSet"). +Module qConstraintSet <: MSetAVL.QuotationOfMake UnivConstraint UnivConstraintSet. + 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 4776ece70..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 ConstraintSet.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 a1edda3eb..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 ConstraintSet.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 fdff67498..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 ConstraintSet.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/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. 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" 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} 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 9dc2f2b67..77e46e313 100644 --- a/safechecker-plugin/_PluginProject.in +++ b/safechecker-plugin/_PluginProject.in @@ -9,10 +9,34 @@ src/META.rocq-metarocq-safechecker # From template 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/wGraph.ml +# src/wGraph.mli # From PCUIC src/pCUICPrimitive.mli @@ -39,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". 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/safechecker/theories/PCUICEqualityDec.v b/safechecker/theories/PCUICEqualityDec.v index 2c6f1ff58..386ea3763 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.make' 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.make' u) (Universe.make' u') - | Variance.Invariant => cmpu Conv (Universe.make' u) (Universe.make' 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.make' u) (Universe.make' 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'. @@ -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 => @@ -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 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.make' ui) -> - forallb p (map Universe.make' 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.make' ui) -> - forallb p (map Universe.make' 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.make' ui) -> - forallb p (map Universe.make' 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. @@ -450,14 +450,14 @@ 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')) -> (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 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' -> @@ -531,14 +531,14 @@ 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')) -> (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 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'. @@ -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') -> @@ -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.make' 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.make' l) -> + forallb (wf_universeb Σ) l -> cmp_global_instance Σ cmp_universe pb gr napp l l. Proof. intros rRE Hl. @@ -675,8 +675,8 @@ 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. - + eapply hU. now move/wf_universe_reflect: H. + - destruct p as [? []]; cbn -[Universe.of_level] in X, wt; rtoProp; intuition eauto; constructor; eauto. + + 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.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 Σ) 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. @@ -720,14 +720,14 @@ 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')) (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 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', @@ -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') -> @@ -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,62 @@ 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]. 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, 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]. now exists v. + * 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 +866,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 +938,144 @@ Section EqualityDecGen. Let HG := (graph_of_wf_ext hΣ).π2. - Let uctx' : VSet.t × GoodConstraintSet.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 +1083,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 +1111,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 +1144,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 +1165,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 +1184,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 da75609b2..0e0bc1583 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. @@ -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/PCUICSafeChecker.v b/safechecker/theories/PCUICSafeChecker.v index da107c59a..0ec974866 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,80 +31,30 @@ 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 /\ ConstraintSet.Equal x.2 y.2. - -Definition gcs_equal x y : Prop := - LevelSet.Equal x.1 y.1 /\ GoodConstraintSet.Equal x.2 y.2. - Require Import Relation_Definitions. + LevelSet.Equal x.1 y.1 /\ UnivConstraintSet.Equal x.2 y.2. - 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 (ConstraintSet.Equal ==> R_opt GoodConstraintSet.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). - 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. - - (** It otherwise tries [auto with *], very bad idea. *) Ltac Corelib.Program.Tactics.program_solve_wf ::= match goal with @@ -145,6 +95,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 +115,97 @@ 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. + 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 -> - 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. + 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. + 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) -> wf_ext (Σ, univs) -> @@ -202,16 +216,19 @@ 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). - 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. unfold PCUICLookup.global_ext_constraints in sat. simpl in sat. red. destruct check_univs => //. unfold valid_constraints0. @@ -221,26 +238,28 @@ 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. 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. unfold PCUICLookup.global_ext_constraints in sat. simpl in sat. red. destruct check_univs => //. unfold valid_constraints0. @@ -250,8 +269,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. @@ -261,8 +280,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. @@ -323,66 +342,97 @@ 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. + + 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 (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_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Σ. - assert (HH: ConstraintSet.For_all - (declared_cstr_levels (LS.union (levels_of_udecl udecl) (global_levels Σ))) + 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)). { - 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]. - 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). + (* enough (valid_on_mono_udecl (global_uctx Σ) udecl). 1: { split. apply wf_consistent_extension_on_consistent => //. - apply: consistent_extension_on_global=> //. } - 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 := @@ -406,12 +456,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. @@ -1401,7 +1450,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' Σ Γ Δ Δ' : @@ -1480,18 +1529,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. @@ -2267,9 +2316,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. @@ -2279,53 +2335,58 @@ 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) - (fun _ => (abstract_env_ext_empty, IllFormedDecl id (Msg ("Set not in the global levels " ^ print_lset levels))));; + check_eq_true_lazy (~~ (LevelSet.mem Level.lzero 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 (ConstraintSet.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 (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.1, univs.2) retro Hunivs) _). 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 (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.mem_spec in H. apply LevelSet.mem_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. } - split; eauto. unfold declared_cstr_levels. cbn. + { 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. - + 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. + 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, CS.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. + (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. + { 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 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. + apply abs_consist in i2; eauto ; clear abs_consist; cbn; sq. Qed. Next Obligation. - cbv beta. intros univs retro id levels X H H0 Hconsistent ? ? Hunivs. clearbody Hunivs. - split. + 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. Unshelve. eauto. diff --git a/safechecker/theories/PCUICSafeConversion.v b/safechecker/theories/PCUICSafeConversion.v index 78239f413..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.make' u) -> - forallb (wf_universeb Σ) (map Universe.make' 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.make' x) (Universe.make' y) -> - abstract_env_compare_universe X pb (Universe.make' x) (Universe.make' 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.make' (puinst p)), - forallb (wf_universeb Σ) (map Universe.make' (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), @@ -3273,10 +3271,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 +3588,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.make' (array_level a)) (Universe.make' (array_level 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_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) @@ -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. @@ -6221,12 +6219,12 @@ 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" - |} [] 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 7dffaa960..639e8d6a9 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 (CS.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 ConstraintSet.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 ConstraintSet.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 []. - 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 ConstraintSet.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. + eapply UnivConstraintSet.union_spec in hx. + 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,60 @@ 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)) ∥) + 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) := check_consistent_instance (Monomorphic_ctx) wfg u @@ -1051,7 +1072,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 +1083,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 +1103,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Σ. @@ -1390,7 +1411,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") ;; @@ -1400,6 +1421,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 +1449,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 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 +1462,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.make' (array_level 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 +1488,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 +1506,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 +1869,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 1131b2d08..f6955e528 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 * GoodConstraintSet.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) : ConstraintSet.t -> bool := - check_constraints_gen (abstract_env_leqb_level_n X). + (X:abstract_env_ext_impl) : UnivConstraintSet.t -> bool := + 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 Σ -> - ConstraintSet.For_all (declared_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 ; + 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; @@ -166,7 +164,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. @@ -176,11 +174,10 @@ 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Σ. - - apply consistent_extension_on_empty. Qed. Program Definition abstract_env_empty_ext {cf:checker_flags} {X_type : abstract_env_impl} @@ -200,7 +197,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 +208,7 @@ Next Obligation. Defined. Definition abstract_env_is_consistent_empty {cf:checker_flags} {X_type : abstract_env_impl} - : VSet.t * GoodConstraintSet.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 +218,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 +234,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,29 +301,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' => //. -Qed. - -Lemma wf_consistent_extension_on_consistent {cf:checker_flags} {Σ} udecl : - wf Σ -> consistent_extension_on (global_uctx Σ) udecl -> - consistent (ConstraintSet.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. - destruct (Hval _ Hl); cbn; econstructor. - - 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). + 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 abstract_env_lookup_correct' {cf:checker_flags} {X_type : abstract_env_impl} @@ -350,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 50dc549fc..acc416ae8 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} @@ -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,21 +267,27 @@ 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. +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); |}. @@ -296,53 +305,58 @@ 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. - rename H0 into Hudecl. rename H1 into Hudecl'. - assert (H0 : global_uctx_invariants (global_uctx X)). + 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))). - { split => //. - - apply LevelSet.union_spec; right ; now destruct H0. - - intros [[l ct] l'] [Hl|Hl]%CS.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 (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). - 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 (CS.union _ _) with global_ext_uctx.2. - apply: consistent_ext_on_full_ext=> //. - apply: add_uctx_subgraph. + destruct (push_uctx _ udecl) eqn:hp. + - split => // _. + 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))). + 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]. + 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. + 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. +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 := @@ -367,14 +381,15 @@ 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)). 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. 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/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-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..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) : @@ -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,10 +2525,10 @@ 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. + move: X1. case: PCUICWfUniverses.wf_universeP => //; eauto. eauto. cbn [a array_value]. solve_all. - assert (WfAst.wf Σ B). { now apply typing_wf in X2. } diff --git a/template-rocq/_PluginProject.in b/template-rocq/_PluginProject.in index 70dc3bb7c..cbe9d6845 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 @@ -144,6 +146,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,8 +156,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/mSetProperties.ml gen-src/mSetProperties.mli gen-src/monad_utils.ml @@ -233,6 +235,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/_RocqProject.in b/template-rocq/_RocqProject.in index 0c45ba02e..d32a3f643 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/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 f31e38694..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_constraint_type = UnivConstraintType.ConstraintType.t type quoted_univ_constraint = Universes0.UnivConstraint.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_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.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 b287cf827..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_constraint_type = UnivConstraintType.ConstraintType.t type quoted_univ_constraint = Universes0.UnivConstraint.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_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 @@ -177,7 +193,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 @@ -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_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 aab8d1d31..70049a7b0 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 universe_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 -> 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 @@ -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, [| universe_of_level l1 |]) else universe_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; 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 *) @@ -238,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 @@ -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 b8daf1eb1..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 *) @@ -172,14 +175,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" @@ -198,10 +200,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/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/g_template_rocq.ml b/template-rocq/src/g_template_rocq.ml deleted file mode 100644 index 2d0b77341..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_coq.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_coq.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_coq.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_coq.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_coq.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_coq.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_coq.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_coq.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_coq.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_coq.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_coq.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_coq.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_coq.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_coq.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_coq.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_coq.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_coq.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_coq.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_coq.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_coq.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/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..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 @@ -208,35 +209,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) @@ -369,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/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..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 @@ -292,6 +294,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.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 *) + 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 @@ -311,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 @@ -333,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/template-rocq/theories/Ast.v b/template-rocq/theories/Ast.v index 85b94d06e..7a585b8d2 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 ->. @@ -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 00d98bff2..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. @@ -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. @@ -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 cbf7cc44c..51143dc89 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. @@ -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, GoodConstraintSet.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 @@ -837,19 +835,17 @@ 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 gc_of_constraints (snd univs) with + match push_uctx init_model (clean_uctx 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 +853,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 (clean_uctx 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 8186b690d..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.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. @@ -134,10 +133,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. @@ -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/ExtractLoopChecking.v b/template-rocq/theories/ExtractLoopChecking.v new file mode 100644 index 000000000..d181b66cd --- /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 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)". +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/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/TemplateLoopChecking.v b/template-rocq/theories/TemplateLoopChecking.v new file mode 100644 index 000000000..bd8795a9f --- /dev/null +++ b/template-rocq/theories/TemplateLoopChecking.v @@ -0,0 +1,84 @@ +(* 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.Common.LoopChecking Require Import Common Interfaces Deciders. +From Equations Require Import Equations. +Set Equations Transparent. + + +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}. + +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 univ_model := Impl.Abstract.t. + +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 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 (UnivConstraintSet.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. + +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. + 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..74a4977d8 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) @@ -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/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/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 3cd0e8141..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)). @@ -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). @@ -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/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/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/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 new file mode 100644 index 000000000..bfb6b3738 --- /dev/null +++ b/test-suite/loop-checking/Makefile @@ -0,0 +1,26 @@ +all: rocq plugin + +rocq: Makefile.rocq + $(MAKE) -f Makefile.rocq + cd gen-src && ./to-lower.sh + +Makefile.rocq: _RocqProject + rocq makefile -f _RocqProject -o Makefile.rocq + +Makefile.plugin: _PluginProject + rocq makefile -f _PluginProject -o Makefile.plugin + +plugin: Makefile.plugin rocq + $(MAKE) -f Makefile.plugin + +.PHONY: plugin + +clean: Makefile.rocq Makefile.plugin + $(MAKE) -f Makefile.rocq 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..0679fe291 --- /dev/null +++ b/test-suite/loop-checking/Makefile.plugin.local @@ -0,0 +1,11 @@ +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 Metarocq_template_plugin +CAMLPKGS+=-package rocq-metarocq-template-ocaml.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/_PluginProject b/test-suite/loop-checking/_PluginProject new file mode 100644 index 000000000..41bb5f011 --- /dev/null +++ b/test-suite/loop-checking/_PluginProject @@ -0,0 +1,22 @@ +-R ../../template-rocq/theories MetaCoq.Template +-I ../../template-rocq/gen-src +src/META.rocq-metarocq-loop-checking + +-I src +-I gen-src +-R theories MetaRocq.LoopChecking + +src/g_metarocq_loop_checking_plugin.mlg +src/metarocq_loop_checking_plugin.mlpack + +# 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 + +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/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/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_metarocq_loop_checking_plugin.mlg b/test-suite/loop-checking/src/g_metarocq_loop_checking_plugin.mlg new file mode 100644 index 000000000..c986640a6 --- /dev/null +++ b/test-suite/loop-checking/src/g_metarocq_loop_checking_plugin.mlg @@ -0,0 +1,11 @@ +{ +open Stdarg +open LoopCheckingPlugin +} + +DECLARE PLUGIN "rocq-metarocq-loop-checking.plugin" + +VERNAC COMMAND EXTEND Check_universes CLASSIFIED AS QUERY STATE program + | [ "MetaRocq" "Check" "Universes" ] -> + { Run_extractable.run_vernac check_universes } +END diff --git a/test-suite/loop-checking/src/metarocq_loop_checking_plugin.mlpack b/test-suite/loop-checking/src/metarocq_loop_checking_plugin.mlpack new file mode 100644 index 000000000..5d430cef7 --- /dev/null +++ b/test-suite/loop-checking/src/metarocq_loop_checking_plugin.mlpack @@ -0,0 +1,4 @@ +LoopChecking +TemplateLoopChecking +LoopCheckingPlugin +G_metarocq_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..a1995c5de --- /dev/null +++ b/test-suite/loop-checking/test/test.v @@ -0,0 +1,7 @@ +Require Import Stdlib.Strings.String. +Require Import MetaRocq.Template.All. +Require Import MetaRocq.LoopChecking.Loader. +Require Import MetaRocq.LoopChecking.all_stdlib. + +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 new file mode 100644 index 000000000..42dcfa95b --- /dev/null +++ b/test-suite/loop-checking/theories/Extraction.v @@ -0,0 +1,13 @@ +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)". + +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..5e4177292 --- /dev/null +++ b/test-suite/loop-checking/theories/Loader.v @@ -0,0 +1,2 @@ +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 new file mode 100644 index 000000000..2e043dbf3 --- /dev/null +++ b/test-suite/loop-checking/theories/LoopCheckingPlugin.v @@ -0,0 +1,29 @@ +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 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 => + "(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 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 => + let clauses := time "building clauses" enforce_level_constraints (snd ctx) in + 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/loop-checking/theories/all_stdlib.v b/test-suite/loop-checking/theories/all_stdlib.v new file mode 100644 index 000000000..9cb364370 --- /dev/null +++ b/test-suite/loop-checking/theories/all_stdlib.v @@ -0,0 +1,516 @@ +From Stdlib Require Strings.Ascii +Strings.String +Strings.BinaryString +Strings.OctalString +Strings.Byte +Strings.HexString +ssrmatching.ssrmatching +ZArith.Zhints +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.Ngcd_def +NArith.Nnat +NArith.Ndec +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.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.Int63.Sint63 +Numbers.Cyclic.Int63.Cyclic63 +Numbers.Cyclic.Int63.Uint63 +Numbers.Cyclic.Int63.PrimInt63 +Numbers.Cyclic.Int63.Ring63 +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.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.Qminmax +QArith.Qring +QArith.QOrderedType +QArith.Qreduction +QArith.Qcanon +QArith.QArith +QArith.Qcabs +Lists.ListDec +Lists.ListSet +Lists.ListTactics +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.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.BoolEq +Bool.Bool +Bool.IfProp +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 +btauto.Btauto +btauto.Reflect +btauto.Algebra +Arith.PeanoNat +Arith.Arith +Arith.EqNat +Arith.Bool_nat +Arith.Factorial +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. \ No newline at end of file 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/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 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. @@ -57,7 +57,7 @@ MetaRocq Quote Definition selfpidq := @selfpid. Constraint i < j. MetaRocq Unquote Definition yuyu := - (tConst (cp "selfpid") [Level.level "j"; Level.level "i"]). + (tConst (cp "selfpid") (Instance.of_level_instance [Level.level "j"; Level.level "i"])). MetaRocq Quote Definition t0 := nat. @@ -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. @@ -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. 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 diff --git a/utils/_RocqProject b/utils/_RocqProject index fdaab1e6c..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 @@ -33,6 +33,11 @@ theories/ReflectEq.v theories/monad_utils.v theories/Show.v theories/utils.v +theories/MRClasses.v +theories/SemiLattice.v +theories/MRInstances.v + +theories/NonEmptyLevelExprSet.v # extra tactics theories/MRTactics/DestructHead.v diff --git a/utils/theories/All_Forall.v b/utils/theories/All_Forall.v index 4b8959e75..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. @@ -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. @@ -1892,7 +1900,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/MRClasses.v b/utils/theories/MRClasses.v new file mode 100644 index 000000000..cae20eaf9 --- /dev/null +++ b/utils/theories/MRClasses.v @@ -0,0 +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 }. + +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..ac0ceb6b8 --- /dev/null +++ b/utils/theories/MRInstances.v @@ -0,0 +1,86 @@ +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 := + {| zero := 0%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. + + #[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. + + Program Definition Natsemilattice : Semilattice nat nat := + {| zero := 0; + add := Nat.add; + 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/MRList.v b/utils/theories/MRList.v index 13c8d3ae3..bd28b3cc6 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. @@ -25,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 @@ -78,7 +87,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/MROption.v b/utils/theories/MROption.v index e94d30491..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. @@ -94,12 +122,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 +205,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 cd5a47f08..cc16151a2 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. @@ -36,30 +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). -Infix "=1" := (pointwise_relation _ Logic.eq) (at level 70) : type_scope. -Notation "`=2`" := (pointwise_relation _ (pointwise_relation _ Logic.eq)) (at level 80). -Infix "=2" := (pointwise_relation _ (pointwise_relation _ Logic.eq)) (at level 70) : type_scope. +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. *) -#[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'. + - 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. @@ -132,3 +135,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[])) (only parsing). + +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/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/MRUtils.v b/utils/theories/MRUtils.v index a5c2eed6d..fb497698f 100644 --- a/utils/theories/MRUtils.v +++ b/utils/theories/MRUtils.v @@ -1,6 +1,8 @@ From Stdlib Require Import Nat ZArith Bool. From MetaRocq.Utils Require Export MRPrelude + MRClasses + MRInstances MRReflect All_Forall MRArith @@ -171,17 +173,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 +185,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/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/NonEmptyLevelExprSet.v b/utils/theories/NonEmptyLevelExprSet.v new file mode 100644 index 000000000..e1f146bba --- /dev/null +++ b/utils/theories/NonEmptyLevelExprSet.v @@ -0,0 +1,885 @@ +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 MRClasses SemiLattice. + +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 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. + +Module Type Quantity. + Include OrderedTypeWithLeibniz. + 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. +End LevelExprT. + +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) + (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. + + Infix "=_lset" := LevelSet.Equal (at level 70). + + Import -(notations) LevelExprSet. + Infix "⊂_leset" := LevelExprSet.Subset (at level 70). + Infix "=_leset" := LevelExprSet.Equal (at level 70). + + Import CommutativeMonoid. + Module Export OfQ := OfQuantity Q. + + Definition level : LevelExpr.t -> Level.t := fst. + + 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). + 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 }. + + Definition levels (e : t) := leset_levels e. + + 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. + 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 := + { 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 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. + + 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_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. + 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. + split; intro H. now apply eq_univ, LevelExprSet.eq_leibniz. + now subst. + 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 equal_exprsets. intros x. + rewrite !LevelExprSet.add_spec. firstorder. + Qed. + + #[program] + Definition 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. + + Infix "∪" := union (at level 60): 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 union; cbn. + apply LevelExprSet.union_spec. + Qed. + + Lemma union_add_singleton u le : union u (singleton le) = add le u. + Proof. + apply equal_exprsets. + intros x. rewrite union_spec LevelExprSet.singleton_spec add_spec. + intuition auto. + Qed. + + Lemma union_comm {u u'} : u ∪ u' = union u' u. + Proof. + apply equal_exprsets. + intros x. rewrite !union_spec. + intuition auto. + Qed. + + Lemma union_add_distr {le u u'} : union (add le u) u' = add le (u ∪ u'). + Proof. + apply equal_exprsets. + 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) <-> + (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 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. + split. + - move=> [] k. now move/LevelExprSet.singleton_spec; rewrite /E.eq => <-. + - intros <-. now exists le.2; apply LevelExprSet.singleton_spec. + Qed. + + Lemma leset_levels_singleton le : leset_levels (LevelExprSet.singleton le) =_lset LevelSet.singleton le.1. + Proof. + 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. + 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_leset_levels : Proper (LevelExprSet.Equal ==> LevelSet.Equal) + leset_levels. + Proof. + intros s s' eq l. + rewrite !leset_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 union_assoc {s t u} : union (s ∪ t) u = + union s (t ∪ u). + Proof. + apply equal_exprsets. + intros x. rewrite !union_spec. + intuition auto. + 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. + + 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. + 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): + 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:=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, CommutativeMonoid.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, CommutativeMonoid.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 (CommutativeMonoid.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 CommutativeMonoid.zero e = e. + Proof. + destruct e. rewrite /add_expr. now rewrite neutral. + Qed. + + Lemma add_prems_0 u : add_prems CommutativeMonoid.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. + + 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. + + Section SemilatticeInterp. + Import Semilattice. + Context {S: Type} {SL : Semilattice S Q.t}. + Context (v : Level.t -> S). + + Definition interp_expr le := + let '(l, k) := le in (add k (v l)). + + 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. + + 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_nes_singleton e : + interp_nes (singleton e) = interp_expr e. + Proof. + rewrite /interp_nes. + now rewrite singleton_to_nonempty_list /=. + Qed. + + Lemma interp_nes_ge (prems : t) : + forall prem, LevelExprSet.In prem prems -> + interp_expr prem ≤ interp_nes prems. + Proof. + intros. + unfold interp_nes. + 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_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_nes. + 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_nes_add le (u : t) : + interp_nes (NonEmptyLevelExprSet.add le u) ≡ join (interp_expr le) (interp_nes u). + Proof. + rewrite 2!interp_nes_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_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_nes u). + Proof. + intros prop hs hadd. + eapply elim. + - intros le. rewrite interp_nes_singleton. apply hs. + - intros le prems ih hnin. + rewrite interp_nes_add. now apply hadd. + Qed. + + Lemma interp_add_prems n e : interp_nes (add_prems n e) ≡ add n (interp_nes e). + Proof. + revert e. + 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_nes_singleton //=. + destruct le; cbn. now rewrite add_distr. + - intros le u k heq hnin. + rewrite add_prems_add. + rewrite interp_nes_add heq interp_add_expr. + now rewrite add_join. + Qed. + + Lemma interp_nes_in {le} {u : t} : + LevelExprSet.In le u -> interp_expr le ≤ interp_nes u. + Proof. + revert u. + 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. + 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_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_nes_add interp_nes_singleton. + - intros le' x ih hnin. + rewrite union_add_distr !interp_nes_add ih. cbn. + now rewrite join_assoc. + Qed. + + 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_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_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_nes_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 new file mode 100644 index 000000000..8325bfe11 --- /dev/null +++ b/utils/theories/SemiLattice.v @@ -0,0 +1,374 @@ +(* 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 MROption. + +Set Equations Transparent. + +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 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; + 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; + 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; + 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 70) : sl_scope. + + 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. + + Definition lt {A} `{SL : Semilattice A} (x y : A) := add 1 x ≤ y. + Infix "<" := lt (at level 70) : sl_scope. + + 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. + 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 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 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 A 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 A incr _ _). + 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 : A} : s ≤ s ∨ t. + Proof. + red. now rewrite -join_assoc join_idem. + Qed. + + 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. + 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. + 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_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. + intros [le|le]; red in le; red. + now rewrite -join_assoc le. + now rewrite (join_comm t) -join_assoc le. + Qed. + + Lemma le_dec {JD : @EqDec A incr CM SL} (x y : A) : + (x ≤ y) \/ ~ (x ≤ y). + Proof. + 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. + split. + - now rewrite -add_join => ->. + - rewrite -add_join => h. + now apply add_inj in h. + Qed. + + End Derived. + + Section FoldSemilattice. + 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. + 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 : 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 : 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' |- *. + - 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 : 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. + - 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 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 := _; + zero := Some zero; + 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, 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. + 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 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. 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. 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 |- * => //.