diff --git a/lib/alpine/lookups.ml b/lib/alpine/lookups.ml index 12f14a1..f4f8efb 100644 --- a/lib/alpine/lookups.ml +++ b/lib/alpine/lookups.ml @@ -62,9 +62,6 @@ module T = PFR.T the calculus reads off inst_prio, so every sub-instance carries the k: lines of the packages in its repository. *) -(* replaces (r:/q:) never appears in a repository index -- it is an - installed-db field -- so inst_repl is empty. *) - let xconstr (c : P.constr) : Alp.coq_Constr = match c with | P.Any -> Alp.CAny @@ -185,7 +182,6 @@ let empty_inst = inst_installIf = Alp.InstallIf.empty; inst_world = Alp.WSet.empty; inst_prio = Alp.Prio.empty; - inst_repl = Alp.Repl.empty; } let rec nat_of_int (k : int) : E.nat = @@ -276,7 +272,6 @@ let pkg_inst ar (world : P.dep list) ((n, v) : string * string) : Alp.coq_Inst = Alp.Deps.ofList (List.map (fun d -> ((n, v), xdep d)) m.P.depends) in { - empty_inst with Alp.inst_repo = repo; inst_deps = deps; inst_prov = Alp.Prov.union prov own; @@ -524,7 +519,7 @@ module L = module PG = L.PG -(* Lookup.versions_lookupName: what the versions callback answers, before +(* Lookup.versions_lookupOrig: what the versions callback answers, before the tagging PubGrub sees -- the name's own versions and its provides. The encoder reads this at the names a formula negates: a negated requirement's complement ranges over the versions offered at the name, diff --git a/lib/cargo/cargo_solve.ml b/lib/cargo/cargo_solve.ml index 8f39d09..00ff578 100644 --- a/lib/cargo/cargo_solve.ml +++ b/lib/cargo/cargo_solve.ml @@ -159,7 +159,7 @@ let install_root ar (v : P.ver) = complete at the moment the lookup answers. Each is complete by construction -- name_set, support_of_name and repo_preimage load every name they read whole, and meta and the witness scan load the owner -- - except the one versions_lookupLinkSub names. Its + except the one versions_lookupLink names. Its sub-instance is the preimage of the link relation at l -- every crate version declaring l -- and no declaration of any one crate names the other declarers, so nothing a loaded crate carries can bring them in: @@ -507,7 +507,7 @@ let crate_msrv_ok st (rustc : string) ((n, v) : string * string) : bool = | Some m -> msrv_ok rustc m.P.v_msrv) (* the support relation at a name -- Lookup.supportPreimage at {n}, - which versions_lookupFeatPSub reads -- as the union of its versions' + which versions_lookupFeatP reads -- as the union of its versions' fibres. Memoized for the same reason name_set is: load_name takes a name whole, so this cannot grow once it has been asked. *) let support_of_name st (n : string) : Cg.SupportSet.t = @@ -517,7 +517,7 @@ let support_of_name st (n : string) : Cg.SupportSet.t = (fun (v : P.ver) -> (fibres_of st (n, v.P.v_vers)).r_supp) (load_name st.ar n))) -(* the witness versions_lookup{Slot,Decision}Sub name: a version of n in +(* the witness versions_lookup{Slot,Decision} name: a version of n in granularity class gr whose own declarations make the name, found by scanning n's index entry, which holds every version of n and is loaded whole. With none, the empty fibres stand for slot_declines and @@ -575,7 +575,7 @@ let empty_sub = links = Cg.LinkRel.empty; } -(* one branch per versions_lookup{Root,Crate,FeatP,Slot,Decision,Link}Sub, +(* one branch per versions_lookup{Root,Crate,FeatP,Slot,Decision,Link}, each passing the components its theorem names and nothing else *) let versions st (tn : Cg.NPlus.t) : Cg.VPlus.t list = let call s = @@ -605,9 +605,9 @@ let versions st (tn : Cg.NPlus.t) : Cg.VPlus.t list = in call { empty_sub with repo; links } -(* one branch per dependees_lookup{Root,Crate,FeatP,Slot,Decision}Sub, +(* one branch per dependees_lookup{Root,Crate,FeatP,Slot,Decision}, with the request (rc, rootFeats, default) carried whole as the - theorems carry it; the fall-through is dependees_lookupInert, empty *) + theorems carry it; the fall-through is dependees_reduceDepsInert, empty *) let dependees st (p : T.Pkg.t) : T.Dependees.t list = let call s = T.DependeesSet.elements diff --git a/lib/opam/lookups.ml b/lib/opam/lookups.ml index 54f858f..c4e9409 100644 --- a/lib/opam/lookups.ml +++ b/lib/opam/lookups.ml @@ -254,7 +254,6 @@ let empty_inst = { Op.inst_repo = Op.PkgSet.empty; inst_dep = []; - inst_dpo = []; inst_cfl = []; inst_cls = Op.ClsRel.empty; inst_avl = []; diff --git a/scripts/check-axioms.sh b/scripts/check-axioms.sh index a78564d..a16267f 100755 --- a/scripts/check-axioms.sh +++ b/scripts/check-axioms.sh @@ -5,16 +5,16 @@ # list below is the only thing to edit when a theorem is added; the # expected count is derived from it. # -# Names are qualified through the nat instantiations: Smoke.v supplies -# one per functor, Npm.v supplies its own (NpmS) since Smoke.v has none, -# and Semver has no instance of its own because Cargo Includes it, so its -# range language is audited through Cgo. +# Names are qualified through the nat instantiations Smoke.v supplies, one +# per functor. Semver has no instance of its own because Cargo Includes +# it, so its range language is audited through Cgo. set -e # Resolved before the cd below, since dune passes it relative to the # directory the action runs in. -theories=$(cd "${PAC_THEORIES:-.}" && pwd) +theories= +[ -z "${PAC_THEORIES:-}" ] || theories=$(cd "$PAC_THEORIES" && pwd) cd "${PAC_ROOT:-$(dirname "$0")/..}" -[ -n "${PAC_THEORIES:-}" ] || theories="$PWD/_build/default/theories" +[ -n "$theories" ] || theories="$PWD/_build/default/theories" command -v coqtop >/dev/null 2>&1 || { echo "FAIL: coqtop not on PATH (eval \$(opam env) first)"; exit 1; } @@ -36,7 +36,6 @@ Cx.Reduction.extractAssignment Cx.Reduction.reduceDeps Cx.Reduction.reduceDeps_functionalInName Cx.Reduction.reduceReal -Cx.Reduction.reduceReal_root Cx.Reduction.three_sat_completeness Cx.Reduction.three_sat_correct Cx.Reduction.three_sat_soundness @@ -53,7 +52,6 @@ Cfl.Reduction.Lookup.versions_lookupOrig Cfl.Reduction.conflictResolution Cfl.Reduction.conflict_completeness Cfl.Reduction.conflict_soundness -Cfl.Reduction.reduce Cfl.Reduction.reduceDeps Cfl.Reduction.reduceReal @@ -69,7 +67,6 @@ Cls.Reduction.classResolution_coreResolution Cls.Reduction.conflict_class_completeness Cls.Reduction.conflict_class_soundness Cls.Reduction.coreResolution -Cls.Reduction.reduce Cls.Reduction.reduceDeps Cls.Reduction.reduceDeps_functionalInName Cls.Reduction.reduceReal @@ -147,7 +144,6 @@ PkgF.Reduction.Lookup.dependees_lookupDisjunct PkgF.Reduction.Lookup.dependees_lookupDisjunctBy PkgF.Reduction.Lookup.dependees_lookupOrig PkgF.Reduction.Lookup.dependees_lookupOrigBy -PkgF.Reduction.Lookup.root_not_absent PkgF.Reduction.Lookup.versions_lookupDisjunct PkgF.Reduction.Lookup.versions_lookupOrig PkgF.Reduction.Lookup.versions_lookupOrigPresent @@ -208,19 +204,18 @@ Deb.versions Deb.versionsDisj Deb.versionsSoft -DMA.Lookup.dependees_lookupDisjunctMA -DMA.Lookup.dependees_lookupOrigMA -DMA.Lookup.dependees_lookupSelectorAgreeMA -DMA.Lookup.dependees_lookupSelectorMA -DMA.Lookup.dependees_lookupSelectorRecMA -DMA.Lookup.dependees_lookupSoftMA -DMA.Lookup.versions_lookupDisjunctMA -DMA.Lookup.versions_lookupOrigMA -DMA.Lookup.versions_lookupOrigMA_pseudo -DMA.Lookup.versions_lookupSelectorAgreeMA -DMA.Lookup.versions_lookupSelectorMA -DMA.Lookup.versions_lookupSelectorRecMA -DMA.Lookup.versions_lookupSoftMA +DMA.Lookup.dependees_lookupDisjunct +DMA.Lookup.dependees_lookupOrig +DMA.Lookup.dependees_lookupSelector +DMA.Lookup.dependees_lookupSelectorAgree +DMA.Lookup.dependees_lookupSelectorRec +DMA.Lookup.dependees_lookupSoft +DMA.Lookup.versions_lookupOrig +DMA.Lookup.versions_lookupOrig_pseudo +DMA.Lookup.versions_lookupSelector +DMA.Lookup.versions_lookupSelectorAgree +DMA.Lookup.versions_lookupSelectorRec +DMA.Lookup.versions_lookupSoft DMA.debian_ma_completeness DMA.debian_ma_core_completeness DMA.debian_ma_core_soundness @@ -234,94 +229,87 @@ DMA.reduceConfEntry DMA.reduceDeps DMA.reduceProv DMA.reduceProvEntry -DMA.reduceRec DMA.reduceReal +DMA.reduceRec -Op.depextsOf -Op.mem_depextsOf +Op.Reduction.Lookup.clsVersions_reduceReal +Op.Reduction.Lookup.declarers +Op.Reduction.Lookup.dependees_lookupClassCore +Op.Reduction.Lookup.dependees_lookupDisjunctCore +Op.Reduction.Lookup.dependees_lookupOrig +Op.Reduction.Lookup.dependees_lookupOrigCore +Op.Reduction.Lookup.dependees_lookupRoot +Op.Reduction.Lookup.dependees_lookupRootCore +Op.Reduction.Lookup.versions_lookupClass +Op.Reduction.Lookup.versions_lookupClassCore +Op.Reduction.Lookup.versions_lookupOrig +Op.Reduction.Lookup.versions_lookupOrigCore +Op.Reduction.Lookup.versions_lookupRootCore Op.Reduction.clsForms Op.Reduction.clsPkgs Op.Reduction.clsSel Op.Reduction.clsVersions -Op.Reduction.clsVersions_reduceReal -Op.Reduction.declarers +Op.Reduction.coreResolution Op.Reduction.decodeS Op.Reduction.dependees Op.Reduction.dependeesBy -Op.Reduction.dependees_lookupClsCore -Op.Reduction.dependees_lookupDisjunctCore -Op.Reduction.dependees_lookupReal -Op.Reduction.dependees_lookupRealCore -Op.Reduction.dependees_lookupRoot -Op.Reduction.dependees_lookupRootCore Op.Reduction.encR Op.Reduction.encodeOF Op.Reduction.opam_completeness Op.Reduction.opam_soundness +Op.Reduction.reduceDeps +Op.Reduction.reduceReal Op.Reduction.rootPkg Op.Reduction.srcVersions -Op.Reduction.transD -Op.Reduction.transR -Op.Reduction.transS Op.Reduction.versSetBy Op.Reduction.versions -Op.Reduction.versions_lookupCls -Op.Reduction.versions_lookupClsCore -Op.Reduction.versions_lookupReal -Op.Reduction.versions_lookupRealCore -Op.Reduction.versions_lookupRootCore +Op.depextsOf +Op.mem_depextsOf Cgo.Lookup.claimants -Cgo.Lookup.dependees_lookup +Cgo.Lookup.decision_declines Cgo.Lookup.dependees_lookupCrate -Cgo.Lookup.dependees_lookupCrateSub Cgo.Lookup.dependees_lookupDecision -Cgo.Lookup.dependees_lookupDecisionSub Cgo.Lookup.dependees_lookupFeatP -Cgo.Lookup.dependees_lookupFeatPSub -Cgo.Lookup.dependees_lookupInert Cgo.Lookup.dependees_lookupRoot -Cgo.Lookup.dependees_lookupRootSub Cgo.Lookup.dependees_lookupSlot -Cgo.Lookup.dependees_lookupSlotSub -Cgo.Lookup.dependees_lookupSub -Cgo.Lookup.decision_declines +Cgo.Lookup.dependees_reduceDeps +Cgo.Lookup.dependees_reduceDepsInert Cgo.Lookup.fdefFibre -Cgo.Lookup.owner Cgo.Lookup.reads Cgo.Lookup.realPreimage Cgo.Lookup.slot_declines Cgo.Lookup.supportPreimage Cgo.Lookup.versions_lookupCrate -Cgo.Lookup.versions_lookupCrateSub Cgo.Lookup.versions_lookupDecision -Cgo.Lookup.versions_lookupDecisionSub Cgo.Lookup.versions_lookupFeatP -Cgo.Lookup.versions_lookupFeatPSub Cgo.Lookup.versions_lookupLink -Cgo.Lookup.versions_lookupLinkSub Cgo.Lookup.versions_lookupRoot -Cgo.Lookup.versions_lookupRootSub Cgo.Lookup.versions_lookupSlot -Cgo.Lookup.versions_lookupSlotSub +Cgo.Lookup.versions_reduceRealCrate +Cgo.Lookup.versions_reduceRealDecision +Cgo.Lookup.versions_reduceRealFeatP +Cgo.Lookup.versions_reduceRealLink +Cgo.Lookup.versions_reduceRealRoot +Cgo.Lookup.versions_reduceRealSlot Cgo.cargo_completeness Cgo.cargo_soundness -Cgo.coreRes +Cgo.coreResolution Cgo.csAdmits Cgo.csHolds Cgo.decodeFS -Cgo.decodeFS_coreRes +Cgo.decodeFS_coreResolution Cgo.decodeParents -Cgo.decodeParents_coreRes +Cgo.decodeParents_coreResolution Cgo.decodeS -Cgo.decodeS_coreRes +Cgo.decodeS_coreResolution Cgo.dependees Cgo.evalReq Cgo.linkRel Cgo.rangeEval +Cgo.reduceDeps +Cgo.reduceReal Cgo.rgHolds -Cgo.transDeps -Cgo.transReal Cgo.versions Cgo.versions_link_reduceReal @@ -332,11 +320,11 @@ Alp.Reduction.Lookup.dependees_lookupProv Alp.Reduction.Lookup.dependees_lookupProvCore Alp.Reduction.Lookup.dependees_lookupRoot Alp.Reduction.Lookup.dependees_lookupRootCore -Alp.Reduction.Lookup.versions_lookupName -Alp.Reduction.Lookup.versions_lookupNameCore +Alp.Reduction.Lookup.versions_lookupOrig +Alp.Reduction.Lookup.versions_lookupOrigCore Alp.Reduction.Lookup.versions_lookupRootCore +Alp.Reduction.alpineResolution_core Alp.Reduction.alpineResolution_coreResolution -Alp.Reduction.alpineResolution_transS Alp.Reduction.alpine_completeness Alp.Reduction.alpine_soundness Alp.Reduction.attachAt @@ -345,29 +333,29 @@ Alp.Reduction.encReq Alp.Reduction.installIfFibre Alp.Reduction.installIfForm Alp.Reduction.matchPos_attachAt +Alp.Reduction.match_req_coreResolution Alp.Reduction.match_req_decode -Alp.Reduction.match_req_transS +Alp.Reduction.reduceDeps +Alp.Reduction.reduceReal Alp.Reduction.rootPkg -Alp.Reduction.transD -Alp.Reduction.transR Alp.Reduction.versions -NpmS.Reduction.Lookup.dependees_lookupGran -NpmS.Reduction.Lookup.dependees_lookupInt -NpmS.Reduction.Lookup.versions_lookupGran -NpmS.Reduction.Lookup.versions_lookupInt +NpmS.Reduction.Lookup.dependees_lookupGranular +NpmS.Reduction.Lookup.dependees_lookupIntermediate +NpmS.Reduction.Lookup.versions_lookupGranular +NpmS.Reduction.Lookup.versions_lookupIntermediate NpmS.Reduction.dependees NpmS.Reduction.dependees_targetNames +NpmS.Reduction.embedRoot NpmS.Reduction.lookup_resolution NpmS.Reduction.npmParents_coreResolution NpmS.Reduction.npmResolution_coreResolution NpmS.Reduction.npm_completeness NpmS.Reduction.npm_soundness NpmS.Reduction.peer_installed -NpmS.Reduction.reached_transR -NpmS.Reduction.transD -NpmS.Reduction.transR -NpmS.Reduction.transRoot +NpmS.Reduction.reached_reduceReal +NpmS.Reduction.reduceDeps +NpmS.Reduction.reduceReal NpmS.Reduction.versions NpmS.rootPkg LIST @@ -377,7 +365,7 @@ expected=$(printf '%s\n' "$names" | grep -c .) # An installed copy under _opam is on coqtop's default load path and goes # stale; an absolute -R is what keeps this reading the build tree. -out=$({ printf 'From PackageCalculus Require Import Smoke Npm.\n' +out=$({ printf 'From PackageCalculus Require Import Smoke.\n' printf '%s\n' "$names" | sed -e 's/^/Print Assumptions /' \ -e 's/$/./'; } \ | coqtop -q -R "$theories" PackageCalculus 2>&1) diff --git a/scripts/check-citations.py b/scripts/check-citations.py index b634599..68c4a83 100755 --- a/scripts/check-citations.py +++ b/scripts/check-citations.py @@ -5,7 +5,7 @@ theories/ does not define. A comment cites a Rocq name when it writes a qualified path whose head is a theories/ module or a driver's alias of one (Lookup.versions_lookupOrig, Red.versions, DMA.Deb.vtMatchb), a name the Rocq naming scheme alone produces -(snake prefix, camel suffix: dependees_lookupInert), a name after +(snake prefix, camel suffix: dependees_reduceDepsInert), a name after Lemma/Theorem/Definition, or a file X.v. A trailing * is a prefix glob and must match at least one name. Only comments are read, so the extracted code itself is checked by the compiler, not here. diff --git a/theories/Alpine.v b/theories/Alpine.v index 3381174..0e020a0 100644 --- a/theories/Alpine.v +++ b/theories/Alpine.v @@ -155,8 +155,6 @@ Module Alpine (N V : UsualOrderedType) (PM : ApkVerMatch V). Module PrioElt := PairUOT Pkg Nat_as_OT. Module Prio := FSetUOT PrioElt. - Module ReplElt := PairUOT Pkg N. - Module Repl := FSetUOT ReplElt. Record Inst : Type := { inst_repo : PkgSet.t @@ -164,8 +162,7 @@ Module Alpine (N V : UsualOrderedType) (PM : ApkVerMatch V). ; inst_prov : Prov.t ; inst_installIf : InstallIf.t ; inst_world : WSet.t - ; inst_prio : Prio.t - ; inst_repl : Repl.t }. + ; inst_prio : Prio.t }. Definition MatchPos (I : Inst) (S : PkgSet.t) (n : N.t) (ct : Constr) : Prop := @@ -515,7 +512,7 @@ Module Alpine (N V : UsualOrderedType) (PM : ApkVerMatch V). end) (inst_prov I). - Definition transR (I : Inst) : PF.PkgSet.t := + Definition reduceReal (I : Inst) : PF.PkgSet.t := PF.PkgSet.add rootPkg (PF.PkgSet.union (SOpp.map embedPkg (inst_repo I)) (provPkgs I (inst_repo I))). @@ -525,8 +522,8 @@ Module Alpine (N V : UsualOrderedType) (PM : ApkVerMatch V). Definition depEdges (q : PF.Pkg.t) (fs : FSet.t) : PF.DepRel.t := SOfd.map (fun f => (q, f)) fs. - Definition transD (I : Inst) : PF.DepRel.t := - SOqd.unionMap (fun q => depEdges q (dependees I q)) (transR I). + Definition reduceDeps (I : Inst) : PF.DepRel.t := + SOqd.unionMap (fun q => depEdges q (dependees I q)) (reduceReal I). Definition tryInvPkg (q : PF.Pkg.t) : option Pkg.t := match q with @@ -537,7 +534,7 @@ Module Alpine (N V : UsualOrderedType) (PM : ApkVerMatch V). Definition alpineResolution (S' : PF.PkgSet.t) : PkgSet.t := SOqp.filterMap tryInvPkg S'. - Definition transS (I : Inst) (S : PkgSet.t) : PF.PkgSet.t := + Definition coreResolution (I : Inst) (S : PkgSet.t) : PF.PkgSet.t := PF.PkgSet.add rootPkg (PF.PkgSet.union (SOpp.map embedPkg S) (provPkgs I S)). @@ -550,9 +547,6 @@ Module Alpine (N V : UsualOrderedType) (PM : ApkVerMatch V). injection H as <-; reflexivity. Qed. - Lemma embedPkg_injective : forall p q, embedPkg p = embedPkg q -> p = q. - Proof. exact (SOqp.emb_injective tryInvPkg embedPkg tryInvPkg_embed). Qed. - Lemma mem_alpineResolution : forall S' p, PkgSet.In p (alpineResolution S') <-> PF.PkgSet.In (embedPkg p) S'. @@ -570,28 +564,22 @@ Module Alpine (N V : UsualOrderedType) (PM : ApkVerMatch V). w = Version.Prov q pv). Proof. intros I n ct w; unfold constrVers. - rewrite PF.VSet.union_spec, SOpw.mem_filterMap, SOrw.mem_filterMap. + rewrite PF.VSet.union_spec, SOpw.mem_filterMap_if, SOrw.mem_filterMap. split. - - intros [[[m v] [Hm Hf]] | [[q [m tg]] [Hm Hf]]]. - + cbn in Hf. - destruct (NEqb.eqb m n) eqn:En; [| discriminate]. - apply NEqb.eqb_true_iff in En; subst m. - destruct (constrMatch ct v) eqn:Ec; [| discriminate]. - injection Hf as <-; left; eauto. + - intros [[[m v] [Hm [Hb ->]]] | [[q [m tg]] [Hm Hf]]]. + + cbn [fst snd] in Hb. + rewrite Bool.andb_true_iff, NEqb.eqb_true_iff in Hb. + destruct Hb as [-> Hc]; left; eauto. + cbn in Hf; destruct tg as [pv |]; [| discriminate]. - destruct (NEqb.eqb m n) eqn:En; [| discriminate]. - apply NEqb.eqb_true_iff in En; subst m. - destruct (PkgSet.mem q (inst_repo I)) eqn:Eq; [| discriminate]. - destruct (constrMatch ct pv) eqn:Ec; [| discriminate]. - injection Hf as <-; right. - exists q, pv; repeat split; try assumption. - apply PkgSet.mem_spec; assumption. + rewrite if_some_iff, !Bool.andb_true_iff, NEqb.eqb_true_iff, + PkgSet.mem_spec in Hf. + destruct Hf as [[-> [Hq Hc]] <-]; right; exists q, pv; auto. - intros [[v [Hv [Hc ->]]] | [q [pv [Hr [Hq [Hc ->]]]]]]. - + left; exists (n, v); split; [exact Hv | cbn]. - rewrite (proj2 (NEqb.eqb_true_iff n n) eq_refl), Hc; reflexivity. + + left; exists (n, v); cbn [fst snd]. + rewrite Bool.andb_true_iff, NEqb.eqb_true_iff; auto. + right; exists (q, (n, PVer pv)); split; [exact Hr | cbn]. - rewrite (proj2 (NEqb.eqb_true_iff n n) eq_refl), Hc. - rewrite (proj2 (PkgSet.mem_spec _ _) Hq); reflexivity. + apply if_some_iff; rewrite !Bool.andb_true_iff, NEqb.eqb_true_iff, + PkgSet.mem_spec; auto. Qed. Lemma mem_uprovSet : forall I n q, @@ -603,14 +591,12 @@ Module Alpine (N V : UsualOrderedType) (PM : ApkVerMatch V). split. - intros [[q0 [m tg]] [Hm Hf]]; cbn in Hf. destruct tg as [|]; [discriminate |]. - destruct (NEqb.eqb m n) eqn:En; [| discriminate]. - apply NEqb.eqb_true_iff in En; subst m. - destruct (PkgSet.mem q0 (inst_repo I)) eqn:Eq; [| discriminate]. - injection Hf as <-. - split; [exact Hm | apply PkgSet.mem_spec; assumption]. + rewrite if_some_iff, Bool.andb_true_iff, NEqb.eqb_true_iff, + PkgSet.mem_spec in Hf. + destruct Hf as [[-> Hq] <-]; auto. - intros [Hr Hq]; exists (q, (n, PVirt)); split; [exact Hr | cbn]. - rewrite (proj2 (NEqb.eqb_true_iff n n) eq_refl). - rewrite (proj2 (PkgSet.mem_spec _ _) Hq); reflexivity. + apply if_some_iff; rewrite Bool.andb_true_iff, NEqb.eqb_true_iff, + PkgSet.mem_spec; auto. Qed. Lemma mem_provPkgs : forall I S y, @@ -622,13 +608,11 @@ Module Alpine (N V : UsualOrderedType) (PM : ApkVerMatch V). split. - intros [[q [m tg]] [Hm Hf]]; cbn in Hf. destruct tg as [pv |]; [| discriminate]. - destruct (PkgSet.mem q S) eqn:Eq; [| discriminate]. - injection Hf as <-. - exists q, m, pv; repeat split; try assumption. - apply PkgSet.mem_spec; assumption. + rewrite if_some_iff, PkgSet.mem_spec in Hf; destruct Hf as [Hq <-]. + exists q, m, pv; auto. - intros [q [m [pv [Hr [Hq ->]]]]]. exists (q, (m, PVer pv)); split; [exact Hr | cbn]. - rewrite (proj2 (PkgSet.mem_spec _ _) Hq); reflexivity. + apply if_some_iff; rewrite PkgSet.mem_spec; auto. Qed. Lemma attachAt_spec : forall I p a, @@ -699,83 +683,88 @@ Module Alpine (N V : UsualOrderedType) (PM : ApkVerMatch V). intro H; apply CondSet.remove_spec in H; exact (proj1 H). Qed. - Lemma mem_transS : forall I S y, - PF.PkgSet.In y (transS I S) <-> + Lemma mem_coreResolution : forall I S y, + PF.PkgSet.In y (coreResolution I S) <-> y = rootPkg \/ (exists p, PkgSet.In p S /\ y = embedPkg p) \/ (exists q m pv, Prov.In (q, (m, PVer pv)) (inst_prov I) /\ PkgSet.In q S /\ y = (Name.Orig m, Version.Prov q pv)). Proof. - intros I S y; unfold transS. + intros I S y; unfold coreResolution. rewrite PF.PkgSet.add_spec, PF.PkgSet.union_spec, SOpp.mem_map, mem_provPkgs. reflexivity. Qed. - Lemma transR_transS : forall I, transR I = transS I (inst_repo I). + Lemma reduceReal_coreResolution : forall I, + reduceReal I = coreResolution I (inst_repo I). Proof. reflexivity. Qed. - Lemma mem_transR : forall I y, - PF.PkgSet.In y (transR I) <-> + Lemma mem_reduceReal : forall I y, + PF.PkgSet.In y (reduceReal I) <-> y = rootPkg \/ (exists p, PkgSet.In p (inst_repo I) /\ y = embedPkg p) \/ (exists q m pv, Prov.In (q, (m, PVer pv)) (inst_prov I) /\ PkgSet.In q (inst_repo I) /\ y = (Name.Orig m, Version.Prov q pv)). - Proof. intros I y; rewrite transR_transS; apply mem_transS. Qed. + Proof. + intros I y; rewrite reduceReal_coreResolution; apply mem_coreResolution. + Qed. - (* Each target name draws its versions from one branch of transS, so + (* Each target name draws its versions from one branch of coreResolution, so the callers name the branch they mean rather than its position. *) - Lemma transS_at_root : forall I S w, - PF.PkgSet.In (Name.Root, w) (transS I S) -> w = Version.RootV. + Lemma coreResolution_at_root : forall I S w, + PF.PkgSet.In (Name.Root, w) (coreResolution I S) -> w = Version.RootV. Proof. - intros I S w H; apply mem_transS in H; unfold embedPkg, rootPkg in H. + intros I S w H; apply mem_coreResolution in H. + unfold embedPkg, rootPkg in H. destruct H as [E | [[p [_ E]] | [q [m [pv [_ [_ E]]]]]]]; [injection E as ->; reflexivity | discriminate E | discriminate E]. Qed. - Lemma transS_at_orig : forall I S n w, - PF.PkgSet.In (Name.Orig n, w) (transS I S) -> + Lemma coreResolution_at_orig : forall I S n w, + PF.PkgSet.In (Name.Orig n, w) (coreResolution I S) -> (exists v, PkgSet.In (n, v) S /\ w = Version.Orig v) \/ (exists q pv, Prov.In (q, (n, PVer pv)) (inst_prov I) /\ PkgSet.In q S /\ w = Version.Prov q pv). Proof. - intros I S n w H; apply mem_transS in H; unfold embedPkg, rootPkg in H. + intros I S n w H; apply mem_coreResolution in H. + unfold embedPkg, rootPkg in H. destruct H as [E | [[[n' v] [Hp E]] | [q [m [pv [Hr [Hq E]]]]]]]; [discriminate E | left; exists v | right; exists q, pv]; cbn [fst snd] in E; injection E as <- ->; auto. Qed. - Lemma transS_embed : forall I S p, - PF.PkgSet.In (embedPkg p) (transS I S) <-> PkgSet.In p S. + Lemma coreResolution_embed : forall I S p, + PF.PkgSet.In (embedPkg p) (coreResolution I S) <-> PkgSet.In p S. Proof. intros I S [n v]; split. - - intro H; apply transS_at_orig in H. + - intro H; apply coreResolution_at_orig in H. destruct H as [[v' [Hp E]] | [q [pv [_ [_ E]]]]]; [injection E as <-; exact Hp | discriminate E]. - - intro Hp; apply mem_transS; right; left; exists (n, v); auto. + - intro Hp; apply mem_coreResolution; right; left; exists (n, v); auto. Qed. - Lemma transS_prov : forall I S m q pv, - PF.PkgSet.In (Name.Orig m, Version.Prov q pv) (transS I S) <-> + Lemma coreResolution_prov : forall I S m q pv, + PF.PkgSet.In (Name.Orig m, Version.Prov q pv) (coreResolution I S) <-> Prov.In (q, (m, PVer pv)) (inst_prov I) /\ PkgSet.In q S. Proof. intros I S m q pv; split. - - intro H; apply transS_at_orig in H. + - intro H; apply coreResolution_at_orig in H. destruct H as [[v [_ E]] | [q' [pv' [Hr [Hq E]]]]]; [discriminate E | injection E as <- <-; auto]. - - intros [Hr Hq]; apply mem_transS; right; right; exists q, m, pv; auto. + - intros [Hr Hq]; apply mem_coreResolution; right; right. + exists q, m, pv; auto. Qed. - Lemma mem_transD : forall I y f, - PF.DepRel.In (y, f) (transD I) <-> - PF.PkgSet.In y (transR I) /\ FSet.In f (dependees I y). + Lemma mem_reduceDeps : forall I y f, + PF.DepRel.In (y, f) (reduceDeps I) <-> + PF.PkgSet.In y (reduceReal I) /\ FSet.In f (dependees I y). Proof. - intros I y f; unfold transD; rewrite SOqd.mem_unionMap. + intros I y f; unfold reduceDeps; rewrite SOqd.mem_unionMap. split. - intros [q [Hq Hf]]; unfold depEdges in Hf. - apply SOfd.mem_map in Hf; destruct Hf as [g [Hg He]]. - injection He as <- <-; split; assumption. + apply SOfd.mem_map in Hf; mem_destruct; auto. - intros [Hy Hf]; exists y; split; [exact Hy |]. unfold depEdges; apply SOfd.mem_map; exists f; split; [exact Hf | reflexivity]. @@ -913,26 +902,28 @@ Module Alpine (N V : UsualOrderedType) (PM : ApkVerMatch V). (split; [| exact Hn]); apply LeastDesignation.in_elements; exact Ha. Qed. - Lemma embed_transR : forall I p, - PF.PkgSet.In (embedPkg p) (transR I) -> + Lemma embed_reduceReal : forall I p, + PF.PkgSet.In (embedPkg p) (reduceReal I) -> PkgSet.In p (inst_repo I). Proof. - intros I p H; rewrite transR_transS, transS_embed in H; exact H. + intros I p H. + rewrite reduceReal_coreResolution, coreResolution_embed in H; exact H. Qed. - Lemma root_transR : forall I, PF.PkgSet.In rootPkg (transR I). + Lemma root_reduceReal : forall I, PF.PkgSet.In rootPkg (reduceReal I). Proof. - intro I; unfold transR; apply PF.PkgSet.add_spec; left; reflexivity. + intro I; unfold reduceReal; apply PF.PkgSet.add_spec; left; reflexivity. Qed. Lemma prov_selected : forall I S' m q pv, - PF.IsResolution (transR I) (transD I) rootPkg S' -> + PF.IsResolution (reduceReal I) (reduceDeps I) rootPkg S' -> PF.PkgSet.In (Name.Orig m, Version.Prov q pv) S' -> Prov.In (q, (m, PVer pv)) (inst_prov I) /\ PF.PkgSet.In (embedPkg q) S'. Proof. intros I S' m q pv [Hsub Hroot Hclo Huniq] Hm. - assert (Ht := Hsub _ Hm); rewrite transR_transS, transS_prov in Ht. + assert (Ht := Hsub _ Hm). + rewrite reduceReal_coreResolution, coreResolution_prov in Ht. split; [exact (proj1 Ht) |]. assert (Hf : FSet.In (PF.FDep (Name.Orig (fst q)) @@ -943,8 +934,8 @@ Module Alpine (N V : UsualOrderedType) (PM : ApkVerMatch V). ((Name.Orig m, Version.Prov q pv), PF.FDep (Name.Orig (fst q)) (PF.VSet.singleton (Version.Orig (snd q)))) - (transD I)). - { apply mem_transD; split; [apply Hsub; exact Hm | exact Hf]. } + (reduceDeps I)). + { apply mem_reduceDeps; split; [apply Hsub; exact Hm | exact Hf]. } assert (Hs := Hclo _ Hm _ Hd). destruct Hs as [w [Hw HwS]]. apply PF.VSet.singleton_spec in Hw; subst w. @@ -952,7 +943,7 @@ Module Alpine (N V : UsualOrderedType) (PM : ApkVerMatch V). Qed. Lemma reg_edge : forall I S' p m pv, - PF.IsResolution (transR I) (transD I) rootPkg S' -> + PF.IsResolution (reduceReal I) (reduceDeps I) rootPkg S' -> PF.PkgSet.In (embedPkg p) S' -> Prov.In (p, (m, PVer pv)) (inst_prov I) -> PF.PkgSet.In (Name.Orig m, Version.Prov p pv) S'. @@ -971,15 +962,15 @@ Module Alpine (N V : UsualOrderedType) (PM : ApkVerMatch V). (embedPkg (n, v), PF.FDep (Name.Orig m) (PF.VSet.singleton (Version.Prov (n, v) pv))) - (transD I)). - { apply mem_transD; split; [apply Hsub; exact HpS | exact Hf]. } + (reduceDeps I)). + { apply mem_reduceDeps; split; [apply Hsub; exact HpS | exact Hf]. } assert (Hs := Hclo _ HpS _ Hd). destruct Hs as [w [Hw HwS]]. apply PF.VSet.singleton_spec in Hw; subst w; exact HwS. Qed. Lemma base_decode : forall I S' n ct, - PF.IsResolution (transR I) (transD I) rootPkg S' -> + PF.IsResolution (reduceReal I) (reduceDeps I) rootPkg S' -> ((exists w, PF.VSet.In w (constrVers I n ct) /\ PF.PkgSet.In (Name.Orig n, w) S') <-> (exists v, PkgSet.In (n, v) (alpineResolution S') /\ @@ -1005,17 +996,17 @@ Module Alpine (N V : UsualOrderedType) (PM : ApkVerMatch V). exists (Version.Orig v); split; [| exact HvS]. apply mem_constrVers; left; exists v. repeat split; try assumption. - exact (embed_transR _ _ (Hsub _ HvS)). + exact (embed_reduceReal _ _ (Hsub _ HvS)). + apply mem_alpineResolution in HqS. exists (Version.Prov q pv); split. * apply mem_constrVers; right; exists q, pv. repeat split; try assumption. - exact (embed_transR _ _ (Hsub _ HqS)). + exact (embed_reduceReal _ _ (Hsub _ HqS)). * exact (reg_edge _ _ _ _ _ Hres HqS Hprov). Qed. Lemma match_decode : forall I S' n ct, - PF.IsResolution (transR I) (transD I) rootPkg S' -> + PF.IsResolution (reduceReal I) (reduceDeps I) rootPkg S' -> (PF.Satisfies S' (encPos I n ct) <-> MatchPos I (alpineResolution S') n ct). Proof. @@ -1030,11 +1021,11 @@ Module Alpine (N V : UsualOrderedType) (PM : ApkVerMatch V). - intros [q [Hp HqS]]; exists q. apply mem_alpineResolution in HqS; split; [| exact HqS]. apply mem_uprovSet; split; - [exact Hp | exact (embed_transR _ _ (Hsub _ HqS))]. + [exact Hp | exact (embed_reduceReal _ _ (Hsub _ HqS))]. Qed. Lemma match_req_decode : forall I S' n ct, - PF.IsResolution (transR I) (transD I) rootPkg S' -> + PF.IsResolution (reduceReal I) (reduceDeps I) rootPkg S' -> (PF.Satisfies S' (encReq I n ct) <-> MatchReq I (alpineResolution S') n ct). Proof. @@ -1050,12 +1041,12 @@ Module Alpine (N V : UsualOrderedType) (PM : ApkVerMatch V). - intros [q [Hp [HqS Ha]]]; exists q. apply mem_alpineResolution in HqS. split; [apply mem_uprovSet; split; - [exact Hp | exact (embed_transR _ _ (Hsub _ HqS))] |]. + [exact Hp | exact (embed_reduceReal _ _ (Hsub _ HqS))] |]. split; [apply selectableb_spec; exact Ha | exact HqS]. Qed. Lemma cond_decode : forall I S' c, - PF.IsResolution (transR I) (transD I) rootPkg S' -> + PF.IsResolution (reduceReal I) (reduceDeps I) rootPkg S' -> (PF.Satisfies S' (encCond I c) <-> MatchCond I (alpineResolution S') c). Proof. @@ -1064,29 +1055,26 @@ Module Alpine (N V : UsualOrderedType) (PM : ApkVerMatch V). rewrite (match_decode I S' n ct Hres); reflexivity. Qed. - (* A rule with no positive condition has nothing to designate, so the - obligation res_installIf states of it would have nothing to carry - it. *) Definition WfInstallIf (I : Inst) : Prop := forall z conds, InstallIf.In (z, conds) (inst_installIf I) -> exists a, CondSet.In (DPos a) conds. Theorem alpine_soundness : forall I S', WfInstallIf I -> - PF.IsResolution (transR I) (transD I) rootPkg S' -> + PF.IsResolution (reduceReal I) (reduceDeps I) rootPkg S' -> IsResolution I (alpineResolution S'). Proof. intros I S' Hwf Hres. assert (Hres' := Hres); destruct Hres' as [Hsub Hroot Hclo Huniq]. constructor. - intros p Hp; apply mem_alpineResolution in Hp. - exact (embed_transR _ _ (Hsub _ Hp)). + exact (embed_reduceReal _ _ (Hsub _ Hp)). - intros d Hd. assert (Hf : FSet.In (encDep I d) (dependees I rootPkg)). { cbn [dependees rootPkg]. apply SOwf.mem_map; exists d; split; [exact Hd | reflexivity]. } - assert (Hdep : PF.DepRel.In (rootPkg, encDep I d) (transD I)). - { apply mem_transD; split; [apply root_transR | exact Hf]. } + assert (Hdep : PF.DepRel.In (rootPkg, encDep I d) (reduceDeps I)). + { apply mem_reduceDeps; split; [apply root_reduceReal | exact Hf]. } assert (Hs := Hclo _ Hroot _ Hdep). destruct d as [[m ct] | [m ct]]; cbn [MatchDep]. + exact (proj1 (match_req_decode _ _ _ _ Hres) Hs). @@ -1100,8 +1088,8 @@ Module Alpine (N V : UsualOrderedType) (PM : ApkVerMatch V). apply SOdf.mem_map; exists ((np, vp), d); split; [| reflexivity]. apply DepsFibred.mem_tailFibre; split; [exact Hdep0 | reflexivity]. } assert (Hdep : PF.DepRel.In (embedPkg (np, vp), encDep I d) - (transD I)). - { apply mem_transD; split; [apply Hsub; exact Hp | exact Hf]. } + (reduceDeps I)). + { apply mem_reduceDeps; split; [apply Hsub; exact Hp | exact Hf]. } assert (Hs := Hclo _ Hp _ Hdep). destruct d as [[m ct] | [m ct]]; cbn [MatchDep]. + exact (proj1 (match_req_decode _ _ _ _ Hres) Hs). @@ -1156,8 +1144,8 @@ Module Alpine (N V : UsualOrderedType) (PM : ApkVerMatch V). apply SOtf.mem_map; exists (z, conds); split; [exact Hfib | reflexivity]. } assert (Hdep : PF.DepRel.In (embedPkg p, installIfForm I z conds) - (transD I)). - { apply mem_transD; split; [apply Hsub; exact HpS | exact Hf]. } + (reduceDeps I)). + { apply mem_reduceDeps; split; [apply Hsub; exact HpS | exact Hf]. } assert (Hs := Hclo _ HpS _ Hdep). apply satisfies_installIfForm in Hs. destruct Hs as [[c [Hcr Hn]] | Hb]. @@ -1167,19 +1155,16 @@ Module Alpine (N V : UsualOrderedType) (PM : ApkVerMatch V). + exact (proj1 (match_decode _ _ _ _ Hres) Hb). Qed. - (* A package providing one name at two versions, or providing its own - name, would put two target versions of that name in the witness - from a single source claimant; apk metadata declares neither. *) Definition WfProvides (I : Inst) : Prop := (forall q n pv pv', Prov.In (q, (n, PVer pv)) (inst_prov I) -> Prov.In (q, (n, PVer pv')) (inst_prov I) -> pv = pv') /\ (forall n v pv, ~ Prov.In ((n, v), (n, PVer pv)) (inst_prov I)). - Lemma base_transS : forall I S n ct, + Lemma base_coreResolution : forall I S n ct, PkgSet.Subset S (inst_repo I) -> ((exists w, PF.VSet.In w (constrVers I n ct) /\ - PF.PkgSet.In (Name.Orig n, w) (transS I S)) <-> + PF.PkgSet.In (Name.Orig n, w) (coreResolution I S)) <-> (exists v, PkgSet.In (n, v) S /\ constrMatch ct v = true) \/ (exists q pv, Prov.In (q, (n, PVer pv)) (inst_prov I) /\ PkgSet.In q S /\ constrMatch ct pv = true)). @@ -1187,80 +1172,82 @@ Module Alpine (N V : UsualOrderedType) (PM : ApkVerMatch V). intros I S n ct Hsub; split. - intros [w [Hw Hm]]; apply mem_constrVers in Hw. destruct Hw as [[v [_ [Hc ->]]] | [q [pv [_ [_ [Hc ->]]]]]]. - + apply (transS_embed I S (n, v)) in Hm; left; eauto. - + apply transS_prov in Hm; destruct Hm as [Hprov Hq]. + + apply (coreResolution_embed I S (n, v)) in Hm; left; eauto. + + apply coreResolution_prov in Hm; destruct Hm as [Hprov Hq]. right; exists q, pv; auto. - intros [[v [HvS Hc]] | [q [pv [Hprov [HqS Hc]]]]]. + exists (Version.Orig v); split. * apply mem_constrVers; left; exists v. repeat split; try assumption. exact (Hsub _ HvS). - * exact (proj2 (transS_embed I S (n, v)) HvS). + * exact (proj2 (coreResolution_embed I S (n, v)) HvS). + exists (Version.Prov q pv); split. * apply mem_constrVers; right; exists q, pv. repeat split; try assumption. exact (Hsub _ HqS). - * apply transS_prov; split; assumption. + * apply coreResolution_prov; split; assumption. Qed. - Lemma match_transS : forall I S n ct, + Lemma match_coreResolution : forall I S n ct, PkgSet.Subset S (inst_repo I) -> - (PF.Satisfies (transS I S) (encPos I n ct) <-> + (PF.Satisfies (coreResolution I S) (encPos I n ct) <-> MatchPos I S n ct). Proof. intros I S n ct Hsub. - rewrite satisfies_encPos, (base_transS I S n ct Hsub). + rewrite satisfies_encPos, (base_coreResolution I S n ct Hsub). unfold MatchPos; rewrite or_assoc. apply or_iff_compat_l, or_iff_compat_l, and_iff_compat_l; split. - intros [q [Hq Hm]]; apply mem_uprovSet in Hq. - apply transS_embed in Hm; exists q; split; [exact (proj1 Hq) |]. + apply coreResolution_embed in Hm; exists q; split; [exact (proj1 Hq) |]. exact Hm. - intros [q [Hp HqS]]; exists q; split; [apply mem_uprovSet; split; [exact Hp | exact (Hsub _ HqS)] - | apply transS_embed; exact HqS]. + | apply coreResolution_embed; exact HqS]. Qed. - Lemma match_req_transS : forall I S n ct, + Lemma match_req_coreResolution : forall I S n ct, PkgSet.Subset S (inst_repo I) -> - (PF.Satisfies (transS I S) (encReq I n ct) <-> + (PF.Satisfies (coreResolution I S) (encReq I n ct) <-> MatchReq I S n ct). Proof. intros I S n ct Hsub. - rewrite satisfies_encReq, (base_transS I S n ct Hsub). + rewrite satisfies_encReq, (base_coreResolution I S n ct Hsub). unfold MatchReq; rewrite or_assoc. apply or_iff_compat_l, or_iff_compat_l, and_iff_compat_l; split. - intros [q [Hq [Hs Hm]]]; apply mem_uprovSet in Hq. - apply transS_embed in Hm; exists q; split; [exact (proj1 Hq) |]. + apply coreResolution_embed in Hm; exists q; split; [exact (proj1 Hq) |]. split; [exact Hm | apply selectableb_spec; exact Hs]. - intros [q [Hp [HqS Ha]]]; exists q. split; [apply mem_uprovSet; split; [exact Hp | exact (Hsub _ HqS)] |]. split; [apply selectableb_spec; exact Ha |]. - apply transS_embed; exact HqS. + apply coreResolution_embed; exact HqS. Qed. Theorem alpine_completeness : forall I S, WfProvides I -> IsResolution I S -> - PF.IsResolution (transR I) (transD I) rootPkg (transS I S). + PF.IsResolution (reduceReal I) (reduceDeps I) rootPkg + (coreResolution I S). Proof. intros I S [Wf1 Wf2] Hres. destruct Hres as [Hsub Hw Hd Hcu Ht]. - assert (Hiff := fun n ct => match_transS I S n ct Hsub). - assert (Hreq := fun n ct => match_req_transS I S n ct Hsub). - assert (Hcond : forall c, PF.Satisfies (transS I S) (encCond I c) <-> + assert (Hiff := fun n ct => match_coreResolution I S n ct Hsub). + assert (Hreq := fun n ct => match_req_coreResolution I S n ct Hsub). + assert (Hcond : forall c, + PF.Satisfies (coreResolution I S) (encCond I c) <-> MatchCond I S c). { intros [[n ct] | [n ct]]; cbn [encCond MatchCond PF.Satisfies]; rewrite (Hiff n ct); reflexivity. } constructor. - intros [[| n] w] Hy. - + apply transS_at_root in Hy; subst w; apply root_transR. - + rewrite transR_transS; apply transS_at_orig in Hy. + + apply coreResolution_at_root in Hy; subst w; apply root_reduceReal. + + rewrite reduceReal_coreResolution; apply coreResolution_at_orig in Hy. destruct Hy as [[v [Hv ->]] | [q [pv [Hr [Hq ->]]]]]. - * exact (proj2 (transS_embed I _ (n, v)) (Hsub _ Hv)). - * apply transS_prov; split; [exact Hr | exact (Hsub _ Hq)]. - - apply mem_transS; left; reflexivity. + * exact (proj2 (coreResolution_embed I _ (n, v)) (Hsub _ Hv)). + * apply coreResolution_prov; split; [exact Hr | exact (Hsub _ Hq)]. + - apply mem_coreResolution; left; reflexivity. - intros y Hy f Hdep. - apply mem_transD in Hdep; destruct Hdep as [HyR Hf]. - apply mem_transS in Hy. + apply mem_reduceDeps in Hdep; destruct Hdep as [HyR Hf]. + apply mem_coreResolution in Hy. destruct Hy as [-> | [[p [Hp ->]] | [q [m [pv [Hr [Hq ->]]]]]]]. + cbn [dependees rootPkg] in Hf. apply SOwf.mem_map in Hf; destruct Hf as [d [Hd0 ->]]. @@ -1292,14 +1279,14 @@ Module Alpine (N V : UsualOrderedType) (PM : ApkVerMatch V). cbn [PF.Satisfies]. exists (Version.Prov (n0, v0) pv); split. -- apply PF.VSet.singleton_spec; reflexivity. - -- apply transS_prov; split; assumption. + -- apply coreResolution_prov; split; assumption. * apply SOtf.mem_map in Hf; destruct Hf as [[z conds] [Hfib ->]]. apply mem_installIfFibre in Hfib. destruct Hfib as [Ht0 Hatt]; unfold attachDesignation in Hatt. destruct (D.designation conds) as [a |] eqn:Edes; [| discriminate]. apply satisfies_installIfForm. destruct (CondSet.exists_ - (fun b => negb (PF.satisfiesb (transS I S) + (fun b => negb (PF.satisfiesb (coreResolution I S) (encCond I b))) (condRest conds)) eqn:Ee. -- apply CondSet.exists_spec' in Ee. @@ -1317,14 +1304,14 @@ Module Alpine (N V : UsualOrderedType) (PM : ApkVerMatch V). { unfold condRest; rewrite Edes. apply CondSet.remove_spec; split; [exact Hc | exact Hne]. } - assert (Hbt : PF.satisfiesb (transS I S) + assert (Hbt : PF.satisfiesb (coreResolution I S) (encCond I c) = true). - { destruct (PF.satisfiesb (transS I S) (encCond I c)) + { destruct (PF.satisfiesb (coreResolution I S) (encCond I c)) eqn:Eb; [reflexivity |]. exfalso. assert (Hex : CondSet.exists_ (fun b => - negb (PF.satisfiesb (transS I S) + negb (PF.satisfiesb (coreResolution I S) (encCond I b))) (condRest conds) = true). { apply CondSet.exists_spec'; exists c; split; @@ -1336,11 +1323,11 @@ Module Alpine (N V : UsualOrderedType) (PM : ApkVerMatch V). cbn [PF.Satisfies]. exists (Version.Orig (snd q)); split. * apply PF.VSet.singleton_spec; reflexivity. - * exact (proj2 (transS_embed I S q) Hq). + * exact (proj2 (coreResolution_embed I S q) Hq). - intros m w w' H1 H2. destruct m as [| n]. - + apply transS_at_root in H1, H2; congruence. - + apply transS_at_orig in H1, H2. + + apply coreResolution_at_root in H1, H2; congruence. + + apply coreResolution_at_orig in H1, H2. destruct H1 as [[v1 [Hv1 ->]] | [q1 [pv1 [Hr1 [Hq1 ->]]]]], H2 as [[v2 [Hv2 ->]] | [q2 [pv2 [Hr2 [Hq2 ->]]]]]. * f_equal. @@ -1366,23 +1353,6 @@ Module Alpine (N V : UsualOrderedType) (PM : ApkVerMatch V). rewrite (Wf1 _ _ _ _ Hr1 Hr2); reflexivity. Qed. - Theorem alpineResolution_transS : forall I S, - alpineResolution (transS I S) = S. - Proof. - intros I S; apply PkgSet.ext; intros [n v]. - rewrite mem_alpineResolution, transS_embed; reflexivity. - Qed. - - Theorem alpineResolution_coreResolution : forall I S, - alpineResolution - (PF.Reduction.packageFormulaResolution - (PF.Reduction.coreResolution (transS I S) (transR I) (transD I))) - = S. - Proof. - intros I S; rewrite PF.Reduction.packageFormulaResolution_coreResolution. - apply alpineResolution_transS. - Qed. - Module Lookup. Lemma or_iff : forall A B C D : Prop, (A <-> C) -> (B <-> D) -> (A \/ B <-> C \/ D). @@ -1473,8 +1443,7 @@ Module Alpine (N V : UsualOrderedType) (PM : ApkVerMatch V). ; inst_prov := Prov.union ownProv (provPreimage I ns) ; inst_installIf := installIf ; inst_world := world - ; inst_prio := prioOf I (repoPreimage I ns) - ; inst_repl := Repl.empty |}. + ; inst_prio := prioOf I (repoPreimage I ns) |}. Lemma constrVers_subInst : forall I ns deps ownProv installIf world n ct, NSet.In n ns -> @@ -1541,7 +1510,7 @@ Module Alpine (N V : UsualOrderedType) (PM : ApkVerMatch V). subInst I (NSet.singleton n) Deps.empty Prov.empty InstallIf.empty WSet.empty. - Theorem versions_lookupName : forall I n, + Theorem versions_lookupOrig : forall I n, versions (nameSubInst I n) n = versions I n. Proof. intros I n; unfold versions, nameSubInst. @@ -1879,58 +1848,49 @@ Module Alpine (N V : UsualOrderedType) (PM : ApkVerMatch V). | exact (world_rootNames I d Hd) | exact Hown ]. Qed. - Lemma versions_transR : forall I m, - PF.C.versions (transR I) (Name.Orig m) = versions I m. + Lemma versions_reduceReal : forall I m, + PF.C.versions (reduceReal I) (Name.Orig m) = versions I m. Proof. intros I m; apply PF.VSet.ext; intro w. - rewrite PF.C.mem_versions, transR_transS; unfold versions. + rewrite PF.C.mem_versions, reduceReal_coreResolution; unfold versions. rewrite mem_constrVers; split. - - intro H; apply transS_at_orig in H. + - intro H; apply coreResolution_at_orig in H. destruct H as [[v [Hv ->]] | [q [pv [Hprov [Hq ->]]]]]; [left; exists v | right; exists q, pv]; auto. - intros [[v [Hv [_ ->]]] | [q [pv [Hprov [Hq [_ ->]]]]]]. - + exact (proj2 (transS_embed I _ (m, v)) Hv). - + apply transS_prov; split; assumption. + + exact (proj2 (coreResolution_embed I _ (m, v)) Hv). + + apply coreResolution_prov; split; assumption. Qed. - Lemma versions_transR_root : forall I, - PF.C.versions (transR I) Name.Root = PF.VSet.singleton Version.RootV. + Lemma versions_reduceReal_root : forall I, + PF.C.versions (reduceReal I) Name.Root = + PF.VSet.singleton Version.RootV. Proof. intro I; apply PF.VSet.ext; intro w. rewrite PF.C.mem_versions, PF.VSet.singleton_spec. - split; [apply transS_at_root | intros ->; apply root_transR]. + split; + [apply coreResolution_at_root | intros ->; apply root_reduceReal]. Qed. - Lemma transD_tailFibre : forall I q, - PF.PkgSet.In q (transR I) -> - PF.Reduction.Lookup.DepRelFibred.tailFibre (transD I) q = + Lemma reduceDeps_tailFibre : forall I q, + PF.PkgSet.In q (reduceReal I) -> + PF.Reduction.Lookup.DepRelFibred.tailFibre (reduceDeps I) q = depEdges q (dependees I q). Proof. intros I q Hq; apply PF.DepRel.ext; intros [q' f]. - rewrite PF.Reduction.Lookup.DepRelFibred.mem_tailFibre, mem_transD. + rewrite PF.Reduction.Lookup.DepRelFibred.mem_tailFibre, mem_reduceDeps. unfold depEdges; rewrite SOfd.mem_map. split. - intros [[_ Hf] ->]; exists f; split; [exact Hf | reflexivity]. - - intros [f0 [Hf0 E]]; injection E as -> ->. - split; [split; [exact Hq | exact Hf0] | reflexivity]. + - intro H; mem_destruct; auto. Qed. - (* The core lookups a driver answers: a package's formulas from its - own sub-instance, pushed through the package-formula reduction - under an oracle agreeing with versions. That sub-instance cannot - serve as the oracle: a negated requirement or positive install-if - condition whose constraint bareMatch admits negates each bare - provider q at q's own name, whose complement ranges over every - version at that name, its provides included, while repoPreimage - keeps only the packages at or providing the names the package - mentions -- q itself, and not the rest of q's name. The versions - lookup at q's name does hold them. *) Lemma dependees_core : forall I Vq q, - PF.PkgSet.In q (transR I) -> + PF.PkgSet.In q (reduceReal I) -> Vq Name.Root = PF.VSet.singleton Version.RootV -> (forall m, Vq (Name.Orig m) = versions I m) -> PF.Reduction.T.dependees - (PF.Reduction.reduceDeps (transR I) (transD I)) + (PF.Reduction.reduceDeps (reduceReal I) (reduceDeps I)) (PF.Reduction.Name.Orig (fst q), PF.Reduction.Version.Orig (snd q)) = PF.Reduction.T.dependees @@ -1941,9 +1901,10 @@ Module Alpine (N V : UsualOrderedType) (PM : ApkVerMatch V). intros I Vq [tn tv] Hq HR HO; cbn [fst snd]. rewrite (PF.Reduction.Lookup.dependees_lookupOrigBy _ _ Vq) by (intros [| m] _; - [rewrite HR, versions_transR_root | rewrite HO, versions_transR]; + [rewrite HR, versions_reduceReal_root + | rewrite HO, versions_reduceReal]; reflexivity). - rewrite (transD_tailFibre I (tn, tv) Hq); reflexivity. + rewrite (reduceDeps_tailFibre I (tn, tv) Hq); reflexivity. Qed. Theorem dependees_lookupOrigCore : forall I Vq n v, @@ -1951,7 +1912,7 @@ Module Alpine (N V : UsualOrderedType) (PM : ApkVerMatch V). Vq Name.Root = PF.VSet.singleton Version.RootV -> (forall m, Vq (Name.Orig m) = versions I m) -> PF.Reduction.T.dependees - (PF.Reduction.reduceDeps (transR I) (transD I)) + (PF.Reduction.reduceDeps (reduceReal I) (reduceDeps I)) (PF.Reduction.embedPkg (embedPkg (n, v))) = PF.Reduction.T.dependees (PF.Reduction.reduceDepsBy Vq @@ -1961,14 +1922,14 @@ Module Alpine (N V : UsualOrderedType) (PM : ApkVerMatch V). Proof. intros I Vq n v Hnv HR HO; rewrite dependees_lookupOrig. apply (dependees_core I Vq (embedPkg (n, v))); [| exact HR | exact HO]. - rewrite transR_transS, transS_embed; exact Hnv. + rewrite reduceReal_coreResolution, coreResolution_embed; exact Hnv. Qed. Theorem dependees_lookupRootCore : forall I Vq, Vq Name.Root = PF.VSet.singleton Version.RootV -> (forall m, Vq (Name.Orig m) = versions I m) -> PF.Reduction.T.dependees - (PF.Reduction.reduceDeps (transR I) (transD I)) + (PF.Reduction.reduceDeps (reduceReal I) (reduceDeps I)) (PF.Reduction.embedPkg rootPkg) = PF.Reduction.T.dependees (PF.Reduction.reduceDepsBy Vq @@ -1976,7 +1937,7 @@ Module Alpine (N V : UsualOrderedType) (PM : ApkVerMatch V). (PF.Reduction.embedPkg rootPkg). Proof. intros I Vq HR HO; rewrite dependees_lookupRoot. - exact (dependees_core I Vq rootPkg (root_transR I) HR HO). + exact (dependees_core I Vq rootPkg (root_reduceReal I) HR HO). Qed. Theorem dependees_lookupProvCore : forall I I' Vq m q pv, @@ -1985,7 +1946,7 @@ Module Alpine (N V : UsualOrderedType) (PM : ApkVerMatch V). Vq Name.Root = PF.VSet.singleton Version.RootV -> (forall m, Vq (Name.Orig m) = versions I m) -> PF.Reduction.T.dependees - (PF.Reduction.reduceDeps (transR I) (transD I)) + (PF.Reduction.reduceDeps (reduceReal I) (reduceDeps I)) (PF.Reduction.embedPkg (Name.Orig m, Version.Prov q pv)) = PF.Reduction.T.dependees (PF.Reduction.reduceDepsBy Vq @@ -1998,11 +1959,12 @@ Module Alpine (N V : UsualOrderedType) (PM : ApkVerMatch V). <- (dependees_lookupProv I m q pv). apply (dependees_core I Vq (Name.Orig m, Version.Prov q pv)); [| exact HR | exact HO]. - rewrite transR_transS, transS_prov; split; assumption. + rewrite reduceReal_coreResolution, coreResolution_prov. + split; assumption. Qed. Theorem dependees_lookupDisjunctCore : forall I I' Vq q fs i, - PF.PkgSet.In q (transR I) -> + PF.PkgSet.In q (reduceReal I) -> dependees I' q = dependees I q -> Vq Name.Root = PF.VSet.singleton Version.RootV -> (forall m, Vq (Name.Orig m) = versions I m) -> @@ -2010,7 +1972,7 @@ Module Alpine (N V : UsualOrderedType) (PM : ApkVerMatch V). (PF.Reduction.reduceReal (PF.PkgSet.singleton q) (depEdges q (dependees I' q))) -> PF.Reduction.T.dependees - (PF.Reduction.reduceDeps (transR I) (transD I)) + (PF.Reduction.reduceDeps (reduceReal I) (reduceDeps I)) (PF.Reduction.Name.Disjunct fs, i) = PF.Reduction.T.dependees (PF.Reduction.reduceDepsBy Vq (depEdges q (dependees I' q))) @@ -2018,67 +1980,87 @@ Module Alpine (N V : UsualOrderedType) (PM : ApkVerMatch V). Proof. intros I I' Vq q fs i Hq HI HR HO Hin; rewrite HI in Hin |- *. assert (Hsub : PF.DepRel.Subset (depEdges q (dependees I q)) - (transD I)). - { rewrite <- (transD_tailFibre I q Hq). + (reduceDeps I)). + { rewrite <- (reduceDeps_tailFibre I q Hq). apply PF.Reduction.Lookup.DepRelFibred.tailFibre_subset. } apply (PF.Reduction.Lookup.dependees_lookupDisjunctBy _ _ _ _ _ _ _ Hsub Hin). intros p f [| m] _ _; - [rewrite HR, versions_transR_root | rewrite HO, versions_transR]; + [rewrite HR, versions_reduceReal_root + | rewrite HO, versions_reduceReal]; reflexivity. Qed. Lemma versions_core : forall I tn, - (exists w, PF.PkgSet.In (tn, w) (transR I)) \/ + (exists w, PF.PkgSet.In (tn, w) (reduceReal I)) \/ (exists s h, PF.Reduction.T.DepRel.In (s, (PF.Reduction.Name.Orig tn, h)) - (PF.Reduction.reduceDeps (transR I) (transD I))) -> + (PF.Reduction.reduceDeps (reduceReal I) (reduceDeps I))) -> PF.Reduction.T.versions - (PF.Reduction.reduceReal (transR I) (transD I)) + (PF.Reduction.reduceReal (reduceReal I) (reduceDeps I)) (PF.Reduction.Name.Orig tn) = PF.Reduction.T.VSet.add PF.Reduction.Version.Bot - (PF.Reduction.embedVS (PF.C.versions (transR I) tn)). + (PF.Reduction.embedVS (PF.C.versions (reduceReal I) tn)). Proof. intros I tn Hreach. destruct Hreach as [[w Hw] | Hreach]; [rewrite (PF.Reduction.Lookup.versions_lookupOrig _ _ (tn, w) tn Hw (or_intror eq_refl) eq_refl) | rewrite (PF.Reduction.Lookup.versions_lookupOrig _ _ rootPkg tn - (root_transR I) (or_introl Hreach) eq_refl)]; + (root_reduceReal I) (or_introl Hreach) eq_refl)]; do 2 f_equal; apply PF.C.versions_ext; intro v; rewrite PF.Reduction.Lookup.PkgFibred.mem_tailFibre; tauto. Qed. - Theorem versions_lookupNameCore : forall I n, + Theorem versions_lookupOrigCore : forall I n, (exists v, PkgSet.In (n, v) (inst_repo I)) \/ (exists s h, PF.Reduction.T.DepRel.In (s, (PF.Reduction.Name.Orig (Name.Orig n), h)) - (PF.Reduction.reduceDeps (transR I) (transD I))) -> + (PF.Reduction.reduceDeps (reduceReal I) (reduceDeps I))) -> PF.Reduction.T.versions - (PF.Reduction.reduceReal (transR I) (transD I)) + (PF.Reduction.reduceReal (reduceReal I) (reduceDeps I)) (PF.Reduction.Name.Orig (Name.Orig n)) = PF.Reduction.T.VSet.add PF.Reduction.Version.Bot (PF.Reduction.embedVS (versions (nameSubInst I n) n)). Proof. - intros I n H; rewrite versions_lookupName, <- versions_transR. + intros I n H; rewrite versions_lookupOrig, <- versions_reduceReal. apply versions_core. destruct H as [[v Hv] | H]; [left; exists (Version.Orig v) | right; exact H]. - rewrite transR_transS; exact (proj2 (transS_embed I _ (n, v)) Hv). + rewrite reduceReal_coreResolution. + exact (proj2 (coreResolution_embed I _ (n, v)) Hv). Qed. Theorem versions_lookupRootCore : forall I, PF.Reduction.T.versions - (PF.Reduction.reduceReal (transR I) (transD I)) + (PF.Reduction.reduceReal (reduceReal I) (reduceDeps I)) (PF.Reduction.Name.Orig Name.Root) = PF.Reduction.T.VSet.add PF.Reduction.Version.Bot (PF.Reduction.embedVS (PF.VSet.singleton Version.RootV)). Proof. - intro I; rewrite <- (versions_transR_root I); apply versions_core. - left; exists Version.RootV; exact (root_transR I). + intro I; rewrite <- (versions_reduceReal_root I); apply versions_core. + left; exists Version.RootV; exact (root_reduceReal I). Qed. End Lookup. + + Theorem alpineResolution_coreResolution : forall I S, + alpineResolution (coreResolution I S) = S. + Proof. + intros I S; apply PkgSet.ext; intros [n v]. + rewrite mem_alpineResolution, coreResolution_embed; reflexivity. + Qed. + + Theorem alpineResolution_core : forall I S, + alpineResolution + (PF.Reduction.packageFormulaResolution + (PF.Reduction.coreResolution (coreResolution I S) (reduceReal I) + (reduceDeps I))) + = S. + Proof. + intros I S; rewrite PF.Reduction.packageFormulaResolution_coreResolution. + apply alpineResolution_coreResolution. + Qed. End Reduct. Module Reduction := Reduct LeastDesignation. diff --git a/theories/Cargo.v b/theories/Cargo.v index 08020bb..8ee410c 100644 --- a/theories/Cargo.v +++ b/theories/Cargo.v @@ -228,10 +228,6 @@ Module Cargo (N V F G CfgS Src : UsualOrderedType) (PM : SemverMatch V). Module PkgEqb := UOTEqb Pkg. Module SKEqb := UOTEqb SlotKey. - Lemma if_some {A : Type} : forall (b : bool) (x y : A), - (if b then Some x else None) = Some y <-> b = true /\ x = y. - Proof. intros [|] x y; intuition congruence. Qed. - Module SOpv := SetOps Pkg V PkgSet VSet. Definition evalReq (R : PkgSet.t) (m : N.t) (rg : Range) : VSet.t := SOpv.filterMap (fun '(o, u) => @@ -248,8 +244,7 @@ Module Cargo (N V F G CfgS Src : UsualOrderedType) (PM : SemverMatch V). - intros [[o w] [HR He]]; cbn beta iota in He. destruct (NEqb.eqb o m) eqn:En; [| discriminate]. apply NEqb.eqb_true_iff in En; subst o. - destruct (rgHolds rg w) eqn:Ev; [| discriminate]. - injection He as ->; split; assumption. + rewrite if_some_iff in He; destruct He as [Hv <-]; split; assumption. - intros [HR Hv]; exists (m, u); split; [exact HR | cbn beta iota]. rewrite NEqb.eqb_refl, Hv; reflexivity. Qed. @@ -609,7 +604,7 @@ Module Cargo (N V F G CfgS Src : UsualOrderedType) (PM : SemverMatch V). !NEqb.eqb_refl, !FEqb.eqb_refl; reflexivity. Qed. - Definition transRoot : T.Pkg.t := (NPlus.CRoot, VPlus.WUnit). + Definition rootPkg : T.Pkg.t := (NPlus.CRoot, VPlus.WUnit). Definition crateReal (g : V.t -> G.t) (R : PkgSet.t) : T.PkgSet.t := SOpp.map (fun '(m, v) => (NPlus.CCrate m (g v), VPlus.WOrig v)) R. @@ -650,11 +645,11 @@ Module Cargo (N V F G CfgS Src : UsualOrderedType) (PM : SemverMatch V). else None) Links. - Definition transReal (g : V.t -> G.t) (R : PkgSet.t) + Definition reduceReal (g : V.t -> G.t) (R : PkgSet.t) (support : SupportSet.t) (FDefs : FDefRel.t) (Slots : SlotRel.t) (Links : LinkRel.t) (rc : Pkg.t) : T.PkgSet.t := - T.PkgSet.union (T.PkgSet.singleton transRoot) + T.PkgSet.union (T.PkgSet.singleton rootPkg) (T.PkgSet.union (crateReal g R) (T.PkgSet.union (featReal g support) (T.PkgSet.union (slotReal g R Slots rc) @@ -668,13 +663,6 @@ Module Cargo (N V F G CfgS Src : UsualOrderedType) (PM : SemverMatch V). ((NPlus.CCrate m (g v), VPlus.WOrig v), NPlus.CLink l)) Links. - (* The lookups below say what one name or one package answers, without - the instance existing. That is what the driver needs, since a crate - is parsed the first time a lookup reads its name, so materialising - transReal to filter it would defeat the laziness the frontend is - built on. The edge relation is then built out of the per-package - lookup rather than beside it, so the two cannot disagree. *) - Module SOlv := SetOps LinkElt VPOT LinkRel T.VSet. Module SOpv2 := SetOps Pkg VPOT PkgSet T.VSet. Module SOspv := SetOps PkgF VPOT SupportSet T.VSet. @@ -812,7 +800,7 @@ Module Cargo (N V F G CfgS Src : UsualOrderedType) (PM : SemverMatch V). SOhe.map (fun h => (p, h)) hs. Module SOpe := SetOps T.Pkg T.DepElt T.PkgSet T.DepRel. - Definition transDeps (g : V.t -> G.t) (R : PkgSet.t) + Definition reduceDeps (g : V.t -> G.t) (R : PkgSet.t) (support : SupportSet.t) (FDefs : FDefRel.t) (Slots : SlotRel.t) (Links : LinkRel.t) (dflt : F.t) (rc : Pkg.t) (rootFeats : FSet.t) : T.DepRel.t := @@ -820,7 +808,7 @@ Module Cargo (N V F G CfgS Src : UsualOrderedType) (PM : SemverMatch V). depEdges p (dependees g R support FDefs Slots Links dflt rc rootFeats p)) - (transReal g R support FDefs Slots Links rc). + (reduceReal g R support FDefs Slots Links rc). Lemma mem_gransOf : forall g vs w, T.VSet.In w (gransOf g vs) <-> @@ -878,8 +866,7 @@ Module Cargo (N V F G CfgS Src : UsualOrderedType) (PM : SemverMatch V). intros g R Slots rc x; unfold slotReal. rewrite SOslp.mem_unionMap; split. - intros [[[m v] d] [Hs Hx]]; cbn beta iota in Hx. - destruct (slotActive rc (m, v) d) eqn:Ea; - [| exfalso; exact (SOvp.empty_in _ Hx)]. + apply SOslp.in_if_empty in Hx as [Ha Hx]. apply SOvp.mem_map in Hx; destruct Hx as [u [Hu ->]]. exists m, v, d, u; repeat split; assumption. - intros [m [v [d [u [Hs [Ha [Hu ->]]]]]]]. @@ -924,7 +911,7 @@ Module Cargo (N V F G CfgS Src : UsualOrderedType) (PM : SemverMatch V). Proof. intros g R Links x; unfold linkReal; rewrite SOlp.mem_filterMap; split. - intros [[[m v] l] [Hl He]]; cbn beta iota in He. - rewrite if_some, PkgSet.mem_spec in He; destruct He as [HR <-]. + rewrite if_some_iff, PkgSet.mem_spec in He; destruct He as [HR <-]. exists m, v, l; auto. - intros [m [v [l [Hl [HR ->]]]]]; exists ((m, v), l); split; [exact Hl | cbn beta iota]. @@ -943,23 +930,23 @@ Module Cargo (N V F G CfgS Src : UsualOrderedType) (PM : SemverMatch V). [exact Hl | reflexivity]. Qed. - Lemma mem_transReal : + Lemma mem_reduceReal : forall g R support FDefs Slots Links rc x, T.PkgSet.In x - (transReal g R support FDefs Slots Links rc) <-> - x = transRoot \/ T.PkgSet.In x (crateReal g R) \/ + (reduceReal g R support FDefs Slots Links rc) <-> + x = rootPkg \/ T.PkgSet.In x (crateReal g R) \/ T.PkgSet.In x (featReal g support) \/ T.PkgSet.In x (slotReal g R Slots rc) \/ T.PkgSet.In x (decReal g R FDefs Slots rc) \/ T.PkgSet.In x (linkReal g R Links). Proof. - intros; unfold transReal; rewrite !T.PkgSet.union_spec. + intros; unfold reduceReal; rewrite !T.PkgSet.union_spec. rewrite T.PkgSet.singleton_spec; reflexivity. Qed. Lemma real_shape : forall g R support FDefs Slots Links rc n w, - T.PkgSet.In (n, w) (transReal g R support FDefs Slots Links rc) <-> + T.PkgSet.In (n, w) (reduceReal g R support FDefs Slots Links rc) <-> match n with | NPlus.CRoot => w = VPlus.WUnit | NPlus.CCrate m gr => @@ -981,23 +968,10 @@ Module Cargo (N V F G CfgS Src : UsualOrderedType) (PM : SemverMatch V). end. Proof. intros g R support FDefs Slots Links rc n w. - rewrite mem_transReal, mem_crateReal, mem_featReal, mem_slotReal, - mem_decReal, mem_linkReal; unfold transRoot, SlotOwned, DecOwned. + rewrite mem_reduceReal, mem_crateReal, mem_featReal, mem_slotReal, + mem_decReal, mem_linkReal; unfold rootPkg, SlotOwned, DecOwned. split. - - intros [He | [He | [He | [He | [He | He]]]]]. - + injection He as -> ->; reflexivity. - + destruct He as [m [v [HR He]]]; injection He as -> ->. - exists v; auto. - + destruct He as [m [v [f [Hs He]]]]; injection He as -> ->. - exists v; auto. - + destruct He as [m [v [d [u [Hs [Hact [Hu He]]]]]]]. - injection He as -> ->; split; [exists v | exists u]; auto. - + destruct He as [m [v [f [e [a [feat [d [u - [Hf [Ee [Hs [<- [Hact [Hu He]]]]]]]]]]]]]]. - injection He as -> ->; split; [exists v, e | exists u]; - repeat split; assumption. - + destruct He as [m [v [l [Hl [HR He]]]]]; injection He as -> ->. - exists m, v; auto. + - intros [He | [He | [He | [He | [He | He]]]]]; mem_destruct; eauto 20. - destruct n as [| m gr | m f gr | m gr d | m gr f d feat | l]; cbn beta iota. + intros ->; left; reflexivity. @@ -1019,7 +993,7 @@ Module Cargo (N V F G CfgS Src : UsualOrderedType) (PM : SemverMatch V). Proof. intros; cbn [versions]; rewrite SOlv.mem_filterMap; split. - intros [[[m v] l'] [Hl He]]; cbn beta iota in He. - rewrite if_some, andb_true_iff, NEqb.eqb_true_iff, PkgSet.mem_spec + rewrite if_some_iff, andb_true_iff, NEqb.eqb_true_iff, PkgSet.mem_spec in He. destruct He as [[-> HR] <-]; exists m, v; auto. - intros [m [v [-> [Hl HR]]]]; exists ((m, v), l); split; @@ -1056,27 +1030,24 @@ Module Cargo (N V F G CfgS Src : UsualOrderedType) (PM : SemverMatch V). exists m, v; auto. Qed. - Lemma mem_transDeps : + Lemma mem_reduceDeps : forall g R support FDefs Slots Links dflt rc rootFeats (p : T.Pkg.t) (h : T.Dependees.t), T.DepRel.In (p, h) - (transDeps g R support FDefs Slots Links dflt rc + (reduceDeps g R support FDefs Slots Links dflt rc rootFeats) <-> T.PkgSet.In p - (transReal g R support FDefs Slots Links rc) /\ + (reduceReal g R support FDefs Slots Links rc) /\ T.DependeesSet.In h (dependees g R support FDefs Slots Links dflt rc rootFeats p). Proof. intros g R support FDefs Slots Links dflt rc rootFeats p - [n vs]; unfold transDeps; rewrite SOpe.mem_unionMap. + [n vs]; unfold reduceDeps; rewrite SOpe.mem_unionMap. split. - intros [q [Hq Hy]]; cbn beta iota in Hy. unfold depEdges in Hy; apply SOhe.mem_map in Hy. - destruct Hy as [e [He Hy]]. - injection Hy as -> He2. - rewrite <- He2 in He. - split; assumption. + mem_destruct; split; assumption. - intros [Hp Hh]. exists p; split; [exact Hp | cbn beta iota]. unfold depEdges; apply SOhe.mem_map. @@ -1108,12 +1079,12 @@ Module Cargo (N V F G CfgS Src : UsualOrderedType) (PM : SemverMatch V). forall g R support FDefs Slots Links dflt rn rv rootFeats h, T.DependeesSet.In h (dependees g R support FDefs Slots Links dflt (rn, rv) - rootFeats transRoot) <-> + rootFeats rootPkg) <-> h = (NPlus.CCrate rn (g rv), T.VSet.singleton (VPlus.WOrig rv)) \/ exists f, FSet.In f rootFeats /\ h = (NPlus.CFeatP rn f (g rv), T.VSet.singleton (VPlus.WOrig rv)). Proof. - intros; cbn [dependees transRoot]. + intros; cbn [dependees rootPkg]. rewrite T.DependeesSet.add_spec, SOfsh.mem_map. split; (intros [Hx | [f [Hf Hx]]]; [left; exact Hx @@ -1149,7 +1120,7 @@ Module Cargo (N V F G CfgS Src : UsualOrderedType) (PM : SemverMatch V). SOlh.mem_filterMap. split. - intros [[[q d] [Hs He]] | [[q l] [Hl He]]]; cbn beta iota in He; - rewrite if_some in He; (split; [reflexivity | split; [exact Em |]]). + rewrite if_some_iff in He; (split; [reflexivity | split; [exact Em |]]). + rewrite !andb_true_iff, PkgEqb.eqb_true_iff, negb_true_iff in He. destruct He as [[-> [Ha Ho]] <-]; left; exists d; auto. + rewrite PkgEqb.eqb_true_iff in He; destruct He as [-> <-]. @@ -1319,7 +1290,7 @@ Module Cargo (N V F G CfgS Src : UsualOrderedType) (PM : SemverMatch V). (dependees g R support FDefs Slots Links dflt rc rootFeats p) -> T.PkgSet.In p - (transReal g R support FDefs Slots Links rc). + (reduceReal g R support FDefs Slots Links rc). Proof. intros g R support FDefs Slots Links dflt rc rootFeats [n w] h Hh; apply real_shape. @@ -1375,7 +1346,7 @@ Module Cargo (N V F G CfgS Src : UsualOrderedType) (PM : SemverMatch V). intros S m v f; unfold featsAt; rewrite SOtf.mem_filterMap; split. - intros [[n w] [Hin He]]; cbn beta iota in He. destruct n; try discriminate; destruct w; try discriminate. - rewrite if_some, PkgEqb.eqb_true_iff in He. + rewrite if_some_iff, PkgEqb.eqb_true_iff in He. destruct He as [[= -> ->] ->]; exists gr; exact Hin. - intros [gr Hin]; exists (NPlus.CFeatP m f gr, VPlus.WOrig v); split; [exact Hin | cbn beta iota]. @@ -1413,7 +1384,7 @@ Module Cargo (N V F G CfgS Src : UsualOrderedType) (PM : SemverMatch V). intros S m gr u; unfold targets; rewrite SOtv2.mem_filterMap; split. - intros [[n w] [Hin He]]; cbn beta iota in He. destruct n; try discriminate; destruct w; try discriminate. - rewrite if_some, andb_true_iff, NEqb.eqb_true_iff, GEqb.eqb_true_iff + rewrite if_some_iff, andb_true_iff, NEqb.eqb_true_iff, GEqb.eqb_true_iff in He. destruct He as [[-> ->] ->]; exact Hin. - intro Hin; exists (NPlus.CCrate m gr, VPlus.WOrig u); split; @@ -1481,701 +1452,14 @@ Module Cargo (N V F G CfgS Src : UsualOrderedType) (PM : SemverMatch V). [apply mem_targets; exact Hcr | rewrite Ha; reflexivity]. Qed. - Module Lookup. - Theorem versions_lookupRoot : - forall g R support FDefs Slots Links rc w, - T.PkgSet.In (NPlus.CRoot, w) - (transReal g R support FDefs Slots Links rc) <-> - T.VSet.In w - (versions g R support FDefs Slots Links rc NPlus.CRoot). - Proof. - intros; rewrite real_shape; cbn [versions]. - rewrite T.VSet.singleton_spec; reflexivity. - Qed. - - Theorem versions_lookupCrate : - forall g R support FDefs Slots Links rc m gr w, - T.PkgSet.In (NPlus.CCrate m gr, w) - (transReal g R support FDefs Slots Links rc) <-> - T.VSet.In w - (versions g R support FDefs Slots Links rc - (NPlus.CCrate m gr)). - Proof. - intros; rewrite real_shape; cbn [versions]. - rewrite SOpv2.mem_filterMap; split. - - intros [v [-> [HR ->]]]; exists (m, v); split; [exact HR |]. - cbn beta iota; rewrite NEqb.eqb_refl, GEqb.eqb_refl; reflexivity. - - intros [[n' v] [HR He]]; cbn beta iota in He. - rewrite if_some, andb_true_iff, NEqb.eqb_true_iff, GEqb.eqb_true_iff - in He. - destruct He as [[-> <-] <-]; exists v; auto. - Qed. - - Theorem versions_lookupFeatP : - forall g R support FDefs Slots Links rc m f gr w, - T.PkgSet.In (NPlus.CFeatP m f gr, w) - (transReal g R support FDefs Slots Links rc) <-> - T.VSet.In w - (versions g R support FDefs Slots Links rc - (NPlus.CFeatP m f gr)). - Proof. - intros; rewrite real_shape; cbn [versions]. - rewrite SOspv.mem_filterMap; split. - - intros [v [-> [Hs ->]]]; exists ((m, v), f); split; [exact Hs |]. - cbn beta iota; rewrite NEqb.eqb_refl, FEqb.eqb_refl, GEqb.eqb_refl; - reflexivity. - - intros [[[n' v] f'] [Hs He]]; cbn beta iota in He. - rewrite if_some, !andb_true_iff, NEqb.eqb_true_iff, FEqb.eqb_true_iff, - GEqb.eqb_true_iff in He. - destruct He as [[[-> ->] <-] <-]; exists v; auto. - Qed. - - Theorem versions_lookupSlot : - forall g R support FDefs Slots Links rc m gr d w, - T.PkgSet.In (NPlus.CSlot m gr d, w) - (transReal g R support FDefs Slots Links rc) <-> - T.VSet.In w - (versions g R support FDefs Slots Links rc - (NPlus.CSlot m gr d)). - Proof. - intros; rewrite real_shape; cbn [versions]. - rewrite SOvv.in_if_empty, slotOwnedb_iff, mem_gransOf; reflexivity. - Qed. - - Theorem versions_lookupDecision : - forall g R support FDefs Slots Links rc m gr f d feat w, - T.PkgSet.In (NPlus.CDec m gr f d feat, w) - (transReal g R support FDefs Slots Links rc) <-> - T.VSet.In w - (versions g R support FDefs Slots Links rc - (NPlus.CDec m gr f d feat)). - Proof. - intros; rewrite real_shape; cbn [versions]. - rewrite SOvv.in_if_empty, decOwnedb_iff, mem_gransOf; reflexivity. - Qed. - - Theorem versions_lookupLink : - forall g R support FDefs Slots Links rc l w, - T.PkgSet.In (NPlus.CLink l, w) - (transReal g R support FDefs Slots Links rc) <-> - T.VSet.In w - (versions g R support FDefs Slots Links rc - (NPlus.CLink l)). - Proof. intros; rewrite real_shape, mem_versions_link; reflexivity. Qed. - - Theorem dependees_lookup : - forall g R support FDefs Slots Links dflt rc rootFeats p, - dependees g R support FDefs Slots Links dflt rc - rootFeats p = - T.dependees - (transDeps g R support FDefs Slots Links dflt rc - rootFeats) p. - Proof. - intros; apply T.DependeesSet.ext; intro h. - rewrite T.mem_dependees, mem_transDeps; split. - - intro Hh; split; [| exact Hh]; eapply dep_real; exact Hh. - - intros [_ Hh]; exact Hh. - Qed. - - Theorem dependees_lookupRoot : - forall g R support FDefs Slots Links dflt rc rootFeats, - dependees g R support FDefs Slots Links dflt rc - rootFeats transRoot = - T.dependees - (transDeps g R support FDefs Slots Links dflt rc - rootFeats) transRoot. - Proof. intros; apply dependees_lookup. Qed. - - Theorem dependees_lookupCrate : - forall g R support FDefs Slots Links dflt rc rootFeats - m gr v, - dependees g R support FDefs Slots Links dflt rc - rootFeats (NPlus.CCrate m gr, VPlus.WOrig v) = - T.dependees - (transDeps g R support FDefs Slots Links dflt rc - rootFeats) (NPlus.CCrate m gr, VPlus.WOrig v). - Proof. intros; apply dependees_lookup. Qed. - - Theorem dependees_lookupFeatP : - forall g R support FDefs Slots Links dflt rc rootFeats - m f gr v, - dependees g R support FDefs Slots Links dflt rc - rootFeats (NPlus.CFeatP m f gr, VPlus.WOrig v) = - T.dependees - (transDeps g R support FDefs Slots Links dflt rc - rootFeats) (NPlus.CFeatP m f gr, VPlus.WOrig v). - Proof. intros; apply dependees_lookup. Qed. - - Theorem dependees_lookupSlot : - forall g R support FDefs Slots Links dflt rc rootFeats - m gr0 d gr, - dependees g R support FDefs Slots Links dflt rc - rootFeats (NPlus.CSlot m gr0 d, VPlus.WClass gr) = - T.dependees - (transDeps g R support FDefs Slots Links dflt rc - rootFeats) (NPlus.CSlot m gr0 d, VPlus.WClass gr). - Proof. intros; apply dependees_lookup. Qed. - - Theorem dependees_lookupDecision : - forall g R support FDefs Slots Links dflt rc rootFeats - m gr0 f d feat gr, - dependees g R support FDefs Slots Links dflt rc - rootFeats (NPlus.CDec m gr0 f d feat, VPlus.WClass gr) = - T.dependees - (transDeps g R support FDefs Slots Links dflt rc - rootFeats) (NPlus.CDec m gr0 f d feat, VPlus.WClass gr). - Proof. intros; apply dependees_lookup. Qed. - - Theorem dependees_lookupInert : - forall g R support FDefs Slots Links dflt rc rootFeats p, - Inert p -> - dependees g R support FDefs Slots Links dflt rc - rootFeats p = - T.dependees - (transDeps g R support FDefs Slots Links dflt rc - rootFeats) p. - Proof. intros; apply dependees_lookup. Qed. - - Module NSet := FSetUOT N. - Module PkgPre := PreimageOfKeys N Pkg NSet PkgSet. - Module SupportPre := PreimageOfKeys N PkgF NSet SupportSet. - Module FDefPre := Preimage FDefElt FDefRel. - Module SlotFibred := FibredRel Pkg SlotData SlotElt SlotRel. - Module LinkFibred := FibredRel Pkg N LinkElt LinkRel. - Module SupportFibred := FibredRel Pkg F PkgF SupportSet. - Module SOsn := SetOps SlotElt N SlotRel NSet. - - Definition realPreimage (R : PkgSet.t) (ns : NSet.t) : PkgSet.t := - PkgPre.ofKeys fst ns R. - - Definition supportPreimage (support : SupportSet.t) (ns : NSet.t) - : SupportSet.t := - SupportPre.ofKeys (fun x => fst (fst x)) ns support. - - Definition fdefFibre (FDefs : FDefRel.t) (p : Pkg.t) : FDefRel.t := - FDefPre.preimage (fun x => fst (fst x)) (fun q => PkgEqb.eqb q p) FDefs. - - Definition reads (Slots : SlotRel.t) (p : Pkg.t) : NSet.t := - NSet.add (fst p) - (SOsn.map (fun x => sTarget (snd x)) (SlotFibred.tailFibre Slots p)). - - Definition claimants (R : PkgSet.t) (Links : LinkRel.t) (l : N.t) - : PkgSet.t := - PkgSet.filter (fun q => LinkRel.mem (q, l) Links) R. - - Lemma mem_realPreimage : forall R ns q, - PkgSet.In q (realPreimage R ns) <-> - PkgSet.In q R /\ NSet.In (fst q) ns. - Proof. intros; unfold realPreimage; apply PkgPre.mem_ofKeys. Qed. - - Lemma evalReq_realPreimage : forall R ns m rg, - NSet.In m ns -> - evalReq (realPreimage R ns) m rg = evalReq R m rg. - Proof. - intros R ns m rg Hm; apply VSet.ext; intro u. - rewrite !mem_evalReq, mem_realPreimage; cbn [fst]; tauto. - Qed. - - Lemma mem_supportPreimage : forall support ns m v f, - SupportSet.In ((m, v), f) (supportPreimage support ns) <-> - SupportSet.In ((m, v), f) support /\ NSet.In m ns. - Proof. - intros; unfold supportPreimage; rewrite SupportPre.mem_ofKeys; - cbn [fst]; reflexivity. - Qed. - - Lemma mem_fdefFibre : forall FDefs p q f e, - FDefRel.In ((q, f), e) (fdefFibre FDefs p) <-> - FDefRel.In ((q, f), e) FDefs /\ q = p. - Proof. - intros; unfold fdefFibre; rewrite FDefPre.mem_preimage; cbn [fst]. - rewrite PkgEqb.eqb_true_iff; reflexivity. - Qed. - - Lemma mem_claimants : forall R Links l q, - PkgSet.In q (claimants R Links l) <-> - PkgSet.In q R /\ LinkRel.In (q, l) Links. - Proof. - intros; unfold claimants; rewrite PkgSet.filter_spec', LinkRel.mem_spec; - reflexivity. - Qed. - - Lemma reads_own : forall Slots p, NSet.In (fst p) (reads Slots p). - Proof. intros; unfold reads; apply NSet.add_spec; left; reflexivity. Qed. - - Lemma reads_target : forall Slots p d, - SlotRel.In (p, d) Slots -> NSet.In (sTarget d) (reads Slots p). - Proof. - intros Slots p d Hs; unfold reads; apply NSet.add_spec; right. - apply SOsn.mem_map; exists (p, d); split; [| reflexivity]. - apply SlotFibred.mem_tailFibre; split; [exact Hs | reflexivity]. - Qed. - - Lemma in_realPreimage_own : forall R Slots p, - PkgSet.In p R <-> PkgSet.In p (realPreimage R (reads Slots p)). - Proof. - intros; rewrite mem_realPreimage; split; - [intro H; split; [exact H | apply reads_own] | intros [H _]; exact H]. - Qed. - - Lemma evalReq_reads : forall R Slots p d, - SlotRel.In (p, d) Slots -> - evalReq R (sTarget d) (sReq d) = - evalReq (realPreimage R (reads Slots p)) (sTarget d) (sReq d). - Proof. - intros R Slots p d Hs; symmetry; apply evalReq_realPreimage. - apply reads_target; exact Hs. - Qed. - - Lemma in_slotFibre : forall Slots p d, - SlotRel.In (p, d) Slots <-> - SlotRel.In (p, d) (SlotFibred.tailFibre Slots p). - Proof. - intros; rewrite SlotFibred.mem_tailFibre; split; - [intro H; split; [exact H | reflexivity] | intros [H _]; exact H]. - Qed. - - Lemma in_linkFibre : forall Links p l, - LinkRel.In (p, l) Links <-> - LinkRel.In (p, l) (LinkFibred.tailFibre Links p). - Proof. - intros; rewrite LinkFibred.mem_tailFibre; split; - [intro H; split; [exact H | reflexivity] | intros [H _]; exact H]. - Qed. - - Lemma in_supportFibre : forall support p f, - SupportSet.In (p, f) support <-> - SupportSet.In (p, f) (SupportFibred.tailFibre support p). - Proof. - intros; rewrite SupportFibred.mem_tailFibre; split; - [intro H; split; [exact H | reflexivity] | intros [H _]; exact H]. - Qed. - - Lemma in_fdefFibre : forall FDefs p f e, - FDefRel.In ((p, f), e) FDefs <-> - FDefRel.In ((p, f), e) (fdefFibre FDefs p). - Proof. - intros; rewrite mem_fdefFibre; split; - [intro H; split; [exact H | reflexivity] | intros [H _]; exact H]. - Qed. - - Theorem versions_lookupRootSub : - forall g R support FDefs Slots Links rc, - versions g R support FDefs Slots Links rc NPlus.CRoot = - versions g PkgSet.empty SupportSet.empty FDefRel.empty SlotRel.empty - LinkRel.empty rc NPlus.CRoot. - Proof. reflexivity. Qed. - - Theorem versions_lookupCrateSub : - forall g R support FDefs Slots Links rc m gr, - versions g R support FDefs Slots Links rc (NPlus.CCrate m gr) = - versions g (realPreimage R (NSet.singleton m)) SupportSet.empty - FDefRel.empty SlotRel.empty LinkRel.empty rc (NPlus.CCrate m gr). - Proof. - intros; cbn [versions]; apply T.VSet.ext; intro w; symmetry. - apply SOpv2.filterMap_restrict; [apply PkgPre.ofKeys_subset |]. - intros [n' v] HR He; cbn beta iota in He. - rewrite if_some, andb_true_iff, NEqb.eqb_true_iff in He. - destruct He as [[-> _] _]; apply mem_realPreimage; split; - [exact HR | apply NSet.singleton_spec; reflexivity]. - Qed. - - Theorem versions_lookupFeatPSub : - forall g R support FDefs Slots Links rc m f gr, - versions g R support FDefs Slots Links rc (NPlus.CFeatP m f gr) = - versions g (realPreimage R (NSet.singleton m)) - (supportPreimage support (NSet.singleton m)) - FDefRel.empty SlotRel.empty LinkRel.empty rc (NPlus.CFeatP m f gr). - Proof. - intros; cbn [versions]; apply T.VSet.ext; intro w; symmetry. - apply SOspv.filterMap_restrict; [apply SupportPre.ofKeys_subset |]. - intros [[n' v] f'] Hs He; cbn beta iota in He. - rewrite if_some, !andb_true_iff, NEqb.eqb_true_iff in He. - destruct He as [[[-> _] _] _]; apply mem_supportPreimage; split; - [exact Hs | apply NSet.singleton_spec; reflexivity]. - Qed. - - Lemma slotOwnedb_witness : - forall g Slots rc m gr d u, - SlotRel.In ((m, u), d) Slots -> g u = gr -> - slotActive rc (m, u) d = true -> - slotOwnedb g Slots rc m gr d = true /\ - slotOwnedb g (SlotFibred.tailFibre Slots (m, u)) rc m gr d = true. - Proof. - intros g Slots rc m gr d u Hs Hg Hact; split; apply slotOwnedb_iff; - exists u; (split; [exact Hg | split; [| exact Hact]]); - [exact Hs | exact (proj1 (in_slotFibre Slots (m, u) d) Hs)]. - Qed. - - Lemma decOwnedb_witness : - forall g FDefs Slots rc m gr f d feat u e, - FDefRel.In (((m, u), f), e) FDefs -> - entryFeatD e = Some (sAlias d, feat) -> - SlotRel.In ((m, u), d) Slots -> g u = gr -> - slotActive rc (m, u) d = true -> - decOwnedb g FDefs Slots rc m gr f d feat = true /\ - decOwnedb g (fdefFibre FDefs (m, u)) - (SlotFibred.tailFibre Slots (m, u)) rc m gr f d feat = true. - Proof. - intros g FDefs Slots rc m gr f d feat u e Hf Ee Hs Hg Hact; - split; apply decOwnedb_iff; exists u, e; - (split; [exact Hg |]). - - repeat split; assumption. - - split; [exact (proj1 (in_fdefFibre FDefs (m, u) f e) Hf) |]. - split; [exact Ee |]. - split; [exact (proj1 (in_slotFibre Slots (m, u) d) Hs) | exact Hact]. - Qed. - - Theorem versions_lookupSlotSub : - forall g R support FDefs Slots Links rc m gr d u, - SlotRel.In ((m, u), d) Slots -> g u = gr -> - slotActive rc (m, u) d = true -> - versions g R support FDefs Slots Links rc (NPlus.CSlot m gr d) = - versions g (realPreimage R (NSet.singleton (sTarget d))) - SupportSet.empty FDefRel.empty (SlotFibred.tailFibre Slots (m, u)) - LinkRel.empty rc (NPlus.CSlot m gr d). - Proof. - intros g R support FDefs Slots Links rc m gr d u Hs Hg Hact. - destruct (slotOwnedb_witness g Slots rc m gr d u Hs Hg Hact) - as [E1 E2]. - cbn [versions]; rewrite E1, E2. - rewrite evalReq_realPreimage; - [reflexivity | apply NSet.singleton_spec; reflexivity]. - Qed. - - Theorem versions_lookupDecisionSub : - forall g R support FDefs Slots Links rc m gr f d feat u e, - FDefRel.In (((m, u), f), e) FDefs -> - entryFeatD e = Some (sAlias d, feat) -> - SlotRel.In ((m, u), d) Slots -> g u = gr -> - slotActive rc (m, u) d = true -> - versions g R support FDefs Slots Links rc - (NPlus.CDec m gr f d feat) = - versions g (realPreimage R (NSet.singleton (sTarget d))) - SupportSet.empty (fdefFibre FDefs (m, u)) - (SlotFibred.tailFibre Slots (m, u)) - LinkRel.empty rc (NPlus.CDec m gr f d feat). - Proof. - intros g R support FDefs Slots Links rc m gr f d feat u e - Hf Ee Hs Hg Hact. - destruct (decOwnedb_witness g FDefs Slots rc m gr f d feat u e - Hf Ee Hs Hg Hact) as [E1 E2]. - cbn [versions]; rewrite E1, E2. - rewrite evalReq_realPreimage; - [reflexivity | apply NSet.singleton_spec; reflexivity]. - Qed. - - Theorem slot_declines : - forall g R support FDefs Slots Links dflt rc rootFeats m gr d, - ~ SlotOwned g Slots rc m gr d -> - versions g R support FDefs Slots Links rc (NPlus.CSlot m gr d) = - T.VSet.empty /\ - forall gr', dependees g R support FDefs Slots Links dflt rc rootFeats - (NPlus.CSlot m gr d, VPlus.WClass gr') = - T.DependeesSet.empty. - Proof. - intros g R support FDefs Slots Links dflt rc rootFeats m gr d Hn. - assert (E : slotOwnedb g Slots rc m gr d = false) - by (apply Bool.not_true_iff_false; rewrite slotOwnedb_iff; exact Hn). - split; [cbn [versions]; rewrite E; reflexivity |]. - intro gr'; cbn [dependees]; rewrite E; reflexivity. - Qed. - - Theorem decision_declines : - forall g R support FDefs Slots Links dflt rc rootFeats m gr f d feat, - ~ DecOwned g FDefs Slots rc m gr f d feat -> - versions g R support FDefs Slots Links rc (NPlus.CDec m gr f d feat) = - T.VSet.empty /\ - forall gr', dependees g R support FDefs Slots Links dflt rc rootFeats - (NPlus.CDec m gr f d feat, VPlus.WClass gr') = - T.DependeesSet.empty. - Proof. - intros g R support FDefs Slots Links dflt rc rootFeats m gr f d feat Hn. - assert (E : decOwnedb g FDefs Slots rc m gr f d feat = false) - by (apply Bool.not_true_iff_false; rewrite decOwnedb_iff; exact Hn). - split; [cbn [versions]; rewrite E; reflexivity |]. - intro gr'; cbn [dependees]; rewrite E; reflexivity. - Qed. - - Lemma crateReal_claimants : forall g R Links l, - crateReal g (claimants R Links l) = - ClsT.Reduction.Lookup.inClass (crateReal g R) (linkRel g Links) - (NPlus.CLink l). - Proof. - intros; apply T.PkgSet.ext; intro x. - rewrite ClsT.Reduction.Lookup.mem_inClass, !mem_crateReal. - split. - - intros [m [v [Hc ->]]]; apply mem_claimants in Hc. - destruct Hc as [HR Hl]; split. - + exists m, v; split; [exact HR | reflexivity]. - + apply mem_linkRel; exists m, v, l; repeat split; exact Hl. - - intros [[m [v [HR ->]]] Hc]. - apply mem_linkRel in Hc; destruct Hc as [m' [v' [l' [Hl [E Ek]]]]]. - injection E as E1 _ E3; subst m' v'; injection Ek as <-. - exists m, v; split; [apply mem_claimants; split; assumption - | reflexivity]. - Qed. - - Lemma linkRel_headFibre : forall g Links l, - linkRel g (LinkFibred.headFibre Links l) = - ClsT.Reduction.Lookup.classRelAt (linkRel g Links) (NPlus.CLink l). - Proof. - intros; apply ClsT.InClassRel.ext; intros [q k]. - rewrite ClsT.Reduction.Lookup.mem_classRelAt, !mem_linkRel. - split. - - intros [m [v [l' [Hl [-> ->]]]]]. - apply LinkFibred.mem_headFibre in Hl; destruct Hl as [Hl ->]. - split; [exists m, v, l; repeat split; exact Hl | reflexivity]. - - intros [[m [v [l' [Hl [-> ->]]]]] Ek]; injection Ek as ->. - exists m, v, l; repeat split. - apply LinkFibred.mem_headFibre; split; [exact Hl | reflexivity]. - Qed. - - (* The one lookup whose sub-instance is a preimage: the claimants of l - are named by no declaration of any one of them, so a driver that - reads its repository lazily holds only the claimants loaded so far - and must answer this afresh at every ask rather than memoise it. *) - Theorem versions_lookupLinkSub : - forall g R support FDefs Slots Links rc l, - versions g R support FDefs Slots Links rc (NPlus.CLink l) = - versions g (claimants R Links l) SupportSet.empty FDefRel.empty - SlotRel.empty (LinkFibred.headFibre Links l) rc (NPlus.CLink l). - Proof. - intros; apply T.VSet.ext; intro w. - rewrite !versions_link_reduceReal, crateReal_claimants, - linkRel_headFibre, <- ClsT.Reduction.Lookup.versions_lookupClass. - reflexivity. - Qed. - - (* The dependee lookups, stated first as agreement between any two - instances that coincide on what a shape reads -- the owner's fibres - and the repository at the owner's slot targets -- so that the - per-name lemmas the driver uses and the owner-uniform - dependees_lookupSub follow from one proof each. *) - Lemma dep_crate_mono : - forall g R R' support support' FDefs FDefs' Slots Slots' Links Links' - dflt rc rootFeats rootFeats' m gr v, - (forall d, SlotRel.In ((m, v), d) Slots -> - SlotRel.In ((m, v), d) Slots') -> - (forall d, SlotRel.In ((m, v), d) Slots -> - evalReq R (sTarget d) (sReq d) = evalReq R' (sTarget d) (sReq d)) -> - (PkgSet.In (m, v) R -> PkgSet.In (m, v) R') -> - (forall l, LinkRel.In ((m, v), l) Links -> LinkRel.In ((m, v), l) Links') -> - forall h, - T.DependeesSet.In h - (dependees g R support FDefs Slots Links dflt rc rootFeats - (NPlus.CCrate m gr, VPlus.WOrig v)) -> - T.DependeesSet.In h - (dependees g R' support' FDefs' Slots' Links' dflt rc rootFeats' - (NPlus.CCrate m gr, VPlus.WOrig v)). - Proof. - intros * HS Hev HR HL h Hh. - apply mem_dep_crate in Hh; apply mem_dep_crate. - destruct Hh as [Hg [Hm Hh]]; split; [exact Hg | split; [exact (HR Hm) |]]. - destruct Hh as [[d [Hd [Ha [Ho ->]]]] | [l [Hl ->]]]. - - left; exists d; rewrite <- (Hev d Hd). - split; [exact (HS d Hd) | split; [exact Ha | split; [exact Ho | reflexivity]]]. - - right; exists l; split; [exact (HL l Hl) | reflexivity]. - Qed. - - Lemma dep_featP_mono : - forall g R R' support support' FDefs FDefs' Slots Slots' Links Links' - dflt rc rootFeats rootFeats' m f gr v, - (forall d, SlotRel.In ((m, v), d) Slots -> - SlotRel.In ((m, v), d) Slots') -> - (forall d, SlotRel.In ((m, v), d) Slots -> - evalReq R (sTarget d) (sReq d) = evalReq R' (sTarget d) (sReq d)) -> - (SupportSet.In ((m, v), f) support -> SupportSet.In ((m, v), f) support') -> - (forall e, FDefRel.In (((m, v), f), e) FDefs -> - FDefRel.In (((m, v), f), e) FDefs') -> - forall h, - T.DependeesSet.In h - (dependees g R support FDefs Slots Links dflt rc rootFeats - (NPlus.CFeatP m f gr, VPlus.WOrig v)) -> - T.DependeesSet.In h - (dependees g R' support' FDefs' Slots' Links' dflt rc rootFeats' - (NPlus.CFeatP m f gr, VPlus.WOrig v)). - Proof. - intros * HS Hev Hsp HF h Hh. - apply mem_dep_featP in Hh; apply mem_dep_featP. - destruct Hh as [Hg [Hs Hh]]; split; [exact Hg | split; [exact (Hsp Hs) |]]. - destruct Hh as [Hh | [e0 [Hfd Hc]]]; [left; exact Hh | right]. - exists e0; split; [exact (HF e0 Hfd) |]. - destruct Hc as [[f' [He ->]] | [[a [d [Ha [Hd [Hal [Hact ->]]]]]] - | [a [feat [d [Ha [Hd [Hal [Hact ->]]]]]]]]]. - - left; exists f'; split; [exact He | reflexivity]. - - right; left; exists a, d; rewrite <- (Hev d Hd). - split; [exact Ha | split; [exact (HS d Hd) | - split; [exact Hal | split; [exact Hact | reflexivity]]]]. - - right; right; exists a, feat, d; rewrite <- (Hev d Hd). - split; [exact Ha | split; [exact (HS d Hd) | - split; [exact Hal | split; [exact Hact | reflexivity]]]]. - Qed. - - Lemma dep_crate_agree : - forall g R R' support support' FDefs FDefs' Slots Slots' Links Links' - dflt rc rootFeats rootFeats' m gr v, - (forall d, SlotRel.In ((m, v), d) Slots <-> - SlotRel.In ((m, v), d) Slots') -> - (forall d, SlotRel.In ((m, v), d) Slots -> - evalReq R (sTarget d) (sReq d) = evalReq R' (sTarget d) (sReq d)) -> - (PkgSet.In (m, v) R <-> PkgSet.In (m, v) R') -> - (forall l, LinkRel.In ((m, v), l) Links <-> LinkRel.In ((m, v), l) Links') -> - dependees g R support FDefs Slots Links dflt rc rootFeats - (NPlus.CCrate m gr, VPlus.WOrig v) = - dependees g R' support' FDefs' Slots' Links' dflt rc rootFeats' - (NPlus.CCrate m gr, VPlus.WOrig v). - Proof. - intros * HS Hev HR HL; apply T.DependeesSet.ext; intro h; split. - - apply dep_crate_mono; - [intros d Hd; apply HS; exact Hd | exact Hev - | apply HR | intros l Hl; apply HL; exact Hl]. - - apply dep_crate_mono; - [intros d Hd; apply HS; exact Hd - | intros d Hd; symmetry; apply Hev; apply HS; exact Hd - | apply HR | intros l Hl; apply HL; exact Hl]. - Qed. - - Lemma dep_featP_agree : - forall g R R' support support' FDefs FDefs' Slots Slots' Links Links' - dflt rc rootFeats rootFeats' m f gr v, - (forall d, SlotRel.In ((m, v), d) Slots <-> - SlotRel.In ((m, v), d) Slots') -> - (forall d, SlotRel.In ((m, v), d) Slots -> - evalReq R (sTarget d) (sReq d) = evalReq R' (sTarget d) (sReq d)) -> - (SupportSet.In ((m, v), f) support <-> SupportSet.In ((m, v), f) support') -> - (forall e, FDefRel.In (((m, v), f), e) FDefs <-> - FDefRel.In (((m, v), f), e) FDefs') -> - dependees g R support FDefs Slots Links dflt rc rootFeats - (NPlus.CFeatP m f gr, VPlus.WOrig v) = - dependees g R' support' FDefs' Slots' Links' dflt rc rootFeats' - (NPlus.CFeatP m f gr, VPlus.WOrig v). - Proof. - intros * HS Hev Hsp HF; apply T.DependeesSet.ext; intro h; split. - - apply dep_featP_mono; - [intros d Hd; apply HS; exact Hd | exact Hev - | apply Hsp | intros e He; apply HF; exact He]. - - apply dep_featP_mono; - [intros d Hd; apply HS; exact Hd - | intros d Hd; symmetry; apply Hev; apply HS; exact Hd - | apply Hsp | intros e He; apply HF; exact He]. - Qed. - - Theorem dependees_lookupRootSub : - forall g R support FDefs Slots Links dflt rc rootFeats, - dependees g R support FDefs Slots Links dflt rc rootFeats transRoot = - dependees g PkgSet.empty SupportSet.empty FDefRel.empty SlotRel.empty - LinkRel.empty dflt rc rootFeats transRoot. - Proof. reflexivity. Qed. - - Theorem dependees_lookupCrateSub : - forall g R support FDefs Slots Links dflt rc rootFeats m gr v, - dependees g R support FDefs Slots Links dflt rc rootFeats - (NPlus.CCrate m gr, VPlus.WOrig v) = - dependees g (realPreimage R (reads Slots (m, v))) SupportSet.empty - FDefRel.empty (SlotFibred.tailFibre Slots (m, v)) - (LinkFibred.tailFibre Links (m, v)) dflt rc rootFeats - (NPlus.CCrate m gr, VPlus.WOrig v). - Proof. - intros; apply dep_crate_agree; - [intro d; apply in_slotFibre | apply evalReq_reads - | apply in_realPreimage_own | intro l; apply in_linkFibre]. - Qed. - - Theorem dependees_lookupFeatPSub : - forall g R support FDefs Slots Links dflt rc rootFeats m f gr v, - dependees g R support FDefs Slots Links dflt rc rootFeats - (NPlus.CFeatP m f gr, VPlus.WOrig v) = - dependees g (realPreimage R (reads Slots (m, v))) - (SupportFibred.tailFibre support (m, v)) (fdefFibre FDefs (m, v)) - (SlotFibred.tailFibre Slots (m, v)) LinkRel.empty dflt rc rootFeats - (NPlus.CFeatP m f gr, VPlus.WOrig v). - Proof. - intros; apply dep_featP_agree; - [intro d; apply in_slotFibre | apply evalReq_reads - | apply in_supportFibre | intro e; apply in_fdefFibre]. - Qed. - - Theorem dependees_lookupSlotSub : - forall g R support FDefs Slots Links dflt rc rootFeats m gr0 d gr u, - SlotRel.In ((m, u), d) Slots -> g u = gr0 -> - slotActive rc (m, u) d = true -> - dependees g R support FDefs Slots Links dflt rc rootFeats - (NPlus.CSlot m gr0 d, VPlus.WClass gr) = - dependees g (realPreimage R (NSet.singleton (sTarget d))) - SupportSet.empty FDefRel.empty (SlotFibred.tailFibre Slots (m, u)) - LinkRel.empty dflt rc rootFeats (NPlus.CSlot m gr0 d, VPlus.WClass gr). - Proof. - intros g R support FDefs Slots Links dflt rc rootFeats m gr0 d gr u - Hs Hg Hact. - destruct (slotOwnedb_witness g Slots rc m gr0 d u Hs Hg Hact) - as [E1 E2]. - cbn [dependees]; rewrite E1, E2. - rewrite evalReq_realPreimage; - [reflexivity | apply NSet.singleton_spec; reflexivity]. - Qed. - - Theorem dependees_lookupDecisionSub : - forall g R support FDefs Slots Links dflt rc rootFeats - m gr0 f d feat gr u e, - FDefRel.In (((m, u), f), e) FDefs -> - entryFeatD e = Some (sAlias d, feat) -> - SlotRel.In ((m, u), d) Slots -> g u = gr0 -> - slotActive rc (m, u) d = true -> - dependees g R support FDefs Slots Links dflt rc rootFeats - (NPlus.CDec m gr0 f d feat, VPlus.WClass gr) = - dependees g (realPreimage R (NSet.singleton (sTarget d))) - SupportSet.empty (fdefFibre FDefs (m, u)) - (SlotFibred.tailFibre Slots (m, u)) - LinkRel.empty dflt rc rootFeats - (NPlus.CDec m gr0 f d feat, VPlus.WClass gr). - Proof. - intros g R support FDefs Slots Links dflt rc rootFeats m gr0 f d feat gr - u e Hf Ee Hs Hg Hact. - destruct (decOwnedb_witness g FDefs Slots rc m gr0 f d feat u e - Hf Ee Hs Hg Hact) as [E1 E2]. - cbn [dependees]; rewrite E1, E2. - rewrite evalReq_realPreimage; - [reflexivity | apply NSet.singleton_spec; reflexivity]. - Qed. - - Definition owner (p : T.Pkg.t) : option Pkg.t := - match p with - | (NPlus.CCrate m _, VPlus.WOrig v) => Some (m, v) - | (NPlus.CFeatP m _ _, VPlus.WOrig v) => Some (m, v) - | _ => None - end. - - Theorem dependees_lookupSub : - forall g R support FDefs Slots Links dflt rc rootFeats p q, - owner p = Some q -> - dependees g R support FDefs Slots Links dflt rc rootFeats p = - dependees g (realPreimage R (reads Slots q)) - (SupportFibred.tailFibre support q) (fdefFibre FDefs q) - (SlotFibred.tailFibre Slots q) (LinkFibred.tailFibre Links q) - dflt rc rootFeats p. - Proof. - intros g R support FDefs Slots Links dflt rc rootFeats [n w] q Ho. - destruct n as [ | m gr | m f gr | m gr0 d | m gr0 f d feat | l ]; - destruct w as [ | u | gr' | q' ]; cbn [owner] in Ho; - try discriminate Ho; injection Ho as <-. - - apply dep_crate_agree; - [intro d; apply in_slotFibre | apply evalReq_reads - | apply in_realPreimage_own | intro l; apply in_linkFibre]. - - apply dep_featP_agree; - [intro d; apply in_slotFibre | apply evalReq_reads - | apply in_supportFibre | intro e; apply in_fdefFibre]. - Qed. - End Lookup. - Theorem cargo_soundness : forall R support FDefs Slots Links g dflt rc rootFeats (S : T.PkgSet.t), SiteFunctional Slots -> T.IsResolution - (transReal g R support FDefs Slots Links rc) - (transDeps g R support FDefs Slots Links dflt rc - rootFeats) transRoot S -> + (reduceReal g R support FDefs Slots Links rc) + (reduceDeps g R support FDefs Slots Links dflt rc + rootFeats) rootPkg S -> IsResolution R support FDefs Slots Links g dflt rc rootFeats (decodeS S) (decodeFS S) (decodeParents FDefs Slots rc S). @@ -2207,9 +1491,9 @@ Module Cargo (N V F G CfgS Src : UsualOrderedType) (PM : SemverMatch V). assert (Hed : T.DepRel.In ((NPlus.CFeatP m f (g u'), VPlus.WOrig u'), (NPlus.CCrate m (g u'), T.VSet.singleton (VPlus.WOrig u'))) - (transDeps g R support FDefs Slots Links dflt + (reduceDeps g R support FDefs Slots Links dflt (rn, rv) rootFeats)). - { apply mem_transDeps; split; [exact (Hsub _ Hf) |]. + { apply mem_reduceDeps; split; [exact (Hsub _ Hf) |]. apply mem_dep_featP; split; [reflexivity |]. split; [exact Hsp | left; reflexivity]. } destruct (Hdep _ Hf _ _ Hed) as [w [Hw HwS]]. @@ -2219,10 +1503,10 @@ Module Cargo (N V F G CfgS Src : UsualOrderedType) (PM : SemverMatch V). - intros [m v] Hp; apply mem_decodeS in Hp; destruct Hp as [gr Hp]. exact (proj1 (A1 _ _ _ Hp)). - assert (Hed : T.DepRel.In - (transRoot, (NPlus.CCrate rn (g rv), T.VSet.singleton (VPlus.WOrig rv))) - (transDeps g R support FDefs Slots Links dflt + (rootPkg, (NPlus.CCrate rn (g rv), T.VSet.singleton (VPlus.WOrig rv))) + (reduceDeps g R support FDefs Slots Links dflt (rn, rv) rootFeats)). - { apply mem_transDeps; split; [exact (Hsub _ Hroot) |]. + { apply mem_reduceDeps; split; [exact (Hsub _ Hroot) |]. apply mem_dep_root; left; reflexivity. } destruct (Hdep _ Hroot _ _ Hed) as [w [Hw HwS]]. apply T.VSet.singleton_spec in Hw; subst w. @@ -2230,11 +1514,11 @@ Module Cargo (N V F G CfgS Src : UsualOrderedType) (PM : SemverMatch V). - intros fs Hfs; apply mem_decodeFS in Hfs; destruct Hfs as [_ ->]; intros f Hf. assert (Hed : T.DepRel.In - (transRoot, (NPlus.CFeatP rn f (g rv), + (rootPkg, (NPlus.CFeatP rn f (g rv), T.VSet.singleton (VPlus.WOrig rv))) - (transDeps g R support FDefs Slots Links dflt + (reduceDeps g R support FDefs Slots Links dflt (rn, rv) rootFeats)). - { apply mem_transDeps; split; [exact (Hsub _ Hroot) |]. + { apply mem_reduceDeps; split; [exact (Hsub _ Hroot) |]. apply mem_dep_root; right; exists f; split; [exact Hf | reflexivity]. } destruct (Hdep _ Hroot _ _ Hed) as [w [Hw HwS]]. @@ -2299,9 +1583,9 @@ Module Cargo (N V F G CfgS Src : UsualOrderedType) (PM : SemverMatch V). ((NPlus.CSlot m (g v) d, VPlus.WClass (g u0)), (NPlus.CCrate (sTarget d) (g u0), inGran g (g u0) (evalReq R (sTarget d) (sReq d)))) - (transDeps g R support FDefs Slots Links dflt + (reduceDeps g R support FDefs Slots Links dflt (rn, rv) rootFeats)). - { apply mem_transDeps; split; [exact (Hsub _ Hslot) |]. + { apply mem_reduceDeps; split; [exact (Hsub _ Hslot) |]. apply mem_dep_slot; split; [exact Ho |]. exists u0; split; [exact Hu0 |]. split; [reflexivity | left; reflexivity]. } @@ -2323,9 +1607,9 @@ Module Cargo (N V F G CfgS Src : UsualOrderedType) (PM : SemverMatch V). ((NPlus.CSlot m (g v) d, VPlus.WClass (g u0)), (NPlus.CFeatP (sTarget d) f (g u0), inGran g (g u0) (evalReq R (sTarget d) (sReq d)))) - (transDeps g R support FDefs Slots Links dflt + (reduceDeps g R support FDefs Slots Links dflt (rn, rv) rootFeats)). - { apply mem_transDeps; split; [exact (Hsub _ Hslot) |]. + { apply mem_reduceDeps; split; [exact (Hsub _ Hslot) |]. apply mem_dep_slot; split; [exact Ho |]. exists u0; split; [exact Hu0 |]. split; [reflexivity |]. @@ -2341,9 +1625,9 @@ Module Cargo (N V F G CfgS Src : UsualOrderedType) (PM : SemverMatch V). ((NPlus.CCrate m (g v), VPlus.WOrig v), (NPlus.CSlot m (g v) d, gransOf g (evalReq R (sTarget d) (sReq d)))) - (transDeps g R support FDefs Slots Links dflt + (reduceDeps g R support FDefs Slots Links dflt (rn, rv) rootFeats)). - { apply mem_transDeps; split; [exact (Hsub _ Hp) |]. + { apply mem_reduceDeps; split; [exact (Hsub _ Hp) |]. apply mem_dep_crate; split; [reflexivity |]. split; [exact (proj1 (A1 _ _ _ Hp)) |]. left; exists d; repeat split; assumption. } @@ -2367,9 +1651,9 @@ Module Cargo (N V F G CfgS Src : UsualOrderedType) (PM : SemverMatch V). ((NPlus.CFeatP m f (g v), VPlus.WOrig v), (NPlus.CSlot m (g v) d, gransOf g (evalReq R (sTarget d) (sReq d)))) - (transDeps g R support FDefs Slots Links dflt + (reduceDeps g R support FDefs Slots Links dflt (rn, rv) rootFeats)). - { apply mem_transDeps; split; [exact (Hsub _ Hffs) |]. + { apply mem_reduceDeps; split; [exact (Hsub _ Hffs) |]. apply mem_dep_featP; split; [reflexivity |]. split; [exact (proj1 (A2 _ _ _ _ Hffs)) |]. right; exists e'; split; [exact He' |]. @@ -2384,9 +1668,9 @@ Module Cargo (N V F G CfgS Src : UsualOrderedType) (PM : SemverMatch V). assert (Hed : T.DepRel.In ((NPlus.CFeatP m f (g v), VPlus.WOrig v), (NPlus.CFeatP m f' (g v), T.VSet.singleton (VPlus.WOrig v))) - (transDeps g R support FDefs Slots Links dflt + (reduceDeps g R support FDefs Slots Links dflt (rn, rv) rootFeats)). - { apply mem_transDeps; split; [exact (Hsub _ Hf) |]. + { apply mem_reduceDeps; split; [exact (Hsub _ Hf) |]. apply mem_dep_featP; split; [reflexivity |]. split; [exact (proj1 (A2 _ _ _ _ Hf)) |]. right; exists (FEntry.EFeat f'); split; [exact He |]. @@ -2416,9 +1700,9 @@ Module Cargo (N V F G CfgS Src : UsualOrderedType) (PM : SemverMatch V). ((NPlus.CFeatP m f (g v), VPlus.WOrig v), (NPlus.CDec m (g v) f d feat, gransOf g (evalReq R (sTarget d) (sReq d)))) - (transDeps g R support FDefs Slots Links dflt + (reduceDeps g R support FDefs Slots Links dflt (rn, rv) rootFeats)). - { apply mem_transDeps; split; [exact (Hsub _ Hf) |]. + { apply mem_reduceDeps; split; [exact (Hsub _ Hf) |]. apply mem_dep_featP; split; [reflexivity |]. split; [exact (proj1 (A2 _ _ _ _ Hf)) |]. right; exists e'; split; [exact He' |]. @@ -2432,9 +1716,9 @@ Module Cargo (N V F G CfgS Src : UsualOrderedType) (PM : SemverMatch V). ((NPlus.CDec m (g v) f d feat, VPlus.WClass (g u1)), (NPlus.CSlot m (g v) d, T.VSet.singleton (VPlus.WClass (g u1)))) - (transDeps g R support FDefs Slots Links dflt + (reduceDeps g R support FDefs Slots Links dflt (rn, rv) rootFeats)). - { apply mem_transDeps; split; [exact (Hsub _ HwS) |]. + { apply mem_reduceDeps; split; [exact (Hsub _ HwS) |]. apply mem_dep_dec; split; [exact Hdo |]. exists u1; split; [exact Hu1 |]. split; [reflexivity | left; reflexivity]. } @@ -2444,9 +1728,9 @@ Module Cargo (N V F G CfgS Src : UsualOrderedType) (PM : SemverMatch V). ((NPlus.CDec m (g v) f d feat, VPlus.WClass (g u1)), (NPlus.CFeatP (sTarget d) feat (g u1), inGran g (g u1) (evalReq R (sTarget d) (sReq d)))) - (transDeps g R support FDefs Slots Links dflt + (reduceDeps g R support FDefs Slots Links dflt (rn, rv) rootFeats)). - { apply mem_transDeps; split; [exact (Hsub _ HwS) |]. + { apply mem_reduceDeps; split; [exact (Hsub _ HwS) |]. apply mem_dep_dec; split; [exact Hdo |]. exists u1; split; [exact Hu1 |]. split; [reflexivity | right; reflexivity]. } @@ -2469,9 +1753,9 @@ Module Cargo (N V F G CfgS Src : UsualOrderedType) (PM : SemverMatch V). ((NPlus.CCrate pn (g pv), VPlus.WOrig pv), (NPlus.CLink l, T.VSet.singleton (VPlus.WName (NPlus.CCrate pn (g pv))))) - (transDeps g R support FDefs Slots Links dflt + (reduceDeps g R support FDefs Slots Links dflt (rn, rv) rootFeats)). - { apply mem_transDeps; split; [exact (Hsub _ Hp) |]. + { apply mem_reduceDeps; split; [exact (Hsub _ Hp) |]. apply mem_dep_crate; split; [reflexivity |]. split; [exact HpR | right; exists l; split; [exact Hlp | reflexivity]]. } @@ -2479,9 +1763,9 @@ Module Cargo (N V F G CfgS Src : UsualOrderedType) (PM : SemverMatch V). ((NPlus.CCrate qn (g qv), VPlus.WOrig qv), (NPlus.CLink l, T.VSet.singleton (VPlus.WName (NPlus.CCrate qn (g qv))))) - (transDeps g R support FDefs Slots Links dflt + (reduceDeps g R support FDefs Slots Links dflt (rn, rv) rootFeats)). - { apply mem_transDeps; split; [exact (Hsub _ Hq) |]. + { apply mem_reduceDeps; split; [exact (Hsub _ Hq) |]. apply mem_dep_crate; split; [reflexivity |]. split; [exact HqR | right; exists l; split; [exact Hlq | reflexivity]]. } @@ -2495,467 +1779,1055 @@ Module Cargo (N V F G CfgS Src : UsualOrderedType) (PM : SemverMatch V). rewrite E'; reflexivity. Qed. - Module SOfw2 := SetOps Featured T.Pkg FeaturedSet T.PkgSet. - Module SOfsp := SetOps F T.Pkg FSet T.PkgSet. - Module SOparp := SetOps ParentElt T.Pkg ParentRel T.PkgSet. + Module SOfw2 := SetOps Featured T.Pkg FeaturedSet T.PkgSet. + Module SOfsp := SetOps F T.Pkg FSet T.PkgSet. + Module SOparp := SetOps ParentElt T.Pkg ParentRel T.PkgSet. + + Definition wFeats (g : V.t -> G.t) (FS : FeaturedSet.t) : T.PkgSet.t := + SOfw2.unionMap (fun '((m, v), fs) => + SOfsp.map (fun f => (NPlus.CFeatP m f (g v), VPlus.WOrig v)) fs) + FS. + + Lemma mem_wFeats : forall g FS x, + T.PkgSet.In x (wFeats g FS) <-> + exists m v fs f, FeaturedSet.In ((m, v), fs) FS /\ FSet.In f fs /\ + x = (NPlus.CFeatP m f (g v), VPlus.WOrig v). + Proof. + intros g FS x; unfold wFeats; rewrite SOfw2.mem_unionMap; split. + - intros [[[m v] fs] [Hin Hx]]; cbn beta iota in Hx. + apply SOfsp.mem_map in Hx; destruct Hx as [f [Hf ->]]. + exists m, v, fs, f; repeat split; assumption. + - intros [m [v [fs [f [Hin [Hf ->]]]]]]. + exists ((m, v), fs); split; [exact Hin | cbn beta iota]. + apply SOfsp.mem_map; exists f; split; [exact Hf | reflexivity]. + Qed. + + Definition wSlots (g : V.t -> G.t) (FDefs : FDefRel.t) + (Slots : SlotRel.t) (rc : Pkg.t) + (S : PkgSet.t) (FS : FeaturedSet.t) (pi : ParentRel.t) : T.PkgSet.t := + SOparp.unionMap (fun '(((m, v), k), u) => + if parentsb FDefs Slots rc S FS (m, v) k + then SOslp.map (fun '(_, d) => + (NPlus.CSlot m (g v) d, VPlus.WClass (g u))) + (slotsAtKey Slots rc (m, v) k) + else T.PkgSet.empty) + pi. + + Lemma mem_wSlots : forall g FDefs Slots rc S FS pi x, + T.PkgSet.In x (wSlots g FDefs Slots rc S FS pi) <-> + exists m v k u d, ParentRel.In (((m, v), k), u) pi /\ + parentsb FDefs Slots rc S FS (m, v) k = true /\ + SlotRel.In ((m, v), d) Slots /\ sKey d = k /\ + slotActive rc (m, v) d = true /\ + x = (NPlus.CSlot m (g v) d, VPlus.WClass (g u)). + Proof. + intros g FDefs Slots rc S FS pi x; unfold wSlots. + rewrite SOparp.mem_unionMap; split. + - intros [[[[m v] k] u] [Hin Hx]]; cbn beta iota in Hx. + apply SOslp.in_if_empty in Hx as [Eb Hx]. + apply SOslp.mem_map in Hx; destruct Hx as [[q d] [Hq ->]]. + apply mem_slotsAtKey in Hq; destruct Hq as [Hs [-> [Ha Hact]]]. + exists m, v, k, u, d; repeat split; assumption. + - intros [m [v [k [u [d [Hin [Eb [Hs [Ha [Hact ->]]]]]]]]]]. + exists (((m, v), k), u); split; [exact Hin | cbn beta iota]. + rewrite Eb; apply SOslp.mem_map; exists ((m, v), d); split; + [apply mem_slotsAtKey; repeat split; assumption | reflexivity]. + Qed. + + Definition wDecs (g : V.t -> G.t) (FDefs : FDefRel.t) + (Slots : SlotRel.t) (rc : Pkg.t) + (S : PkgSet.t) (FS : FeaturedSet.t) (pi : ParentRel.t) : T.PkgSet.t := + SOparp.unionMap (fun '(((m, v), k), u) => + if parentsb FDefs Slots rc S FS (m, v) k + then SOfp.unionMap (fun '((q, f), e) => + match entryFeatD e with + | Some (a', feat) => + if andb (andb (PkgEqb.eqb q (m, v)) + (NEqb.eqb a' (kAlias k))) + (FSet.mem f (fsAt FS (m, v))) + then SOslp.map (fun '(_, d) => + (NPlus.CDec m (g v) f d feat, VPlus.WClass (g u))) + (slotsAtKey Slots rc (m, v) k) + else T.PkgSet.empty + | None => T.PkgSet.empty + end) + FDefs + else T.PkgSet.empty) + pi. + + Lemma mem_wDecs : forall g FDefs Slots rc S FS pi x, + T.PkgSet.In x (wDecs g FDefs Slots rc S FS pi) <-> + exists m v k u f e feat d, ParentRel.In (((m, v), k), u) pi /\ + parentsb FDefs Slots rc S FS (m, v) k = true /\ + FDefRel.In (((m, v), f), e) FDefs /\ + entryFeatD e = Some (kAlias k, feat) /\ + FSet.In f (fsAt FS (m, v)) /\ + SlotRel.In ((m, v), d) Slots /\ sKey d = k /\ + slotActive rc (m, v) d = true /\ + x = (NPlus.CDec m (g v) f d feat, VPlus.WClass (g u)). + Proof. + intros g FDefs Slots rc S FS pi x; unfold wDecs. + rewrite SOparp.mem_unionMap; split. + - intros [[[[m v] k] u] [Hin Hx]]; cbn beta iota in Hx. + apply SOslp.in_if_empty in Hx as [Eb Hx]. + apply SOfp.mem_unionMap in Hx; destruct Hx as [[[q f] e] [Hf Hx]]. + cbn beta iota in Hx. + destruct (entryFeatD e) as [[a' feat] |] eqn:Ee; + [| exfalso; exact (SOslp.empty_in _ Hx)]. + rewrite SOslp.in_if_empty, !andb_true_iff, PkgEqb.eqb_true_iff, + NEqb.eqb_true_iff, FSet.mem_spec in Hx. + destruct Hx as [[[-> ->] Em] Hx]. + apply SOslp.mem_map in Hx; destruct Hx as [[q d] [Hq ->]]. + apply mem_slotsAtKey in Hq; destruct Hq as [Hs [-> [Ha Hact]]]. + exists m, v, k, u, f, e, feat, d; repeat split; assumption. + - intros [m [v [k [u [f [e [feat [d + [Hin [Eb [Hf [Ee [Em [Hs [Ha [Hact ->]]]]]]]]]]]]]]]]. + exists (((m, v), k), u); split; [exact Hin | cbn beta iota]. + rewrite Eb; apply SOfp.mem_unionMap. + exists (((m, v), f), e); split; [exact Hf | cbn beta iota]. + rewrite Ee, PkgEqb.eqb_refl, NEqb.eqb_refl, + (proj2 (FSet.mem_spec _ _) Em); cbn [andb]. + apply SOslp.mem_map; exists ((m, v), d); split; + [apply mem_slotsAtKey; repeat split; assumption | reflexivity]. + Qed. + + Definition coreResolution (g : V.t -> G.t) (FDefs : FDefRel.t) + (Slots : SlotRel.t) (Links : LinkRel.t) + (rc : Pkg.t) (S : PkgSet.t) + (FS : FeaturedSet.t) (pi : ParentRel.t) : T.PkgSet.t := + T.PkgSet.add rootPkg + (T.PkgSet.union (crateReal g S) + (T.PkgSet.union (wFeats g FS) + (T.PkgSet.union + (wSlots g FDefs Slots rc S FS pi) + (T.PkgSet.union + (wDecs g FDefs Slots rc S FS pi) + (linkReal g S Links))))). + + Lemma mem_coreResolution : + forall g FDefs Slots Links rc S FS pi x, + T.PkgSet.In x + (coreResolution g FDefs Slots Links rc S FS pi) <-> + x = rootPkg \/ T.PkgSet.In x (crateReal g S) \/ + T.PkgSet.In x (wFeats g FS) \/ + T.PkgSet.In x (wSlots g FDefs Slots rc S FS pi) \/ + T.PkgSet.In x (wDecs g FDefs Slots rc S FS pi) \/ + T.PkgSet.In x (linkReal g S Links). + Proof. + intros; unfold coreResolution. + rewrite T.PkgSet.add_spec, !T.PkgSet.union_spec; reflexivity. + Qed. + + Lemma core_shape : + forall g FDefs Slots Links rc S FS pi n w, + T.PkgSet.In (n, w) + (coreResolution g FDefs Slots Links rc S FS pi) <-> + match n with + | NPlus.CRoot => w = VPlus.WUnit + | NPlus.CCrate m gr => + exists v, w = VPlus.WOrig v /\ PkgSet.In (m, v) S /\ gr = g v + | NPlus.CFeatP m f gr => + exists v fs, w = VPlus.WOrig v /\ FeaturedSet.In ((m, v), fs) FS /\ + FSet.In f fs /\ gr = g v + | NPlus.CSlot m gr d => + exists v u, w = VPlus.WClass (g u) /\ gr = g v /\ + ParentRel.In (((m, v), sKey d), u) pi /\ + parentsb FDefs Slots rc S FS (m, v) (sKey d) = true /\ + SlotRel.In ((m, v), d) Slots /\ slotActive rc (m, v) d = true + | NPlus.CDec m gr f d feat => + exists v u e, w = VPlus.WClass (g u) /\ gr = g v /\ + ParentRel.In (((m, v), sKey d), u) pi /\ + parentsb FDefs Slots rc S FS (m, v) (sKey d) = true /\ + SlotRel.In ((m, v), d) Slots /\ slotActive rc (m, v) d = true /\ + FDefRel.In (((m, v), f), e) FDefs /\ + entryFeatD e = Some (sAlias d, feat) /\ + FSet.In f (fsAt FS (m, v)) + | NPlus.CLink l => + exists m v, w = VPlus.WName (NPlus.CCrate m (g v)) /\ + LinkRel.In ((m, v), l) Links /\ PkgSet.In (m, v) S + end. + Proof. + intros g FDefs Slots Links rc S FS pi n w. + rewrite mem_coreResolution, mem_crateReal, mem_wFeats, mem_wSlots, + mem_wDecs, mem_linkReal; unfold rootPkg; split. + - intros [He | [He | [He | [He | [He | He]]]]]; mem_destruct; eauto 20. + - destruct n as [| m gr | m f gr | m gr d | m gr f d feat | l]; + cbn beta iota. + + intros ->; left; reflexivity. + + intros [v [-> [HS ->]]]; right; left; exists m, v; auto. + + intros [v [fs [-> [Hfs [Hf ->]]]]]. + right; right; left; exists m, v, fs, f; auto. + + intros [v [u [-> [-> [Hpi [Eb [Hs Hact]]]]]]]. + right; right; right; left; exists m, v, (sKey d), u, d. + repeat split; assumption. + + intros [v [u [e [-> [-> [Hpi [Eb [Hs [Hact [Hf [Ee Hfs]]]]]]]]]]]. + right; right; right; right; left. + exists m, v, (sKey d), u, f, e, feat, d; repeat split; assumption. + + intros [m [v [-> [Hl HS]]]]; right; right; right; right; right. + exists m, v, l; auto. + Qed. + + Lemma fsAt_mem + {R support FDefs Slots Links g dflt rc rootFeats S FS pi} : + IsResolution R support FDefs Slots Links g dflt rc + rootFeats S FS pi -> + forall p, PkgSet.In p S -> FeaturedSet.In (p, fsAt FS p) FS. + Proof. + intros Hres p Hp; destruct (res_fs_total Hres Hp) as [fs Hfs]. + rewrite (fsAt_in FS p fs (res_fs_functional Hres) Hfs); exact Hfs. + Qed. + + Lemma parent_pick + {R support FDefs Slots Links g dflt rc rootFeats S FS pi} : + IsResolution R support FDefs Slots Links g dflt rc + rootFeats S FS pi -> + forall m v d, PkgSet.In (m, v) S -> + SlotRel.In ((m, v), d) Slots -> + slotActive rc (m, v) d = true -> + (sOptional d = false \/ + Activated FDefs (fsAt FS (m, v)) (m, v) (sAlias d)) -> + exists u, ParentRel.In (((m, v), sKey d), u) pi /\ + parentsb FDefs Slots rc S FS (m, v) (sKey d) = true /\ + VSet.In u (evalReq R (sTarget d) (sReq d)) /\ + PkgSet.In (sTarget d, u) S /\ + FSet.Subset (slotRequests d dflt) (fsAt FS (sTarget d, u)). + Proof. + intros Hres m v d HS Hd Hact Hopt. + destruct (res_slot_closure Hres HS (fsAt_mem Hres _ HS) Hd Hact Hopt) + as [u [Hpi [Hrg [Htgt Hsub]]]]. + exists u; repeat split; try assumption. + - apply parentsb_iff; split; [exact HS |]. + exists d; repeat split; assumption. + - apply mem_evalReq; split; [exact (res_subset Hres Htgt) | exact Hrg]. + - exact (Hsub _ (fsAt_mem Hres _ Htgt)). + Qed. + + Lemma parent_slot + {R support FDefs Slots Links g dflt rc rootFeats S FS pi} : + SiteFunctional Slots -> + IsResolution R support FDefs Slots Links g dflt rc + rootFeats S FS pi -> + forall m v k u, ParentRel.In (((m, v), k), u) pi -> + parentsb FDefs Slots rc S FS (m, v) k = true -> + exists d, SlotRel.In ((m, v), d) Slots /\ sKey d = k /\ + slotActive rc (m, v) d = true /\ + VSet.In u (evalReq R (sTarget d) (sReq d)) /\ + PkgSet.In (sTarget d, u) S /\ + FSet.Subset (slotRequests d dflt) (fsAt FS (sTarget d, u)). + Proof. + intros Hsite Hres m v k u Hpi Eb. + apply parentsb_iff in Eb; destruct Eb as [HS [d [Hd [<- [Hact Hreq]]]]]. + destruct (parent_pick Hres m v d HS Hd Hact Hreq) + as [u0 [Hpi0 [_ [Hu0 [Htgt Hsub]]]]]. + rewrite (res_pi_functional Hres Hpi Hpi0). + exists d; repeat split; assumption. + Qed. + + Theorem cargo_completeness : + forall R support FDefs Slots Links g dflt rc rootFeats + S FS pi, + SiteFunctional Slots -> + IsResolution R support FDefs Slots Links g dflt rc + rootFeats S FS pi -> + T.IsResolution + (reduceReal g R support FDefs Slots Links rc) + (reduceDeps g R support FDefs Slots Links dflt rc + rootFeats) rootPkg + (coreResolution g FDefs Slots Links rc S FS pi). + Proof. + intros R support FDefs Slots Links g dflt rc rootFeats + S FS pi Hsite Hres. + assert (HfsAt := fsAt_mem Hres). + assert (Hpick := parent_pick Hres). + assert (Hslot := parent_slot Hsite Hres). + destruct rc as [rn rv]. + destruct Hres as [Hsub Hroot Hrootf Hdom Htot Hfun Hclass Hsupp + Hpifun _ Hslotc Hfsame Hfdep Hlinks]. + constructor. + - intros [n w] Hx; apply core_shape in Hx; apply real_shape. + destruct n as [| m gr | m f gr | m gr d | m gr f d feat | l]; + cbn beta iota in Hx |- *. + + exact Hx. + + destruct Hx as [v [-> [HS ->]]]; exists v. + repeat split; exact (Hsub _ HS). + + destruct Hx as [v [fs [-> [Hfs [Hf ->]]]]]; exists v. + repeat split; exact (Hsupp _ _ _ Hfs Hf). + + destruct Hx as [v [u [-> [-> [Hpi [Eb [Hd Hact]]]]]]]. + destruct (Hslot _ _ _ _ Hpi Eb) as [d' [Hd' [Ha' [_ [Hu _]]]]]. + rewrite (Hsite (m, v) d' d Hd' Hd Ha') in Hu. + split; [exists v | exists u]; auto. + + destruct Hx + as [v [u [e [-> [-> [Hpi [Eb [Hd [Hact [Hf [Ee _]]]]]]]]]]]. + destruct (Hslot _ _ _ _ Hpi Eb) as [d' [Hd' [Ha' [_ [Hu _]]]]]. + rewrite (Hsite (m, v) d' d Hd' Hd Ha') in Hu. + split; [exists v, e; repeat split; assumption | exists u; auto]. + + destruct Hx as [m [v [-> [Hl HS]]]]; exists m, v. + repeat split; [exact Hl | exact (Hsub _ HS)]. + - apply mem_coreResolution; left; reflexivity. + - intros p Hp n vs Hed. + apply mem_reduceDeps in Hed; destruct Hed as [_ Hh]. + destruct p as [[| m gr | m f gr | m gr1 d | m gr1 f d feat | l] + [| v0 | gr0 | q]]; + try (rewrite dep_inert in Hh by exact I; + exfalso; exact (T.DependeesSet.empty_spec Hh)). + + apply mem_dep_root in Hh. + destruct Hh as [He | [f [Hf He]]]; injection He as E1 E2; + subst n vs; exists (VPlus.WOrig rv); + (split; [apply T.VSet.singleton_spec; reflexivity |]); + apply core_shape. + * exists rv; repeat split; exact Hroot. + * exists rv, (fsAt FS (rn, rv)); repeat split; + [exact (HfsAt _ Hroot) | exact (Hrootf _ (HfsAt _ Hroot) f Hf)]. + + apply mem_dep_crate in Hh. + apply core_shape in Hp; cbn beta iota in Hp. + destruct Hp as [v1 [Ev [HS _]]]; injection Ev as Ev; subst v1. + destruct Hh + as [<- [_ [[d [Hd [Hact [Hopt He]]]] | [l [Hl He]]]]]; + injection He as E1 E2; subst n vs. + * destruct (Hpick _ _ _ HS Hd Hact (or_introl Hopt)) + as [u [Hpi [Eb [Hu [Htgt Hss]]]]]. + exists (VPlus.WClass (g u)); split. + { apply mem_gransOf; exists u; split; + [exact Hu | reflexivity]. } + apply core_shape; exists v0, u; repeat split; assumption. + * exists (VPlus.WName (NPlus.CCrate m (g v0))); split; + [apply T.VSet.singleton_spec; reflexivity |]. + apply core_shape; exists m, v0; repeat split; assumption. + + apply mem_dep_featP in Hh. + apply core_shape in Hp; cbn beta iota in Hp. + destruct Hp as [v1 [fs [Ev [Hfs [Hf _]]]]]. + injection Ev as Ev; subst v1. + assert (Efs : fsAt FS (m, v0) = fs) + by exact (fsAt_in FS (m, v0) fs Hfun Hfs). + assert (HS : PkgSet.In (m, v0) S) by exact (Hdom _ _ Hfs). + destruct Hh as [_ [_ [He | [e0 [Hfd Hcase]]]]]. + * injection He as E1 E2; subst n vs. + exists (VPlus.WOrig v0); split; + [apply T.VSet.singleton_spec; reflexivity |]. + apply core_shape; exists v0; repeat split; exact HS. + * destruct Hcase as [[f' [Ee He]] | [Hcase | Hcase]]. + -- injection He as E1 E2; subst n vs e0. + exists (VPlus.WOrig v0); split; + [apply T.VSet.singleton_spec; reflexivity |]. + apply core_shape; exists v0, fs; repeat split; + [exact Hfs | exact (Hfsame _ _ _ _ Hfs Hf Hfd)]. + -- destruct Hcase as [a [d [Ea [Hd [Ha [Hact He]]]]]]; subst a. + injection He as E1 E2; subst n vs. + assert (Hactd : Activated FDefs (fsAt FS (m, v0)) (m, v0) + (sAlias d)). + { rewrite Efs; exists f; split; [exact Hf |]. + destruct e0 as [f0 | a0 | a0 feat0 | a0 feat0]; + cbn [entryActivates] in Ea; try discriminate; + injection Ea as Ea; subst a0; eauto. } + destruct (Hpick _ _ _ HS Hd Hact (or_intror Hactd)) + as [u [Hpi [Eb [Hu [Htgt Hss]]]]]. + exists (VPlus.WClass (g u)); split. + { apply mem_gransOf; exists u; split; + [exact Hu | reflexivity]. } + apply core_shape; exists v0, u; repeat split; assumption. + -- destruct Hcase as [a [feat [d [Ea [Hd [Ha [Hact He]]]]]]]; + subst a. + injection He as E1 E2; subst n vs. + assert (Hactd : Activated FDefs (fsAt FS (m, v0)) (m, v0) + (sAlias d)). + { rewrite Efs; exists f; split; [exact Hf |]. + destruct e0 as [f0 | a0 | a0 feat0 | a0 feat0]; + cbn [entryFeatD] in Ea; try discriminate; + injection Ea as Ea1 Ea2; subst a0 feat0; eauto. } + destruct (Hpick _ _ _ HS Hd Hact (or_intror Hactd)) + as [u [Hpi [Eb [Hu [Htgt Hss]]]]]. + exists (VPlus.WClass (g u)); split. + { apply mem_gransOf; exists u; split; + [exact Hu | reflexivity]. } + apply core_shape; exists v0, u, e0; repeat split; + try assumption. + rewrite Efs; exact Hf. + + apply mem_dep_slot in Hh. + destruct Hh as [_ [u0 [Hu0 [Hgu Hcase]]]]. + apply core_shape in Hp; cbn beta iota in Hp. + destruct Hp as [v [u [Eu [Egr [Hpi [Eb [Hd Hact]]]]]]]. + injection Eu as ->. + destruct (Hslot _ _ _ _ Hpi Eb) + as [d' [Hd' [Ha' [Hact' [Hu' [Htgt Hss]]]]]]. + assert (Ed : d' = d) by exact (Hsite (m, v) d' d Hd' Hd Ha'). + subst d'. + destruct Hcase as [He | [f0 [Hf0 He]]]; injection He as E1 E2; + subst n vs; exists (VPlus.WOrig u); + (split; [apply mem_inGran; exists u; auto |]); apply core_shape. + * exists u; repeat split; assumption. + * exists u, (fsAt FS (sTarget d, u)); repeat split; try assumption; + [exact (HfsAt _ Htgt) | exact (Hss _ Hf0)]. + + apply mem_dep_dec in Hh. + destruct Hh as [_ [u0 [Hu0 [Hgu Hcase]]]]. + apply core_shape in Hp; cbn beta iota in Hp. + destruct Hp as [v [u [e [Eu [Egr [Hpi [Eb [Hd [Hact + [Hfd2 [Ee2 Hf]]]]]]]]]]]. + injection Eu as ->; subst gr1. + assert (HSnv : PkgSet.In (m, v) S) + by (apply parentsb_iff in Eb; exact (proj1 Eb)). + destruct (Hslot _ _ _ _ Hpi Eb) + as [d' [Hd' [Ha' [Hact' [Hu' [Htgt Hss]]]]]]. + assert (Ed : d' = d) by exact (Hsite (m, v) d' d Hd' Hd Ha'). + subst d'. + destruct Hcase as [He | He]; injection He as E1 E2; subst n vs. + * exists (VPlus.WClass (g u)); split; + [apply T.VSet.singleton_spec; reflexivity |]. + apply core_shape; exists v, u; repeat split; assumption. + * exists (VPlus.WOrig u); split; [apply mem_inGran; exists u; auto |]. + apply core_shape; exists u, (fsAt FS (sTarget d, u)); + repeat split; try assumption; [exact (HfsAt _ Htgt) |]. + assert (Hor : + FDefRel.In (((m, v), f), FEntry.EDepFeat (sAlias d) feat) + FDefs \/ + FDefRel.In (((m, v), f), FEntry.EWeakFeat (sAlias d) feat) + FDefs). + { destruct e as [f0 | a0 | a0 feat0 | a0 feat0]; + cbn [entryFeatD] in Ee2; try discriminate; + injection Ee2 as Ee1 Ee3; subst a0 feat0; + [left | right]; exact Hfd2. } + exact (Hfdep (m, v) (fsAt FS (m, v)) f (sAlias d) feat + (HfsAt _ HSnv) Hf Hor d u Hd eq_refl Hpi + (fsAt FS (sTarget d, u)) (HfsAt _ Htgt)). + - intros n w w' Hw Hw'. + apply core_shape in Hw; apply core_shape in Hw'. + destruct n as [ | m gr | m f gr | m gr d | m gr f d feat | l ]; + cbn beta iota in Hw, Hw'. + + subst w w'; reflexivity. + + destruct Hw as [v [-> [HS Eg]]]; + destruct Hw' as [v' [-> [HS' Eg']]]. + destruct (V.eq_dec v v') as [E | NE]; + [rewrite E; reflexivity |]. + exfalso; apply (Hclass m v v' HS HS' NE); congruence. + + destruct Hw as [v [fs [-> [Hfs [Hf Eg]]]]]; + destruct Hw' as [v' [fs' [-> [Hfs' [Hf' Eg']]]]]. + destruct (V.eq_dec v v') as [E | NE]; + [rewrite E; reflexivity |]. + exfalso; apply (Hclass m v v' (Hdom _ _ Hfs) (Hdom _ _ Hfs') NE); + congruence. + + destruct Hw as [v [u [-> [Egr [Hpi [Eb _]]]]]]; + destruct Hw' as [v' [u' [-> [Egr' [Hpi' [Eb' _]]]]]]. + apply parentsb_iff in Eb; apply parentsb_iff in Eb'. + destruct (V.eq_dec v v') as [<- | NE]; + [| exfalso; apply (Hclass m v v' (proj1 Eb) (proj1 Eb') NE); + congruence]. + rewrite (Hpifun (m, v) (sKey d) u u' Hpi Hpi'); reflexivity. + + destruct Hw as [v [u [e [-> [Egr [Hpi [Eb _]]]]]]]; + destruct Hw' as [v' [u' [e' [-> [Egr' [Hpi' [Eb' _]]]]]]]. + apply parentsb_iff in Eb; apply parentsb_iff in Eb'. + destruct (V.eq_dec v v') as [<- | NE]; + [| exfalso; apply (Hclass m v v' (proj1 Eb) (proj1 Eb') NE); + congruence]. + rewrite (Hpifun (m, v) (sKey d) u u' Hpi Hpi'); reflexivity. + + destruct Hw as [m [v [-> [Hl HS]]]]; + destruct Hw' as [m' [v' [-> [Hl' HS']]]]. + assert (E := Hlinks (m, v) (m', v') l HS HS' Hl Hl'). + injection E as <- <-; reflexivity. + Qed. + + Module Lookup. + Theorem versions_reduceRealRoot : + forall g R support FDefs Slots Links rc w, + T.PkgSet.In (NPlus.CRoot, w) + (reduceReal g R support FDefs Slots Links rc) <-> + T.VSet.In w + (versions g R support FDefs Slots Links rc NPlus.CRoot). + Proof. + intros; rewrite real_shape; cbn [versions]. + rewrite T.VSet.singleton_spec; reflexivity. + Qed. + + Theorem versions_reduceRealCrate : + forall g R support FDefs Slots Links rc m gr w, + T.PkgSet.In (NPlus.CCrate m gr, w) + (reduceReal g R support FDefs Slots Links rc) <-> + T.VSet.In w + (versions g R support FDefs Slots Links rc + (NPlus.CCrate m gr)). + Proof. + intros; rewrite real_shape; cbn [versions]. + rewrite SOpv2.mem_filterMap; split. + - intros [v [-> [HR ->]]]; exists (m, v); split; [exact HR |]. + cbn beta iota; rewrite NEqb.eqb_refl, GEqb.eqb_refl; reflexivity. + - intros [[n' v] [HR He]]; cbn beta iota in He. + rewrite if_some_iff, andb_true_iff, NEqb.eqb_true_iff, GEqb.eqb_true_iff + in He. + destruct He as [[-> <-] <-]; exists v; auto. + Qed. + + Theorem versions_reduceRealFeatP : + forall g R support FDefs Slots Links rc m f gr w, + T.PkgSet.In (NPlus.CFeatP m f gr, w) + (reduceReal g R support FDefs Slots Links rc) <-> + T.VSet.In w + (versions g R support FDefs Slots Links rc + (NPlus.CFeatP m f gr)). + Proof. + intros; rewrite real_shape; cbn [versions]. + rewrite SOspv.mem_filterMap; split. + - intros [v [-> [Hs ->]]]; exists ((m, v), f); split; [exact Hs |]. + cbn beta iota; rewrite NEqb.eqb_refl, FEqb.eqb_refl, GEqb.eqb_refl; + reflexivity. + - intros [[[n' v] f'] [Hs He]]; cbn beta iota in He. + rewrite if_some_iff, !andb_true_iff, NEqb.eqb_true_iff, + FEqb.eqb_true_iff, GEqb.eqb_true_iff in He. + destruct He as [[[-> ->] <-] <-]; exists v; auto. + Qed. + + Theorem versions_reduceRealSlot : + forall g R support FDefs Slots Links rc m gr d w, + T.PkgSet.In (NPlus.CSlot m gr d, w) + (reduceReal g R support FDefs Slots Links rc) <-> + T.VSet.In w + (versions g R support FDefs Slots Links rc + (NPlus.CSlot m gr d)). + Proof. + intros; rewrite real_shape; cbn [versions]. + rewrite SOvv.in_if_empty, slotOwnedb_iff, mem_gransOf; reflexivity. + Qed. + + Theorem versions_reduceRealDecision : + forall g R support FDefs Slots Links rc m gr f d feat w, + T.PkgSet.In (NPlus.CDec m gr f d feat, w) + (reduceReal g R support FDefs Slots Links rc) <-> + T.VSet.In w + (versions g R support FDefs Slots Links rc + (NPlus.CDec m gr f d feat)). + Proof. + intros; rewrite real_shape; cbn [versions]. + rewrite SOvv.in_if_empty, decOwnedb_iff, mem_gransOf; reflexivity. + Qed. + + Theorem versions_reduceRealLink : + forall g R support FDefs Slots Links rc l w, + T.PkgSet.In (NPlus.CLink l, w) + (reduceReal g R support FDefs Slots Links rc) <-> + T.VSet.In w + (versions g R support FDefs Slots Links rc + (NPlus.CLink l)). + Proof. intros; rewrite real_shape, mem_versions_link; reflexivity. Qed. + + Theorem dependees_reduceDeps : + forall g R support FDefs Slots Links dflt rc rootFeats p, + dependees g R support FDefs Slots Links dflt rc + rootFeats p = + T.dependees + (reduceDeps g R support FDefs Slots Links dflt rc + rootFeats) p. + Proof. + intros; apply T.DependeesSet.ext; intro h. + rewrite T.mem_dependees, mem_reduceDeps; split. + - intro Hh; split; [| exact Hh]; eapply dep_real; exact Hh. + - intros [_ Hh]; exact Hh. + Qed. + + Theorem dependees_reduceDepsInert : + forall g R support FDefs Slots Links dflt rc rootFeats p, + Inert p -> + dependees g R support FDefs Slots Links dflt rc + rootFeats p = + T.dependees + (reduceDeps g R support FDefs Slots Links dflt rc + rootFeats) p. + Proof. intros; apply dependees_reduceDeps. Qed. + + Module NSet := FSetUOT N. + Module PkgPre := PreimageOfKeys N Pkg NSet PkgSet. + Module SupportPre := PreimageOfKeys N PkgF NSet SupportSet. + Module FDefPre := Preimage FDefElt FDefRel. + Module SlotFibred := FibredRel Pkg SlotData SlotElt SlotRel. + Module LinkFibred := FibredRel Pkg N LinkElt LinkRel. + Module SupportFibred := FibredRel Pkg F PkgF SupportSet. + Module SOsn := SetOps SlotElt N SlotRel NSet. + + Definition realPreimage (R : PkgSet.t) (ns : NSet.t) : PkgSet.t := + PkgPre.ofKeys fst ns R. + + Definition supportPreimage (support : SupportSet.t) (ns : NSet.t) + : SupportSet.t := + SupportPre.ofKeys (fun x => fst (fst x)) ns support. + + Definition fdefFibre (FDefs : FDefRel.t) (p : Pkg.t) : FDefRel.t := + FDefPre.preimage (fun x => fst (fst x)) (fun q => PkgEqb.eqb q p) FDefs. + + Definition reads (Slots : SlotRel.t) (p : Pkg.t) : NSet.t := + NSet.add (fst p) + (SOsn.map (fun x => sTarget (snd x)) (SlotFibred.tailFibre Slots p)). + + Definition claimants (R : PkgSet.t) (Links : LinkRel.t) (l : N.t) + : PkgSet.t := + PkgSet.filter (fun q => LinkRel.mem (q, l) Links) R. + + Lemma mem_realPreimage : forall R ns q, + PkgSet.In q (realPreimage R ns) <-> + PkgSet.In q R /\ NSet.In (fst q) ns. + Proof. intros; unfold realPreimage; apply PkgPre.mem_ofKeys. Qed. + + Lemma evalReq_realPreimage : forall R ns m rg, + NSet.In m ns -> + evalReq (realPreimage R ns) m rg = evalReq R m rg. + Proof. + intros R ns m rg Hm; apply VSet.ext; intro u. + rewrite !mem_evalReq, mem_realPreimage; cbn [fst]; tauto. + Qed. + + Lemma mem_supportPreimage : forall support ns m v f, + SupportSet.In ((m, v), f) (supportPreimage support ns) <-> + SupportSet.In ((m, v), f) support /\ NSet.In m ns. + Proof. + intros; unfold supportPreimage; rewrite SupportPre.mem_ofKeys; + cbn [fst]; reflexivity. + Qed. + + Lemma mem_fdefFibre : forall FDefs p q f e, + FDefRel.In ((q, f), e) (fdefFibre FDefs p) <-> + FDefRel.In ((q, f), e) FDefs /\ q = p. + Proof. + intros; unfold fdefFibre; rewrite FDefPre.mem_preimage; cbn [fst]. + rewrite PkgEqb.eqb_true_iff; reflexivity. + Qed. + + Lemma mem_claimants : forall R Links l q, + PkgSet.In q (claimants R Links l) <-> + PkgSet.In q R /\ LinkRel.In (q, l) Links. + Proof. + intros; unfold claimants; rewrite PkgSet.filter_spec', LinkRel.mem_spec; + reflexivity. + Qed. + + Lemma reads_own : forall Slots p, NSet.In (fst p) (reads Slots p). + Proof. intros; unfold reads; apply NSet.add_spec; left; reflexivity. Qed. + + Lemma reads_target : forall Slots p d, + SlotRel.In (p, d) Slots -> NSet.In (sTarget d) (reads Slots p). + Proof. + intros Slots p d Hs; unfold reads; apply NSet.add_spec; right. + apply SOsn.mem_map; exists (p, d); split; [| reflexivity]. + apply SlotFibred.mem_tailFibre; split; [exact Hs | reflexivity]. + Qed. + + Lemma in_realPreimage_own : forall R Slots p, + PkgSet.In p R <-> PkgSet.In p (realPreimage R (reads Slots p)). + Proof. + intros; rewrite mem_realPreimage; split; + [intro H; split; [exact H | apply reads_own] | intros [H _]; exact H]. + Qed. + + Lemma evalReq_reads : forall R Slots p d, + SlotRel.In (p, d) Slots -> + evalReq R (sTarget d) (sReq d) = + evalReq (realPreimage R (reads Slots p)) (sTarget d) (sReq d). + Proof. + intros R Slots p d Hs; symmetry; apply evalReq_realPreimage. + apply reads_target; exact Hs. + Qed. + + Lemma in_slotFibre : forall Slots p d, + SlotRel.In (p, d) Slots <-> + SlotRel.In (p, d) (SlotFibred.tailFibre Slots p). + Proof. + intros; rewrite SlotFibred.mem_tailFibre; split; + [intro H; split; [exact H | reflexivity] | intros [H _]; exact H]. + Qed. + + Lemma in_linkFibre : forall Links p l, + LinkRel.In (p, l) Links <-> + LinkRel.In (p, l) (LinkFibred.tailFibre Links p). + Proof. + intros; rewrite LinkFibred.mem_tailFibre; split; + [intro H; split; [exact H | reflexivity] | intros [H _]; exact H]. + Qed. + + Lemma in_supportFibre : forall support p f, + SupportSet.In (p, f) support <-> + SupportSet.In (p, f) (SupportFibred.tailFibre support p). + Proof. + intros; rewrite SupportFibred.mem_tailFibre; split; + [intro H; split; [exact H | reflexivity] | intros [H _]; exact H]. + Qed. + + Lemma in_fdefFibre : forall FDefs p f e, + FDefRel.In ((p, f), e) FDefs <-> + FDefRel.In ((p, f), e) (fdefFibre FDefs p). + Proof. + intros; rewrite mem_fdefFibre; split; + [intro H; split; [exact H | reflexivity] | intros [H _]; exact H]. + Qed. + + Theorem versions_lookupRoot : + forall g R support FDefs Slots Links rc, + versions g R support FDefs Slots Links rc NPlus.CRoot = + versions g PkgSet.empty SupportSet.empty FDefRel.empty SlotRel.empty + LinkRel.empty rc NPlus.CRoot. + Proof. reflexivity. Qed. + + Theorem versions_lookupCrate : + forall g R support FDefs Slots Links rc m gr, + versions g R support FDefs Slots Links rc (NPlus.CCrate m gr) = + versions g (realPreimage R (NSet.singleton m)) SupportSet.empty + FDefRel.empty SlotRel.empty LinkRel.empty rc (NPlus.CCrate m gr). + Proof. + intros; cbn [versions]; apply T.VSet.ext; intro w; symmetry. + apply SOpv2.filterMap_restrict; [apply PkgPre.ofKeys_subset |]. + intros [n' v] HR He; cbn beta iota in He. + rewrite if_some_iff, andb_true_iff, NEqb.eqb_true_iff in He. + destruct He as [[-> _] _]; apply mem_realPreimage; split; + [exact HR | apply NSet.singleton_spec; reflexivity]. + Qed. - Definition wFeats (g : V.t -> G.t) (FS : FeaturedSet.t) : T.PkgSet.t := - SOfw2.unionMap (fun '((m, v), fs) => - SOfsp.map (fun f => (NPlus.CFeatP m f (g v), VPlus.WOrig v)) fs) - FS. + Theorem versions_lookupFeatP : + forall g R support FDefs Slots Links rc m f gr, + versions g R support FDefs Slots Links rc (NPlus.CFeatP m f gr) = + versions g (realPreimage R (NSet.singleton m)) + (supportPreimage support (NSet.singleton m)) + FDefRel.empty SlotRel.empty LinkRel.empty rc (NPlus.CFeatP m f gr). + Proof. + intros; cbn [versions]; apply T.VSet.ext; intro w; symmetry. + apply SOspv.filterMap_restrict; [apply SupportPre.ofKeys_subset |]. + intros [[n' v] f'] Hs He; cbn beta iota in He. + rewrite if_some_iff, !andb_true_iff, NEqb.eqb_true_iff in He. + destruct He as [[[-> _] _] _]; apply mem_supportPreimage; split; + [exact Hs | apply NSet.singleton_spec; reflexivity]. + Qed. - Lemma mem_wFeats : forall g FS x, - T.PkgSet.In x (wFeats g FS) <-> - exists m v fs f, FeaturedSet.In ((m, v), fs) FS /\ FSet.In f fs /\ - x = (NPlus.CFeatP m f (g v), VPlus.WOrig v). - Proof. - intros g FS x; unfold wFeats; rewrite SOfw2.mem_unionMap; split. - - intros [[[m v] fs] [Hin Hx]]; cbn beta iota in Hx. - apply SOfsp.mem_map in Hx; destruct Hx as [f [Hf ->]]. - exists m, v, fs, f; repeat split; assumption. - - intros [m [v [fs [f [Hin [Hf ->]]]]]]. - exists ((m, v), fs); split; [exact Hin | cbn beta iota]. - apply SOfsp.mem_map; exists f; split; [exact Hf | reflexivity]. - Qed. + Lemma slotOwnedb_witness : + forall g Slots rc m gr d u, + SlotRel.In ((m, u), d) Slots -> g u = gr -> + slotActive rc (m, u) d = true -> + slotOwnedb g Slots rc m gr d = true /\ + slotOwnedb g (SlotFibred.tailFibre Slots (m, u)) rc m gr d = true. + Proof. + intros g Slots rc m gr d u Hs Hg Hact; split; apply slotOwnedb_iff; + exists u; (split; [exact Hg | split; [| exact Hact]]); + [exact Hs | exact (proj1 (in_slotFibre Slots (m, u) d) Hs)]. + Qed. - Definition wSlots (g : V.t -> G.t) (FDefs : FDefRel.t) - (Slots : SlotRel.t) (rc : Pkg.t) - (S : PkgSet.t) (FS : FeaturedSet.t) (pi : ParentRel.t) : T.PkgSet.t := - SOparp.unionMap (fun '(((m, v), k), u) => - if parentsb FDefs Slots rc S FS (m, v) k - then SOslp.map (fun '(_, d) => - (NPlus.CSlot m (g v) d, VPlus.WClass (g u))) - (slotsAtKey Slots rc (m, v) k) - else T.PkgSet.empty) - pi. + Lemma decOwnedb_witness : + forall g FDefs Slots rc m gr f d feat u e, + FDefRel.In (((m, u), f), e) FDefs -> + entryFeatD e = Some (sAlias d, feat) -> + SlotRel.In ((m, u), d) Slots -> g u = gr -> + slotActive rc (m, u) d = true -> + decOwnedb g FDefs Slots rc m gr f d feat = true /\ + decOwnedb g (fdefFibre FDefs (m, u)) + (SlotFibred.tailFibre Slots (m, u)) rc m gr f d feat = true. + Proof. + intros g FDefs Slots rc m gr f d feat u e Hf Ee Hs Hg Hact; + split; apply decOwnedb_iff; exists u, e; + (split; [exact Hg |]). + - repeat split; assumption. + - split; [exact (proj1 (in_fdefFibre FDefs (m, u) f e) Hf) |]. + split; [exact Ee |]. + split; [exact (proj1 (in_slotFibre Slots (m, u) d) Hs) | exact Hact]. + Qed. - Lemma mem_wSlots : forall g FDefs Slots rc S FS pi x, - T.PkgSet.In x (wSlots g FDefs Slots rc S FS pi) <-> - exists m v k u d, ParentRel.In (((m, v), k), u) pi /\ - parentsb FDefs Slots rc S FS (m, v) k = true /\ - SlotRel.In ((m, v), d) Slots /\ sKey d = k /\ - slotActive rc (m, v) d = true /\ - x = (NPlus.CSlot m (g v) d, VPlus.WClass (g u)). - Proof. - intros g FDefs Slots rc S FS pi x; unfold wSlots. - rewrite SOparp.mem_unionMap; split. - - intros [[[[m v] k] u] [Hin Hx]]; cbn beta iota in Hx. - destruct (parentsb FDefs Slots rc S FS (m, v) k) eqn:Eb; - [| exfalso; exact (SOslp.empty_in _ Hx)]. - apply SOslp.mem_map in Hx; destruct Hx as [[q d] [Hq ->]]. - apply mem_slotsAtKey in Hq; destruct Hq as [Hs [-> [Ha Hact]]]. - exists m, v, k, u, d; repeat split; assumption. - - intros [m [v [k [u [d [Hin [Eb [Hs [Ha [Hact ->]]]]]]]]]]. - exists (((m, v), k), u); split; [exact Hin | cbn beta iota]. - rewrite Eb; apply SOslp.mem_map; exists ((m, v), d); split; - [apply mem_slotsAtKey; repeat split; assumption | reflexivity]. - Qed. + Theorem versions_lookupSlot : + forall g R support FDefs Slots Links rc m gr d u, + SlotRel.In ((m, u), d) Slots -> g u = gr -> + slotActive rc (m, u) d = true -> + versions g R support FDefs Slots Links rc (NPlus.CSlot m gr d) = + versions g (realPreimage R (NSet.singleton (sTarget d))) + SupportSet.empty FDefRel.empty (SlotFibred.tailFibre Slots (m, u)) + LinkRel.empty rc (NPlus.CSlot m gr d). + Proof. + intros g R support FDefs Slots Links rc m gr d u Hs Hg Hact. + destruct (slotOwnedb_witness g Slots rc m gr d u Hs Hg Hact) + as [E1 E2]. + cbn [versions]; rewrite E1, E2. + rewrite evalReq_realPreimage; + [reflexivity | apply NSet.singleton_spec; reflexivity]. + Qed. - Definition wDecs (g : V.t -> G.t) (FDefs : FDefRel.t) - (Slots : SlotRel.t) (rc : Pkg.t) - (S : PkgSet.t) (FS : FeaturedSet.t) (pi : ParentRel.t) : T.PkgSet.t := - SOparp.unionMap (fun '(((m, v), k), u) => - if parentsb FDefs Slots rc S FS (m, v) k - then SOfp.unionMap (fun '((q, f), e) => - match entryFeatD e with - | Some (a', feat) => - if andb (andb (PkgEqb.eqb q (m, v)) - (NEqb.eqb a' (kAlias k))) - (FSet.mem f (fsAt FS (m, v))) - then SOslp.map (fun '(_, d) => - (NPlus.CDec m (g v) f d feat, VPlus.WClass (g u))) - (slotsAtKey Slots rc (m, v) k) - else T.PkgSet.empty - | None => T.PkgSet.empty - end) - FDefs - else T.PkgSet.empty) - pi. + Theorem versions_lookupDecision : + forall g R support FDefs Slots Links rc m gr f d feat u e, + FDefRel.In (((m, u), f), e) FDefs -> + entryFeatD e = Some (sAlias d, feat) -> + SlotRel.In ((m, u), d) Slots -> g u = gr -> + slotActive rc (m, u) d = true -> + versions g R support FDefs Slots Links rc + (NPlus.CDec m gr f d feat) = + versions g (realPreimage R (NSet.singleton (sTarget d))) + SupportSet.empty (fdefFibre FDefs (m, u)) + (SlotFibred.tailFibre Slots (m, u)) + LinkRel.empty rc (NPlus.CDec m gr f d feat). + Proof. + intros g R support FDefs Slots Links rc m gr f d feat u e + Hf Ee Hs Hg Hact. + destruct (decOwnedb_witness g FDefs Slots rc m gr f d feat u e + Hf Ee Hs Hg Hact) as [E1 E2]. + cbn [versions]; rewrite E1, E2. + rewrite evalReq_realPreimage; + [reflexivity | apply NSet.singleton_spec; reflexivity]. + Qed. + + Theorem slot_declines : + forall g R support FDefs Slots Links dflt rc rootFeats m gr d, + ~ SlotOwned g Slots rc m gr d -> + versions g R support FDefs Slots Links rc (NPlus.CSlot m gr d) = + T.VSet.empty /\ + forall gr', dependees g R support FDefs Slots Links dflt rc rootFeats + (NPlus.CSlot m gr d, VPlus.WClass gr') = + T.DependeesSet.empty. + Proof. + intros g R support FDefs Slots Links dflt rc rootFeats m gr d Hn. + assert (E : slotOwnedb g Slots rc m gr d = false) + by (apply Bool.not_true_iff_false; rewrite slotOwnedb_iff; exact Hn). + split; [cbn [versions]; rewrite E; reflexivity |]. + intro gr'; cbn [dependees]; rewrite E; reflexivity. + Qed. + + Theorem decision_declines : + forall g R support FDefs Slots Links dflt rc rootFeats m gr f d feat, + ~ DecOwned g FDefs Slots rc m gr f d feat -> + versions g R support FDefs Slots Links rc (NPlus.CDec m gr f d feat) = + T.VSet.empty /\ + forall gr', dependees g R support FDefs Slots Links dflt rc rootFeats + (NPlus.CDec m gr f d feat, VPlus.WClass gr') = + T.DependeesSet.empty. + Proof. + intros g R support FDefs Slots Links dflt rc rootFeats m gr f d feat Hn. + assert (E : decOwnedb g FDefs Slots rc m gr f d feat = false) + by (apply Bool.not_true_iff_false; rewrite decOwnedb_iff; exact Hn). + split; [cbn [versions]; rewrite E; reflexivity |]. + intro gr'; cbn [dependees]; rewrite E; reflexivity. + Qed. + + Lemma crateReal_claimants : forall g R Links l, + crateReal g (claimants R Links l) = + ClsT.Reduction.Lookup.inClass (crateReal g R) (linkRel g Links) + (NPlus.CLink l). + Proof. + intros; apply T.PkgSet.ext; intro x. + rewrite ClsT.Reduction.Lookup.mem_inClass, !mem_crateReal. + split. + - intros [m [v [Hc ->]]]; apply mem_claimants in Hc. + destruct Hc as [HR Hl]; split. + + exists m, v; split; [exact HR | reflexivity]. + + apply mem_linkRel; exists m, v, l; repeat split; exact Hl. + - intros [[m [v [HR ->]]] Hc]. + apply mem_linkRel in Hc; destruct Hc as [m' [v' [l' [Hl [E Ek]]]]]. + injection E as E1 _ E3; subst m' v'; injection Ek as <-. + exists m, v; split; [apply mem_claimants; split; assumption + | reflexivity]. + Qed. + + Lemma linkRel_headFibre : forall g Links l, + linkRel g (LinkFibred.headFibre Links l) = + ClsT.Reduction.Lookup.classRelAt (linkRel g Links) (NPlus.CLink l). + Proof. + intros; apply ClsT.InClassRel.ext; intros [q k]. + rewrite ClsT.Reduction.Lookup.mem_classRelAt, !mem_linkRel. + split. + - intros [m [v [l' [Hl [-> ->]]]]]. + apply LinkFibred.mem_headFibre in Hl; destruct Hl as [Hl ->]. + split; [exists m, v, l; repeat split; exact Hl | reflexivity]. + - intros [[m [v [l' [Hl [-> ->]]]]] Ek]; injection Ek as ->. + exists m, v, l; repeat split. + apply LinkFibred.mem_headFibre; split; [exact Hl | reflexivity]. + Qed. + + Theorem versions_lookupLink : + forall g R support FDefs Slots Links rc l, + versions g R support FDefs Slots Links rc (NPlus.CLink l) = + versions g (claimants R Links l) SupportSet.empty FDefRel.empty + SlotRel.empty (LinkFibred.headFibre Links l) rc (NPlus.CLink l). + Proof. + intros; apply T.VSet.ext; intro w. + rewrite !versions_link_reduceReal, crateReal_claimants, + linkRel_headFibre, <- ClsT.Reduction.Lookup.versions_lookupClass. + reflexivity. + Qed. + + Lemma dep_crate_mono : + forall g R R' support support' FDefs FDefs' Slots Slots' Links Links' + dflt rc rootFeats rootFeats' m gr v, + (forall d, SlotRel.In ((m, v), d) Slots -> + SlotRel.In ((m, v), d) Slots') -> + (forall d, SlotRel.In ((m, v), d) Slots -> + evalReq R (sTarget d) (sReq d) = evalReq R' (sTarget d) (sReq d)) -> + (PkgSet.In (m, v) R -> PkgSet.In (m, v) R') -> + (forall l, LinkRel.In ((m, v), l) Links -> LinkRel.In ((m, v), l) Links') -> + forall h, + T.DependeesSet.In h + (dependees g R support FDefs Slots Links dflt rc rootFeats + (NPlus.CCrate m gr, VPlus.WOrig v)) -> + T.DependeesSet.In h + (dependees g R' support' FDefs' Slots' Links' dflt rc rootFeats' + (NPlus.CCrate m gr, VPlus.WOrig v)). + Proof. + intros * HS Hev HR HL h Hh. + apply mem_dep_crate in Hh; apply mem_dep_crate. + destruct Hh as [Hg [Hm Hh]]; split; [exact Hg | split; [exact (HR Hm) |]]. + destruct Hh as [[d [Hd [Ha [Ho ->]]]] | [l [Hl ->]]]. + - left; exists d; rewrite <- (Hev d Hd). + split; [exact (HS d Hd) | split; [exact Ha | split; [exact Ho | reflexivity]]]. + - right; exists l; split; [exact (HL l Hl) | reflexivity]. + Qed. - Lemma mem_wDecs : forall g FDefs Slots rc S FS pi x, - T.PkgSet.In x (wDecs g FDefs Slots rc S FS pi) <-> - exists m v k u f e feat d, ParentRel.In (((m, v), k), u) pi /\ - parentsb FDefs Slots rc S FS (m, v) k = true /\ - FDefRel.In (((m, v), f), e) FDefs /\ - entryFeatD e = Some (kAlias k, feat) /\ - FSet.In f (fsAt FS (m, v)) /\ - SlotRel.In ((m, v), d) Slots /\ sKey d = k /\ - slotActive rc (m, v) d = true /\ - x = (NPlus.CDec m (g v) f d feat, VPlus.WClass (g u)). - Proof. - intros g FDefs Slots rc S FS pi x; unfold wDecs. - rewrite SOparp.mem_unionMap; split. - - intros [[[[m v] k] u] [Hin Hx]]; cbn beta iota in Hx. - destruct (parentsb FDefs Slots rc S FS (m, v) k) eqn:Eb; - [| exfalso; exact (SOfp.empty_in _ Hx)]. - apply SOfp.mem_unionMap in Hx; destruct Hx as [[[q f] e] [Hf Hx]]. - cbn beta iota in Hx. - destruct (entryFeatD e) as [[a' feat] |] eqn:Ee; - [| exfalso; exact (SOslp.empty_in _ Hx)]. - rewrite SOslp.in_if_empty, !andb_true_iff, PkgEqb.eqb_true_iff, - NEqb.eqb_true_iff, FSet.mem_spec in Hx. - destruct Hx as [[[-> ->] Em] Hx]. - apply SOslp.mem_map in Hx; destruct Hx as [[q d] [Hq ->]]. - apply mem_slotsAtKey in Hq; destruct Hq as [Hs [-> [Ha Hact]]]. - exists m, v, k, u, f, e, feat, d; repeat split; assumption. - - intros [m [v [k [u [f [e [feat [d - [Hin [Eb [Hf [Ee [Em [Hs [Ha [Hact ->]]]]]]]]]]]]]]]]. - exists (((m, v), k), u); split; [exact Hin | cbn beta iota]. - rewrite Eb; apply SOfp.mem_unionMap. - exists (((m, v), f), e); split; [exact Hf | cbn beta iota]. - rewrite Ee, PkgEqb.eqb_refl, NEqb.eqb_refl, - (proj2 (FSet.mem_spec _ _) Em); cbn [andb]. - apply SOslp.mem_map; exists ((m, v), d); split; - [apply mem_slotsAtKey; repeat split; assumption | reflexivity]. - Qed. + Lemma dep_featP_mono : + forall g R R' support support' FDefs FDefs' Slots Slots' Links Links' + dflt rc rootFeats rootFeats' m f gr v, + (forall d, SlotRel.In ((m, v), d) Slots -> + SlotRel.In ((m, v), d) Slots') -> + (forall d, SlotRel.In ((m, v), d) Slots -> + evalReq R (sTarget d) (sReq d) = evalReq R' (sTarget d) (sReq d)) -> + (SupportSet.In ((m, v), f) support -> SupportSet.In ((m, v), f) support') -> + (forall e, FDefRel.In (((m, v), f), e) FDefs -> + FDefRel.In (((m, v), f), e) FDefs') -> + forall h, + T.DependeesSet.In h + (dependees g R support FDefs Slots Links dflt rc rootFeats + (NPlus.CFeatP m f gr, VPlus.WOrig v)) -> + T.DependeesSet.In h + (dependees g R' support' FDefs' Slots' Links' dflt rc rootFeats' + (NPlus.CFeatP m f gr, VPlus.WOrig v)). + Proof. + intros * HS Hev Hsp HF h Hh. + apply mem_dep_featP in Hh; apply mem_dep_featP. + destruct Hh as [Hg [Hs Hh]]; split; [exact Hg | split; [exact (Hsp Hs) |]]. + destruct Hh as [Hh | [e0 [Hfd Hc]]]; [left; exact Hh | right]. + exists e0; split; [exact (HF e0 Hfd) |]. + destruct Hc as [[f' [He ->]] | [[a [d [Ha [Hd [Hal [Hact ->]]]]]] + | [a [feat [d [Ha [Hd [Hal [Hact ->]]]]]]]]]. + - left; exists f'; split; [exact He | reflexivity]. + - right; left; exists a, d; rewrite <- (Hev d Hd). + split; [exact Ha | split; [exact (HS d Hd) | + split; [exact Hal | split; [exact Hact | reflexivity]]]]. + - right; right; exists a, feat, d; rewrite <- (Hev d Hd). + split; [exact Ha | split; [exact (HS d Hd) | + split; [exact Hal | split; [exact Hact | reflexivity]]]]. + Qed. - Definition coreRes (g : V.t -> G.t) (FDefs : FDefRel.t) - (Slots : SlotRel.t) (Links : LinkRel.t) - (rc : Pkg.t) (S : PkgSet.t) - (FS : FeaturedSet.t) (pi : ParentRel.t) : T.PkgSet.t := - T.PkgSet.add transRoot - (T.PkgSet.union (crateReal g S) - (T.PkgSet.union (wFeats g FS) - (T.PkgSet.union - (wSlots g FDefs Slots rc S FS pi) - (T.PkgSet.union - (wDecs g FDefs Slots rc S FS pi) - (linkReal g S Links))))). + Lemma dep_crate_agree : + forall g R R' support support' FDefs FDefs' Slots Slots' Links Links' + dflt rc rootFeats rootFeats' m gr v, + (forall d, SlotRel.In ((m, v), d) Slots <-> + SlotRel.In ((m, v), d) Slots') -> + (forall d, SlotRel.In ((m, v), d) Slots -> + evalReq R (sTarget d) (sReq d) = evalReq R' (sTarget d) (sReq d)) -> + (PkgSet.In (m, v) R <-> PkgSet.In (m, v) R') -> + (forall l, LinkRel.In ((m, v), l) Links <-> LinkRel.In ((m, v), l) Links') -> + dependees g R support FDefs Slots Links dflt rc rootFeats + (NPlus.CCrate m gr, VPlus.WOrig v) = + dependees g R' support' FDefs' Slots' Links' dflt rc rootFeats' + (NPlus.CCrate m gr, VPlus.WOrig v). + Proof. + intros * HS Hev HR HL; apply T.DependeesSet.ext; intro h; split. + - apply dep_crate_mono; + [intros d Hd; apply HS; exact Hd | exact Hev + | apply HR | intros l Hl; apply HL; exact Hl]. + - apply dep_crate_mono; + [intros d Hd; apply HS; exact Hd + | intros d Hd; symmetry; apply Hev; apply HS; exact Hd + | apply HR | intros l Hl; apply HL; exact Hl]. + Qed. - Lemma mem_coreRes : - forall g FDefs Slots Links rc S FS pi x, - T.PkgSet.In x - (coreRes g FDefs Slots Links rc S FS pi) <-> - x = transRoot \/ T.PkgSet.In x (crateReal g S) \/ - T.PkgSet.In x (wFeats g FS) \/ - T.PkgSet.In x (wSlots g FDefs Slots rc S FS pi) \/ - T.PkgSet.In x (wDecs g FDefs Slots rc S FS pi) \/ - T.PkgSet.In x (linkReal g S Links). - Proof. - intros; unfold coreRes. - rewrite T.PkgSet.add_spec, !T.PkgSet.union_spec; reflexivity. - Qed. + Lemma dep_featP_agree : + forall g R R' support support' FDefs FDefs' Slots Slots' Links Links' + dflt rc rootFeats rootFeats' m f gr v, + (forall d, SlotRel.In ((m, v), d) Slots <-> + SlotRel.In ((m, v), d) Slots') -> + (forall d, SlotRel.In ((m, v), d) Slots -> + evalReq R (sTarget d) (sReq d) = evalReq R' (sTarget d) (sReq d)) -> + (SupportSet.In ((m, v), f) support <-> SupportSet.In ((m, v), f) support') -> + (forall e, FDefRel.In (((m, v), f), e) FDefs <-> + FDefRel.In (((m, v), f), e) FDefs') -> + dependees g R support FDefs Slots Links dflt rc rootFeats + (NPlus.CFeatP m f gr, VPlus.WOrig v) = + dependees g R' support' FDefs' Slots' Links' dflt rc rootFeats' + (NPlus.CFeatP m f gr, VPlus.WOrig v). + Proof. + intros * HS Hev Hsp HF; apply T.DependeesSet.ext; intro h; split. + - apply dep_featP_mono; + [intros d Hd; apply HS; exact Hd | exact Hev + | apply Hsp | intros e He; apply HF; exact He]. + - apply dep_featP_mono; + [intros d Hd; apply HS; exact Hd + | intros d Hd; symmetry; apply Hev; apply HS; exact Hd + | apply Hsp | intros e He; apply HF; exact He]. + Qed. - Lemma core_shape : - forall g FDefs Slots Links rc S FS pi n w, - T.PkgSet.In (n, w) - (coreRes g FDefs Slots Links rc S FS pi) <-> - match n with - | NPlus.CRoot => w = VPlus.WUnit - | NPlus.CCrate m gr => - exists v, w = VPlus.WOrig v /\ PkgSet.In (m, v) S /\ gr = g v - | NPlus.CFeatP m f gr => - exists v fs, w = VPlus.WOrig v /\ FeaturedSet.In ((m, v), fs) FS /\ - FSet.In f fs /\ gr = g v - | NPlus.CSlot m gr d => - exists v u, w = VPlus.WClass (g u) /\ gr = g v /\ - ParentRel.In (((m, v), sKey d), u) pi /\ - parentsb FDefs Slots rc S FS (m, v) (sKey d) = true /\ - SlotRel.In ((m, v), d) Slots /\ slotActive rc (m, v) d = true - | NPlus.CDec m gr f d feat => - exists v u e, w = VPlus.WClass (g u) /\ gr = g v /\ - ParentRel.In (((m, v), sKey d), u) pi /\ - parentsb FDefs Slots rc S FS (m, v) (sKey d) = true /\ - SlotRel.In ((m, v), d) Slots /\ slotActive rc (m, v) d = true /\ - FDefRel.In (((m, v), f), e) FDefs /\ - entryFeatD e = Some (sAlias d, feat) /\ - FSet.In f (fsAt FS (m, v)) - | NPlus.CLink l => - exists m v, w = VPlus.WName (NPlus.CCrate m (g v)) /\ - LinkRel.In ((m, v), l) Links /\ PkgSet.In (m, v) S - end. - Proof. - intros g FDefs Slots Links rc S FS pi n w. - rewrite mem_coreRes, mem_crateReal, mem_wFeats, mem_wSlots, mem_wDecs, - mem_linkReal; unfold transRoot; split. - - intros [He | [He | [He | [He | [He | He]]]]]. - + injection He as -> ->; reflexivity. - + destruct He as [m [v [HS He]]]; injection He as -> ->. - exists v; auto. - + destruct He as [m [v [fs [f [Hfs [Hf He]]]]]]; injection He as -> ->. - exists v, fs; auto. - + destruct He as [m [v [k [u [d [Hpi [Eb [Hs [<- [Hact He]]]]]]]]]]. - injection He as -> ->; exists v, u; repeat split; assumption. - + destruct He as [m [v [k [u [f [e [feat [d - [Hpi [Eb [Hf [Ee [Em [Hs [<- [Hact He]]]]]]]]]]]]]]]]. - injection He as -> ->; exists v, u, e; repeat split; assumption. - + destruct He as [m [v [l [Hl [HS He]]]]]; injection He as -> ->. - exists m, v; auto. - - destruct n as [| m gr | m f gr | m gr d | m gr f d feat | l]; - cbn beta iota. - + intros ->; left; reflexivity. - + intros [v [-> [HS ->]]]; right; left; exists m, v; auto. - + intros [v [fs [-> [Hfs [Hf ->]]]]]. - right; right; left; exists m, v, fs, f; auto. - + intros [v [u [-> [-> [Hpi [Eb [Hs Hact]]]]]]]. - right; right; right; left; exists m, v, (sKey d), u, d. - repeat split; assumption. - + intros [v [u [e [-> [-> [Hpi [Eb [Hs [Hact [Hf [Ee Hfs]]]]]]]]]]]. - right; right; right; right; left. - exists m, v, (sKey d), u, f, e, feat, d; repeat split; assumption. - + intros [m [v [-> [Hl HS]]]]; right; right; right; right; right. - exists m, v, l; auto. - Qed. + Theorem dependees_lookupRoot : + forall g R support FDefs Slots Links dflt rc rootFeats, + dependees g R support FDefs Slots Links dflt rc rootFeats rootPkg = + dependees g PkgSet.empty SupportSet.empty FDefRel.empty SlotRel.empty + LinkRel.empty dflt rc rootFeats rootPkg. + Proof. reflexivity. Qed. - Lemma fsAt_mem - {R support FDefs Slots Links g dflt rc rootFeats S FS pi} : - IsResolution R support FDefs Slots Links g dflt rc - rootFeats S FS pi -> - forall p, PkgSet.In p S -> FeaturedSet.In (p, fsAt FS p) FS. - Proof. - intros Hres p Hp; destruct (res_fs_total Hres Hp) as [fs Hfs]. - rewrite (fsAt_in FS p fs (res_fs_functional Hres) Hfs); exact Hfs. - Qed. + Theorem dependees_lookupCrate : + forall g R support FDefs Slots Links dflt rc rootFeats m gr v, + dependees g R support FDefs Slots Links dflt rc rootFeats + (NPlus.CCrate m gr, VPlus.WOrig v) = + dependees g (realPreimage R (reads Slots (m, v))) SupportSet.empty + FDefRel.empty (SlotFibred.tailFibre Slots (m, v)) + (LinkFibred.tailFibre Links (m, v)) dflt rc rootFeats + (NPlus.CCrate m gr, VPlus.WOrig v). + Proof. + intros; apply dep_crate_agree; + [intro d; apply in_slotFibre | apply evalReq_reads + | apply in_realPreimage_own | intro l; apply in_linkFibre]. + Qed. - Lemma parent_pick - {R support FDefs Slots Links g dflt rc rootFeats S FS pi} : - IsResolution R support FDefs Slots Links g dflt rc - rootFeats S FS pi -> - forall m v d, PkgSet.In (m, v) S -> - SlotRel.In ((m, v), d) Slots -> - slotActive rc (m, v) d = true -> - (sOptional d = false \/ - Activated FDefs (fsAt FS (m, v)) (m, v) (sAlias d)) -> - exists u, ParentRel.In (((m, v), sKey d), u) pi /\ - parentsb FDefs Slots rc S FS (m, v) (sKey d) = true /\ - VSet.In u (evalReq R (sTarget d) (sReq d)) /\ - PkgSet.In (sTarget d, u) S /\ - FSet.Subset (slotRequests d dflt) (fsAt FS (sTarget d, u)). - Proof. - intros Hres m v d HS Hd Hact Hopt. - destruct (res_slot_closure Hres HS (fsAt_mem Hres _ HS) Hd Hact Hopt) - as [u [Hpi [Hrg [Htgt Hsub]]]]. - exists u; repeat split; try assumption. - - apply parentsb_iff; split; [exact HS |]. - exists d; repeat split; assumption. - - apply mem_evalReq; split; [exact (res_subset Hres Htgt) | exact Hrg]. - - exact (Hsub _ (fsAt_mem Hres _ Htgt)). - Qed. + Theorem dependees_lookupFeatP : + forall g R support FDefs Slots Links dflt rc rootFeats m f gr v, + dependees g R support FDefs Slots Links dflt rc rootFeats + (NPlus.CFeatP m f gr, VPlus.WOrig v) = + dependees g (realPreimage R (reads Slots (m, v))) + (SupportFibred.tailFibre support (m, v)) (fdefFibre FDefs (m, v)) + (SlotFibred.tailFibre Slots (m, v)) LinkRel.empty dflt rc rootFeats + (NPlus.CFeatP m f gr, VPlus.WOrig v). + Proof. + intros; apply dep_featP_agree; + [intro d; apply in_slotFibre | apply evalReq_reads + | apply in_supportFibre | intro e; apply in_fdefFibre]. + Qed. + + Theorem dependees_lookupSlot : + forall g R support FDefs Slots Links dflt rc rootFeats m gr0 d gr u, + SlotRel.In ((m, u), d) Slots -> g u = gr0 -> + slotActive rc (m, u) d = true -> + dependees g R support FDefs Slots Links dflt rc rootFeats + (NPlus.CSlot m gr0 d, VPlus.WClass gr) = + dependees g (realPreimage R (NSet.singleton (sTarget d))) + SupportSet.empty FDefRel.empty (SlotFibred.tailFibre Slots (m, u)) + LinkRel.empty dflt rc rootFeats (NPlus.CSlot m gr0 d, VPlus.WClass gr). + Proof. + intros g R support FDefs Slots Links dflt rc rootFeats m gr0 d gr u + Hs Hg Hact. + destruct (slotOwnedb_witness g Slots rc m gr0 d u Hs Hg Hact) + as [E1 E2]. + cbn [dependees]; rewrite E1, E2. + rewrite evalReq_realPreimage; + [reflexivity | apply NSet.singleton_spec; reflexivity]. + Qed. - Lemma parent_slot - {R support FDefs Slots Links g dflt rc rootFeats S FS pi} : - SiteFunctional Slots -> - IsResolution R support FDefs Slots Links g dflt rc - rootFeats S FS pi -> - forall m v k u, ParentRel.In (((m, v), k), u) pi -> - parentsb FDefs Slots rc S FS (m, v) k = true -> - exists d, SlotRel.In ((m, v), d) Slots /\ sKey d = k /\ - slotActive rc (m, v) d = true /\ - VSet.In u (evalReq R (sTarget d) (sReq d)) /\ - PkgSet.In (sTarget d, u) S /\ - FSet.Subset (slotRequests d dflt) (fsAt FS (sTarget d, u)). - Proof. - intros Hsite Hres m v k u Hpi Eb. - apply parentsb_iff in Eb; destruct Eb as [HS [d [Hd [<- [Hact Hreq]]]]]. - destruct (parent_pick Hres m v d HS Hd Hact Hreq) - as [u0 [Hpi0 [_ [Hu0 [Htgt Hsub]]]]]. - rewrite (res_pi_functional Hres Hpi Hpi0). - exists d; repeat split; assumption. - Qed. + Theorem dependees_lookupDecision : + forall g R support FDefs Slots Links dflt rc rootFeats + m gr0 f d feat gr u e, + FDefRel.In (((m, u), f), e) FDefs -> + entryFeatD e = Some (sAlias d, feat) -> + SlotRel.In ((m, u), d) Slots -> g u = gr0 -> + slotActive rc (m, u) d = true -> + dependees g R support FDefs Slots Links dflt rc rootFeats + (NPlus.CDec m gr0 f d feat, VPlus.WClass gr) = + dependees g (realPreimage R (NSet.singleton (sTarget d))) + SupportSet.empty (fdefFibre FDefs (m, u)) + (SlotFibred.tailFibre Slots (m, u)) + LinkRel.empty dflt rc rootFeats + (NPlus.CDec m gr0 f d feat, VPlus.WClass gr). + Proof. + intros g R support FDefs Slots Links dflt rc rootFeats m gr0 f d feat gr + u e Hf Ee Hs Hg Hact. + destruct (decOwnedb_witness g FDefs Slots rc m gr0 f d feat u e + Hf Ee Hs Hg Hact) as [E1 E2]. + cbn [dependees]; rewrite E1, E2. + rewrite evalReq_realPreimage; + [reflexivity | apply NSet.singleton_spec; reflexivity]. + Qed. - Theorem cargo_completeness : - forall R support FDefs Slots Links g dflt rc rootFeats - S FS pi, - SiteFunctional Slots -> - IsResolution R support FDefs Slots Links g dflt rc - rootFeats S FS pi -> - T.IsResolution - (transReal g R support FDefs Slots Links rc) - (transDeps g R support FDefs Slots Links dflt rc - rootFeats) transRoot - (coreRes g FDefs Slots Links rc S FS pi). - Proof. - intros R support FDefs Slots Links g dflt rc rootFeats - S FS pi Hsite Hres. - assert (HfsAt := fsAt_mem Hres). - assert (Hpick := parent_pick Hres). - assert (Hslot := parent_slot Hsite Hres). - destruct rc as [rn rv]. - destruct Hres as [Hsub Hroot Hrootf Hdom Htot Hfun Hclass Hsupp - Hpifun _ Hslotc Hfsame Hfdep Hlinks]. - constructor. - - intros [n w] Hx; apply core_shape in Hx; apply real_shape. - destruct n as [| m gr | m f gr | m gr d | m gr f d feat | l]; - cbn beta iota in Hx |- *. - + exact Hx. - + destruct Hx as [v [-> [HS ->]]]; exists v. - repeat split; exact (Hsub _ HS). - + destruct Hx as [v [fs [-> [Hfs [Hf ->]]]]]; exists v. - repeat split; exact (Hsupp _ _ _ Hfs Hf). - + destruct Hx as [v [u [-> [-> [Hpi [Eb [Hd Hact]]]]]]]. - destruct (Hslot _ _ _ _ Hpi Eb) as [d' [Hd' [Ha' [_ [Hu _]]]]]. - rewrite (Hsite (m, v) d' d Hd' Hd Ha') in Hu. - split; [exists v | exists u]; auto. - + destruct Hx - as [v [u [e [-> [-> [Hpi [Eb [Hd [Hact [Hf [Ee _]]]]]]]]]]]. - destruct (Hslot _ _ _ _ Hpi Eb) as [d' [Hd' [Ha' [_ [Hu _]]]]]. - rewrite (Hsite (m, v) d' d Hd' Hd Ha') in Hu. - split; [exists v, e; repeat split; assumption | exists u; auto]. - + destruct Hx as [m [v [-> [Hl HS]]]]; exists m, v. - repeat split; [exact Hl | exact (Hsub _ HS)]. - - apply mem_coreRes; left; reflexivity. - - intros p Hp n vs Hed. - apply mem_transDeps in Hed; destruct Hed as [_ Hh]. - destruct p as [[| m gr | m f gr | m gr1 d | m gr1 f d feat | l] - [| v0 | gr0 | q]]; - try (rewrite dep_inert in Hh by exact I; - exfalso; exact (T.DependeesSet.empty_spec Hh)). - + apply mem_dep_root in Hh. - destruct Hh as [He | [f [Hf He]]]; injection He as E1 E2; - subst n vs; exists (VPlus.WOrig rv); - (split; [apply T.VSet.singleton_spec; reflexivity |]); - apply core_shape. - * exists rv; repeat split; exact Hroot. - * exists rv, (fsAt FS (rn, rv)); repeat split; - [exact (HfsAt _ Hroot) | exact (Hrootf _ (HfsAt _ Hroot) f Hf)]. - + apply mem_dep_crate in Hh. - apply core_shape in Hp; cbn beta iota in Hp. - destruct Hp as [v1 [Ev [HS _]]]; injection Ev as Ev; subst v1. - destruct Hh - as [<- [_ [[d [Hd [Hact [Hopt He]]]] | [l [Hl He]]]]]; - injection He as E1 E2; subst n vs. - * destruct (Hpick _ _ _ HS Hd Hact (or_introl Hopt)) - as [u [Hpi [Eb [Hu [Htgt Hss]]]]]. - exists (VPlus.WClass (g u)); split. - { apply mem_gransOf; exists u; split; - [exact Hu | reflexivity]. } - apply core_shape; exists v0, u; repeat split; assumption. - * exists (VPlus.WName (NPlus.CCrate m (g v0))); split; - [apply T.VSet.singleton_spec; reflexivity |]. - apply core_shape; exists m, v0; repeat split; assumption. - + apply mem_dep_featP in Hh. - apply core_shape in Hp; cbn beta iota in Hp. - destruct Hp as [v1 [fs [Ev [Hfs [Hf _]]]]]. - injection Ev as Ev; subst v1. - assert (Efs : fsAt FS (m, v0) = fs) - by exact (fsAt_in FS (m, v0) fs Hfun Hfs). - assert (HS : PkgSet.In (m, v0) S) by exact (Hdom _ _ Hfs). - destruct Hh as [_ [_ [He | [e0 [Hfd Hcase]]]]]. - * injection He as E1 E2; subst n vs. - exists (VPlus.WOrig v0); split; - [apply T.VSet.singleton_spec; reflexivity |]. - apply core_shape; exists v0; repeat split; exact HS. - * destruct Hcase as [[f' [Ee He]] | [Hcase | Hcase]]. - -- injection He as E1 E2; subst n vs e0. - exists (VPlus.WOrig v0); split; - [apply T.VSet.singleton_spec; reflexivity |]. - apply core_shape; exists v0, fs; repeat split; - [exact Hfs | exact (Hfsame _ _ _ _ Hfs Hf Hfd)]. - -- destruct Hcase as [a [d [Ea [Hd [Ha [Hact He]]]]]]; subst a. - injection He as E1 E2; subst n vs. - assert (Hactd : Activated FDefs (fsAt FS (m, v0)) (m, v0) - (sAlias d)). - { rewrite Efs; exists f; split; [exact Hf |]. - destruct e0 as [f0 | a0 | a0 feat0 | a0 feat0]; - cbn [entryActivates] in Ea; try discriminate; - injection Ea as Ea; subst a0; eauto. } - destruct (Hpick _ _ _ HS Hd Hact (or_intror Hactd)) - as [u [Hpi [Eb [Hu [Htgt Hss]]]]]. - exists (VPlus.WClass (g u)); split. - { apply mem_gransOf; exists u; split; - [exact Hu | reflexivity]. } - apply core_shape; exists v0, u; repeat split; assumption. - -- destruct Hcase as [a [feat [d [Ea [Hd [Ha [Hact He]]]]]]]; - subst a. - injection He as E1 E2; subst n vs. - assert (Hactd : Activated FDefs (fsAt FS (m, v0)) (m, v0) - (sAlias d)). - { rewrite Efs; exists f; split; [exact Hf |]. - destruct e0 as [f0 | a0 | a0 feat0 | a0 feat0]; - cbn [entryFeatD] in Ea; try discriminate; - injection Ea as Ea1 Ea2; subst a0 feat0; eauto. } - destruct (Hpick _ _ _ HS Hd Hact (or_intror Hactd)) - as [u [Hpi [Eb [Hu [Htgt Hss]]]]]. - exists (VPlus.WClass (g u)); split. - { apply mem_gransOf; exists u; split; - [exact Hu | reflexivity]. } - apply core_shape; exists v0, u, e0; repeat split; - try assumption. - rewrite Efs; exact Hf. - + apply mem_dep_slot in Hh. - destruct Hh as [_ [u0 [Hu0 [Hgu Hcase]]]]. - apply core_shape in Hp; cbn beta iota in Hp. - destruct Hp as [v [u [Eu [Egr [Hpi [Eb [Hd Hact]]]]]]]. - injection Eu as ->. - destruct (Hslot _ _ _ _ Hpi Eb) - as [d' [Hd' [Ha' [Hact' [Hu' [Htgt Hss]]]]]]. - assert (Ed : d' = d) by exact (Hsite (m, v) d' d Hd' Hd Ha'). - subst d'. - destruct Hcase as [He | [f0 [Hf0 He]]]; injection He as E1 E2; - subst n vs; exists (VPlus.WOrig u); - (split; [apply mem_inGran; exists u; auto |]); apply core_shape. - * exists u; repeat split; assumption. - * exists u, (fsAt FS (sTarget d, u)); repeat split; try assumption; - [exact (HfsAt _ Htgt) | exact (Hss _ Hf0)]. - + apply mem_dep_dec in Hh. - destruct Hh as [_ [u0 [Hu0 [Hgu Hcase]]]]. - apply core_shape in Hp; cbn beta iota in Hp. - destruct Hp as [v [u [e [Eu [Egr [Hpi [Eb [Hd [Hact - [Hfd2 [Ee2 Hf]]]]]]]]]]]. - injection Eu as ->; subst gr1. - assert (HSnv : PkgSet.In (m, v) S) - by (apply parentsb_iff in Eb; exact (proj1 Eb)). - destruct (Hslot _ _ _ _ Hpi Eb) - as [d' [Hd' [Ha' [Hact' [Hu' [Htgt Hss]]]]]]. - assert (Ed : d' = d) by exact (Hsite (m, v) d' d Hd' Hd Ha'). - subst d'. - destruct Hcase as [He | He]; injection He as E1 E2; subst n vs. - * exists (VPlus.WClass (g u)); split; - [apply T.VSet.singleton_spec; reflexivity |]. - apply core_shape; exists v, u; repeat split; assumption. - * exists (VPlus.WOrig u); split; [apply mem_inGran; exists u; auto |]. - apply core_shape; exists u, (fsAt FS (sTarget d, u)); - repeat split; try assumption; [exact (HfsAt _ Htgt) |]. - assert (Hor : - FDefRel.In (((m, v), f), FEntry.EDepFeat (sAlias d) feat) - FDefs \/ - FDefRel.In (((m, v), f), FEntry.EWeakFeat (sAlias d) feat) - FDefs). - { destruct e as [f0 | a0 | a0 feat0 | a0 feat0]; - cbn [entryFeatD] in Ee2; try discriminate; - injection Ee2 as Ee1 Ee3; subst a0 feat0; - [left | right]; exact Hfd2. } - exact (Hfdep (m, v) (fsAt FS (m, v)) f (sAlias d) feat - (HfsAt _ HSnv) Hf Hor d u Hd eq_refl Hpi - (fsAt FS (sTarget d, u)) (HfsAt _ Htgt)). - - intros n w w' Hw Hw'. - apply core_shape in Hw; apply core_shape in Hw'. - destruct n as [ | m gr | m f gr | m gr d | m gr f d feat | l ]; - cbn beta iota in Hw, Hw'. - + subst w w'; reflexivity. - + destruct Hw as [v [-> [HS Eg]]]; - destruct Hw' as [v' [-> [HS' Eg']]]. - destruct (V.eq_dec v v') as [E | NE]; - [rewrite E; reflexivity |]. - exfalso; apply (Hclass m v v' HS HS' NE); congruence. - + destruct Hw as [v [fs [-> [Hfs [Hf Eg]]]]]; - destruct Hw' as [v' [fs' [-> [Hfs' [Hf' Eg']]]]]. - destruct (V.eq_dec v v') as [E | NE]; - [rewrite E; reflexivity |]. - exfalso; apply (Hclass m v v' (Hdom _ _ Hfs) (Hdom _ _ Hfs') NE); - congruence. - + destruct Hw as [v [u [-> [Egr [Hpi [Eb _]]]]]]; - destruct Hw' as [v' [u' [-> [Egr' [Hpi' [Eb' _]]]]]]. - apply parentsb_iff in Eb; apply parentsb_iff in Eb'. - destruct (V.eq_dec v v') as [<- | NE]; - [| exfalso; apply (Hclass m v v' (proj1 Eb) (proj1 Eb') NE); - congruence]. - rewrite (Hpifun (m, v) (sKey d) u u' Hpi Hpi'); reflexivity. - + destruct Hw as [v [u [e [-> [Egr [Hpi [Eb _]]]]]]]; - destruct Hw' as [v' [u' [e' [-> [Egr' [Hpi' [Eb' _]]]]]]]. - apply parentsb_iff in Eb; apply parentsb_iff in Eb'. - destruct (V.eq_dec v v') as [<- | NE]; - [| exfalso; apply (Hclass m v v' (proj1 Eb) (proj1 Eb') NE); - congruence]. - rewrite (Hpifun (m, v) (sKey d) u u' Hpi Hpi'); reflexivity. - + destruct Hw as [m [v [-> [Hl HS]]]]; - destruct Hw' as [m' [v' [-> [Hl' HS']]]]. - assert (E := Hlinks (m, v) (m', v') l HS HS' Hl Hl'). - injection E as <- <-; reflexivity. - Qed. + End Lookup. - Theorem decodeS_coreRes : forall g FDefs Slots Links rc S FS pi, - decodeS (coreRes g FDefs Slots Links rc S FS pi) = S. + Theorem decodeS_coreResolution : forall g FDefs Slots Links rc S FS pi, + decodeS (coreResolution g FDefs Slots Links rc S FS pi) = S. Proof. intros g FDefs Slots Links rc S FS pi; apply PkgSet.ext; intros [m v]. rewrite mem_decodeS; split. @@ -2965,12 +2837,12 @@ Module Cargo (N V F G CfgS Src : UsualOrderedType) (PM : SemverMatch V). repeat split; exact HS. Qed. - Lemma featsAt_coreRes + Lemma featsAt_coreResolution {R support FDefs Slots Links g dflt rc rootFeats S FS pi} : IsResolution R support FDefs Slots Links g dflt rc rootFeats S FS pi -> forall p, PkgSet.In p S -> - featsAt (coreRes g FDefs Slots Links rc S FS pi) p = fsAt FS p. + featsAt (coreResolution g FDefs Slots Links rc S FS pi) p = fsAt FS p. Proof. intros Hres [m v] Hp. apply FSet.ext; intro f; rewrite mem_featsAt; split. @@ -2981,33 +2853,31 @@ Module Cargo (N V F G CfgS Src : UsualOrderedType) (PM : SemverMatch V). repeat split; [exact (fsAt_mem Hres _ Hp) | exact Hf]. Qed. - Theorem decodeFS_coreRes : + Theorem decodeFS_coreResolution : forall R support FDefs Slots Links g dflt rc rootFeats S FS pi, IsResolution R support FDefs Slots Links g dflt rc rootFeats S FS pi -> - decodeFS (coreRes g FDefs Slots Links rc S FS pi) = FS. + decodeFS (coreResolution g FDefs Slots Links rc S FS pi) = FS. Proof. intros R support FDefs Slots Links g dflt rc rootFeats S FS pi Hres. apply FeaturedSet.ext; intros [p fs]. - rewrite mem_decodeFS, decodeS_coreRes; split. - - intros [Hp ->]; rewrite (featsAt_coreRes Hres _ Hp). + rewrite mem_decodeFS, decodeS_coreResolution; split. + - intros [Hp ->]; rewrite (featsAt_coreResolution Hres _ Hp). exact (fsAt_mem Hres _ Hp). - intro Hfs; assert (Hp := res_fs_dom Hres Hfs). split; [exact Hp |]. - rewrite (featsAt_coreRes Hres _ Hp); symmetry. + rewrite (featsAt_coreResolution Hres _ Hp); symmetry. exact (fsAt_in FS p fs (res_fs_functional Hres) Hfs). Qed. - (* Only this direction holds: a core resolution may carry synthetic - packages the witness would not rebuild. *) - Theorem decodeParents_coreRes : + Theorem decodeParents_coreResolution : forall R support FDefs Slots Links g dflt rc rootFeats S FS pi, SiteFunctional Slots -> IsResolution R support FDefs Slots Links g dflt rc rootFeats S FS pi -> decodeParents FDefs Slots rc - (coreRes g FDefs Slots Links rc S FS pi) = pi. + (coreResolution g FDefs Slots Links rc S FS pi) = pi. Proof. intros R support FDefs Slots Links g dflt rc rootFeats S FS pi Hsite Hres. @@ -3046,7 +2916,7 @@ Module Cargo (N V F G CfgS Src : UsualOrderedType) (PM : SemverMatch V). assert (d' = d) by exact (Hsite (m, v) d' d Hd' Hd Ha'). subst d'. exists (g v), (g u), d; repeat split; try assumption; - [| | rewrite (featsAt_coreRes Hres _ HS); exact Hreq |]; + [| | rewrite (featsAt_coreResolution Hres _ HS); exact Hreq |]; apply core_shape. + exists v, u; repeat split; assumption. + exists v; repeat split; exact HS. diff --git a/theories/Complexity.v b/theories/Complexity.v index 542b7aa..cfed57b 100644 --- a/theories/Complexity.v +++ b/theories/Complexity.v @@ -353,9 +353,6 @@ Module Complexity (N V : UsualOrderedType) (X : UsualOrderedType). right; apply List.in_map_iff; exists l; split; [reflexivity | exact Hl]. Qed. - Theorem reduceReal_root : forall phi, T.PkgSet.In root (reduceReal phi). - Proof. intro phi; apply mem_reduceReal; left; reflexivity. Qed. - Theorem reduceDeps_functionalInName : forall phi, T.FunctionalInName (reduceDeps phi). Proof. diff --git a/theories/Conflict.v b/theories/Conflict.v index 3b5a5e0..d84d4f6 100644 --- a/theories/Conflict.v +++ b/theories/Conflict.v @@ -193,10 +193,6 @@ Module Conflict (N V : UsualOrderedType). tauto. Qed. - Definition reduce (R : PkgSet.t) (D : C.DepRel.t) (G : ConflictRel.t) : - T.PkgSet.t * T.DepRel.t := - (reduceReal R D G, reduceDeps R D G). - Definition tryInvPkg (p : T.Pkg.t) : option Pkg.t := match p with | (n, Version.Orig v) => Some (n, v) diff --git a/theories/ConflictClass.v b/theories/ConflictClass.v index 0b8125f..7ca2094 100644 --- a/theories/ConflictClass.v +++ b/theories/ConflictClass.v @@ -188,10 +188,6 @@ Module ConflictClass (N V : UsualOrderedType). reflexivity. Qed. - Definition reduce (R : PkgSet.t) (D : C.DepRel.t) (Om : InClassRel.t) : - T.PkgSet.t * T.DepRel.t := - (reduceReal R Om, reduceDeps D Om). - Definition tryInvPkg (p : T.Pkg.t) : option Pkg.t := match p with | (Name.Orig n, Version.Orig v) => Some (n, v) diff --git a/theories/Debian.v b/theories/Debian.v index 5c37b4d..6d8ad86 100644 --- a/theories/Debian.v +++ b/theories/Debian.v @@ -1696,15 +1696,6 @@ Module Debian (N V : UsualOrderedType) (NG : NameGroup N). rewrite (Huniq n1 v1 v2 Hp1 Hp2); reflexivity. Qed. - Corollary debianResolution_coreResolution : forall R D Rec Pi G S, - debianResolution (coreResolution R D Rec Pi G S) = S. - Proof. - intros R D Rec Pi G S; apply PkgSet.ext; intros [n v]. - rewrite mem_debianResolution, mem_coreResolution. - unfold embedPkg; cbn [fst snd]. - split; [intro H; inversion H; assumption | apply CoreReal]. - Qed. - Module Lookup. Module SOcn := SetOps ClauseElt N Deps NSet. @@ -2365,4 +2356,13 @@ Module Debian (N V : UsualOrderedType) (NG : NameGroup N). Qed. End Lookup. + + Corollary debianResolution_coreResolution : forall R D Rec Pi G S, + debianResolution (coreResolution R D Rec Pi G S) = S. + Proof. + intros R D Rec Pi G S; apply PkgSet.ext; intros [n v]. + rewrite mem_debianResolution, mem_coreResolution. + unfold embedPkg; cbn [fst snd]. + split; [intro H; inversion H; assumption | apply CoreReal]. + Qed. End Debian. diff --git a/theories/DebianMA.v b/theories/DebianMA.v index eb505e3..67c4036 100644 --- a/theories/DebianMA.v +++ b/theories/DebianMA.v @@ -132,8 +132,6 @@ Module DebianMA (N V : UsualOrderedType) (AP : ArchParam). Module Cls := FSetUOT ClsElt. Module ClsFibred := FibredRel Pkg MCOT ClsElt Cls. - (* Total class lookup with default MANo; instances are expected to be - functional in the package. *) Definition classOf (M : Cls.t) (p : Pkg.t) : MAClass := match Cls.min_elt (ClsFibred.tailFibre M p) with | Some e => snd e @@ -775,10 +773,8 @@ Module DebianMA (N V : UsualOrderedType) (AP : ArchParam). PkgSet.In q (multiarchResolution S) -> PkgSet.In q R). { intros q Hq. rewrite mem_multiarchResolution in Hq. - apply Hsub in Hq. - unfold reduceReal in *; rewrite SOmr.mem_map in Hq. - destruct Hq as [p [HpR Hpe]]. - apply embedPkg_injective in Hpe; subst q; exact HpR. } + apply Hsub in Hq; unfold reduceReal in Hq. + exact (proj1 (SOmr.mem_map_inj _ _ _ embedPkg_injective) Hq). } constructor. - exact HinR. - rewrite mem_multiarchResolution; exact Hroot. @@ -888,11 +884,9 @@ Module DebianMA (N V : UsualOrderedType) (AP : ArchParam). intros R D Pi G M r S HS. destruct HS as [HSsub HSroot HScc HSca HSci HSvu]. constructor. - - intros x Hx. - unfold reduceReal in *; rewrite SOmr.mem_map in Hx; unfold reduceReal; rewrite SOmr.mem_map. - destruct Hx as [p [HpS Hpe]]; exists p; split; - [exact (HSsub p HpS) | exact Hpe]. - - unfold reduceReal; rewrite SOmr.mem_map; exists r; split; [exact HSroot | reflexivity]. + - exact (SOmr.map_mono _ _ _ _ HSsub (fun _ => eq_refl)). + - unfold reduceReal; apply (SOmr.mem_map_inj _ _ _ embedPkg_injective). + exact HSroot. - intros ph HphT A HA. unfold reduceReal in *; rewrite SOmr.mem_map in HphT; destruct HphT as [p [HpS Hpe]]; subst ph. rewrite mem_reduceDeps in HA. @@ -904,7 +898,8 @@ Module DebianMA (N V : UsualOrderedType) (AP : ArchParam). exists (reduceAtom (parch p) a); split. { apply List.in_map; exact Hat. } exists (embedPkg q); split. - { unfold reduceReal; rewrite SOmr.mem_map; exists q; split; [exact HqS | reflexivity]. } + { unfold reduceReal; apply (SOmr.mem_map_inj _ _ _ embedPkg_injective). + exact HqS. } exact (proj1 (match_transfer R Pi M (parch p) a q (HSsub q HqS)) HqM). - intros ph HphT ea x HaG [qh [HqhT [Hne [Hex HM]]]]. unfold reduceReal in *; rewrite SOmr.mem_map in HphT; destruct HphT as [p1 [Hp1S Hp1e]]. @@ -975,16 +970,6 @@ Module DebianMA (N V : UsualOrderedType) (AP : ArchParam). exact (HSvu (pn, pa) pv pv' HpS Hp'S). Qed. - Corollary multiarchResolution_reduceReal : forall S, - multiarchResolution (reduceReal S) = S. - Proof. - intro S; apply PkgSet.ext; intro q. - rewrite mem_multiarchResolution; unfold reduceReal; rewrite SOmr.mem_map. - split. - - intros [p [HpS Hp]]; rewrite (embedPkg_injective _ _ Hp); exact HpS. - - intro H; exists q; split; [exact H | reflexivity]. - Qed. - Corollary debian_ma_core_soundness : forall R D Rec Pi G M r S, Deb.T.IsResolution (Deb.reduceReal (reduceReal R) (reduceDeps D) (reduceRec Rec) @@ -1016,17 +1001,6 @@ Module DebianMA (N V : UsualOrderedType) (AP : ArchParam). (debian_ma_completeness R D Pi G M r S H)). Qed. - Corollary multiarchResolution_core : forall R D Rec Pi G M S, - multiarchResolution - (Deb.debianResolution - (Deb.coreResolution (reduceReal R) (reduceDeps D) (reduceRec Rec) - (reduceProv R Pi M) (reduceConf R G M) (reduceReal S))) = S. - Proof. - intros R D Rec Pi G M S. - rewrite Deb.debianResolution_coreResolution. - apply multiarchResolution_reduceReal. - Qed. - Module Lookup. Module NSet := FSetUOT N. Module PkgFibred := FibredRel NA V Pkg PkgSet. @@ -1176,7 +1150,6 @@ Module DebianMA (N V : UsualOrderedType) (AP : ArchParam). split; [exact He | reflexivity]. Qed. - (* The class table cut down to the packages reduceProv Rp Pis reads. *) Definition provClsPreimage (M : Cls.t) (Rp : PkgSet.t) (Pis : Prov.t) : Cls.t := clsPreimage M (PkgSet.union Rp (provOwners Pis)). @@ -1326,8 +1299,8 @@ Module DebianMA (N V : UsualOrderedType) (AP : ArchParam). apply Deb.SOew.filterMap_restrict. - exact (reduceProv_mono R Rp Pi Pis M Hr Hp). - intros [q [mx vt]] Hin Hf; cbn [fst snd Deb.aname Deb.aform] in Hf. - destruct (Deb.NEqb.eqb mx (m, x)) eqn:Hn; [| discriminate Hf]. - apply Deb.NEqb.eqb_true_iff in Hn as ->. + rewrite if_some_iff, Bool.andb_true_iff, Deb.NEqb.eqb_true_iff in Hf. + destruct Hf as [[-> _] _]. apply (reduceProv_node R Pi M ns Rp Pis q m x vt Hsl Hm); exact Hin. Qed. @@ -1663,7 +1636,7 @@ Module DebianMA (N V : UsualOrderedType) (AP : ArchParam). apply mem_clauseNames; exists a0; split; [exact Ha0 | reflexivity]. Qed. - Theorem versions_lookupOrigMA : forall R D Rec Pi G M (r : Pkg.t) + Theorem versions_lookupOrig : forall R D Rec Pi G M (r : Pkg.t) (n : N.t) (b : A.t), PkgSet.In r R -> (exists s h, @@ -1692,7 +1665,7 @@ Module DebianMA (N V : UsualOrderedType) (AP : ArchParam). injection Hq as -> ->; reflexivity. Qed. - Theorem versions_lookupOrigMA_pseudo : + Theorem versions_lookupOrig_pseudo : forall R D Rec Pi G M (n : N.t) (x : NameArch), (forall b, x <> QAArch b) -> (exists s h, @@ -1720,7 +1693,7 @@ Module DebianMA (N V : UsualOrderedType) (AP : ArchParam). exact (Hx b Hb). Qed. - Theorem dependees_lookupOrigMA : forall R D Rec Pi G M (p : Pkg.t), + Theorem dependees_lookupOrig : forall R D Rec Pi G M (p : Pkg.t), PkgSet.In p R -> Deb.dependees (reduceReal R) (reduceDeps D) (reduceRec Rec) (reduceProv R Pi M) @@ -1855,23 +1828,7 @@ Module DebianMA (N V : UsualOrderedType) (AP : ArchParam). split; [exact Hx | exact Hy]. Qed. - Theorem versions_lookupDisjunctMA : forall R D Rec Pi G M (p : Pkg.t) Al, - (exists s h, - Deb.T.DepRel.In - (s, (Deb.Name.Disjunct (reduceClause (parch p) Al), h)) - (Deb.reduceDeps (reduceReal R) (reduceDeps D) (reduceRec Rec) - (reduceProv R Pi M) (reduceConf R G M))) -> - Deb.versions (reduceReal R) (reduceDeps D) (reduceRec Rec) - (reduceProv R Pi M) - (reduceConf R G M) - (Deb.Name.Disjunct (reduceClause (parch p) Al)) = - Deb.versionsDisj (reduceClause (parch p) Al). - Proof. - intros R D Rec Pi G M p Al H. - exact (Deb.Lookup.versions_lookupDisjunct _ _ _ _ _ _ H). - Qed. - - Theorem dependees_lookupDisjunctMA : + Theorem dependees_lookupDisjunct : forall R D Rec Pi G M (p : Pkg.t) Al (a' : Deb.Atom.t), Deb.T.PkgSet.In (Deb.Name.Disjunct (reduceClause (parch p) Al), @@ -1907,7 +1864,7 @@ Module DebianMA (N V : UsualOrderedType) (AP : ArchParam). (preimageProvSubInst R Pi _) Hm). Qed. - Theorem versions_lookupSoftMA : forall R D Rec Pi G M (p : Pkg.t) Al, + Theorem versions_lookupSoft : forall R D Rec Pi G M (p : Pkg.t) Al, Deps.In (p, Al) Rec -> Deb.versions (reduceReal R) (reduceDeps D) (reduceRec Rec) (reduceProv R Pi M) (reduceConf R G M) @@ -1918,7 +1875,7 @@ Module DebianMA (N V : UsualOrderedType) (AP : ArchParam). rewrite (hasClauseb_reduceDeps Rec p Al HD); reflexivity. Qed. - Theorem dependees_lookupSoftMA : + Theorem dependees_lookupSoft : forall R D Rec Pi G M (p : Pkg.t) Al (a' : Deb.Atom.t), Deb.T.PkgSet.In (Deb.Name.Soft (reduceClause (parch p) Al), Deb.Version.Atom a') @@ -1952,7 +1909,7 @@ Module DebianMA (N V : UsualOrderedType) (AP : ArchParam). (preimageProvSubInst R Pi _) Hm). Qed. - Theorem versions_lookupSelectorAgreeMA : + Theorem versions_lookupSelectorAgree : forall R D Rec (D' Rec' : Deb.Deps.t) Pi G M (p : Pkg.t) (a : Atom.t), Deb.occursAtomb (Deb.allClauses (reduceDeps D) (reduceRec Rec)) (reduceAtom (parch p) a) = @@ -1986,7 +1943,7 @@ Module DebianMA (N V : UsualOrderedType) (AP : ArchParam). reflexivity. Qed. - Theorem dependees_lookupSelectorAgreeMA : + Theorem dependees_lookupSelectorAgree : forall R D Rec (D' Rec' : Deb.Deps.t) Pi G M (p : Pkg.t) (a : Atom.t) (y : Deb.Version.t), Deb.occursAtomb (Deb.allClauses (reduceDeps D) (reduceRec Rec)) @@ -2027,7 +1984,7 @@ Module DebianMA (N V : UsualOrderedType) (AP : ArchParam). reflexivity. Qed. - Theorem versions_lookupSelectorMA : + Theorem versions_lookupSelector : forall R D Rec Pi G M (p : Pkg.t) Al (a : Atom.t), Deps.In (p, Al) D -> List.In a Al -> Deb.versions (reduceReal R) (reduceDeps D) (reduceRec Rec) @@ -2041,7 +1998,7 @@ Module DebianMA (N V : UsualOrderedType) (AP : ArchParam). Deb.Conf.empty (Deb.Name.Selector (reduceAtom (parch p) a)). Proof. intros R D Rec Pi G M p Al a HD Ha. - apply versions_lookupSelectorAgreeMA. + apply versions_lookupSelectorAgree. rewrite (Deb.occursAtomb_allClausesL (reduceDeps D) (reduceRec Rec) (reduceAtom (parch p) a) (occursAtomb_reduceDeps D p Al a HD Ha)), @@ -2052,7 +2009,7 @@ Module DebianMA (N V : UsualOrderedType) (AP : ArchParam). reflexivity. Qed. - Theorem dependees_lookupSelectorMA : + Theorem dependees_lookupSelector : forall R D Rec Pi G M (p : Pkg.t) Al (a : Atom.t) (y : Deb.Version.t), Deps.In (p, Al) D -> List.In a Al -> Deb.dependees (reduceReal R) (reduceDeps D) (reduceRec Rec) @@ -2068,7 +2025,7 @@ Module DebianMA (N V : UsualOrderedType) (AP : ArchParam). (Deb.Name.Selector (reduceAtom (parch p) a), y). Proof. intros R D Rec Pi G M p Al a y HD Ha. - apply dependees_lookupSelectorAgreeMA. + apply dependees_lookupSelectorAgree. rewrite (Deb.occursAtomb_allClausesL (reduceDeps D) (reduceRec Rec) (reduceAtom (parch p) a) (occursAtomb_reduceDeps D p Al a HD Ha)), @@ -2079,7 +2036,7 @@ Module DebianMA (N V : UsualOrderedType) (AP : ArchParam). reflexivity. Qed. - Theorem versions_lookupSelectorRecMA : + Theorem versions_lookupSelectorRec : forall R D Rec Pi G M (p : Pkg.t) Al (a : Atom.t), Deps.In (p, Al) Rec -> List.In a Al -> Deb.versions (reduceReal R) (reduceDeps D) (reduceRec Rec) @@ -2093,7 +2050,7 @@ Module DebianMA (N V : UsualOrderedType) (AP : ArchParam). Deb.Conf.empty (Deb.Name.Selector (reduceAtom (parch p) a)). Proof. intros R D Rec Pi G M p Al a HRec Ha. - apply versions_lookupSelectorAgreeMA. + apply versions_lookupSelectorAgree. rewrite (Deb.occursAtomb_allClausesR (reduceDeps D) (reduceRec Rec) (reduceAtom (parch p) a) (occursAtomb_reduceDeps Rec p Al a HRec Ha)), @@ -2104,7 +2061,7 @@ Module DebianMA (N V : UsualOrderedType) (AP : ArchParam). reflexivity. Qed. - Theorem dependees_lookupSelectorRecMA : + Theorem dependees_lookupSelectorRec : forall R D Rec Pi G M (p : Pkg.t) Al (a : Atom.t) (y : Deb.Version.t), Deps.In (p, Al) Rec -> List.In a Al -> Deb.dependees (reduceReal R) (reduceDeps D) (reduceRec Rec) @@ -2120,7 +2077,7 @@ Module DebianMA (N V : UsualOrderedType) (AP : ArchParam). (Deb.Name.Selector (reduceAtom (parch p) a), y). Proof. intros R D Rec Pi G M p Al a y HRec Ha. - apply dependees_lookupSelectorAgreeMA. + apply dependees_lookupSelectorAgree. rewrite (Deb.occursAtomb_allClausesR (reduceDeps D) (reduceRec Rec) (reduceAtom (parch p) a) (occursAtomb_reduceDeps Rec p Al a HRec Ha)), @@ -2132,4 +2089,23 @@ Module DebianMA (N V : UsualOrderedType) (AP : ArchParam). Qed. End Lookup. + + Corollary multiarchResolution_reduceReal : forall S, + multiarchResolution (reduceReal S) = S. + Proof. + intro S; apply PkgSet.ext; intro q. + rewrite mem_multiarchResolution; unfold reduceReal. + exact (SOmr.mem_map_inj _ _ _ embedPkg_injective). + Qed. + + Corollary multiarchResolution_core : forall R D Rec Pi G M S, + multiarchResolution + (Deb.debianResolution + (Deb.coreResolution (reduceReal R) (reduceDeps D) (reduceRec Rec) + (reduceProv R Pi M) (reduceConf R G M) (reduceReal S))) = S. + Proof. + intros R D Rec Pi G M S. + rewrite Deb.debianResolution_coreResolution. + apply multiarchResolution_reduceReal. + Qed. End DebianMA. diff --git a/theories/Feature.v b/theories/Feature.v index 3fa417e..c6dbc33 100644 --- a/theories/Feature.v +++ b/theories/Feature.v @@ -593,10 +593,6 @@ Module Feature (N V F : UsualOrderedType). Module SupportFibred := FibredRel Pkg F PkgF SupportSet. Module AddlDepRelFibred := FibredLabelledRel PkgF N VSFS AddlDepElt AddlDepRel. - (* support is a relation between packages and features, so neither of - its fibres alone cuts it down to the support pairs that introduce - one name: those are pinned by the base name and the feature at - once. *) Definition supportFibre (support : SupportSet.t) (n : N.t) (f : F.t) : SupportSet.t := SupportSet.filter (fun '((m, _), g) => diff --git a/theories/Npm.v b/theories/Npm.v index 7f26f8e..8cc3cd6 100644 --- a/theories/Npm.v +++ b/theories/Npm.v @@ -308,10 +308,8 @@ Module Npm (N V : UsualOrderedType) (PM : SemverMatch V). Proof. intros I [k v]; unfold realPkgs, Available, base; simpl. rewrite SOkp.mem_unionMap; split. - - intros [k0 [Hk0 Hm]]; apply SOvp.mem_map in Hm. - destruct Hm as [u [Hu He]]. - assert (k0 = k) by congruence; assert (u = v) by congruence. - subst k0 u; split; [exact Hk0 | apply mem_realVersions; exact Hu]. + - intros [k0 [Hk0 Hm]]; apply SOvp.mem_map in Hm as [u [Hu He]]. + mem_destruct; split; [exact Hk0 | apply mem_realVersions; exact Hu]. - intros [Hk Hb]; exists k; split; [exact Hk |]. apply SOvp.mem_map; exists v; split; [apply mem_realVersions; exact Hb | reflexivity]. @@ -323,23 +321,23 @@ Module Npm (N V : UsualOrderedType) (PM : SemverMatch V). Record IsResolution (I : Inst) (S : PkgSet.t) (pi : Conc.ParentRel.t) : Prop := - { nres_subset : forall q, PkgSet.In q S -> Available I q - ; nres_root : PkgSet.In (rootPkg I) S - ; nres_unique : + { res_subset : forall q, PkgSet.In q S -> Available I q + ; res_root : PkgSet.In (rootPkg I) S + ; res_unique : forall p m v v', Installs S pi p m v -> Installs S pi p m v' -> v = v' - ; nres_slot : + ; res_slot : forall p, PkgSet.In p S -> forall a, NSet.In a (dirs I (base p)) -> exists v, VSet.In v (slotCands I (base p) a) /\ Installs S pi p (slotKey I (base p) a) v - ; nres_peer_install : + ; res_peer_install : forall p, PkgSet.In p S -> forall m u, Installs S pi p m u -> forall r, In ((snd m, u), r) (inst_peer I) -> p_optional r = false -> exists v, VSet.In v (peerCandsAt I (base p) r) /\ Installs S pi p (peerKeyAt I (base p) r) v - ; nres_peer_match : + ; res_peer_match : forall p, PkgSet.In p S -> forall m u, Installs S pi p m u -> forall r, In ((snd m, u), r) (inst_peer I) -> @@ -347,18 +345,18 @@ Module Npm (N V : UsualOrderedType) (PM : SemverMatch V). NSet.In (p_name r) (dirs I (base p)) -> forall v, Installs S pi p (peerKeyAt I (base p) r) v -> VSet.In v (peerCandsAt I (base p) r) - ; nres_root_peer : + ; res_root_peer : forall r, In (inst_root I, r) (inst_peer I) -> p_optional r = false -> exists v, VSet.In v (peerCandsAt I (inst_root I) r) /\ Installs S pi (rootPkg I) (peerKeyAt I (inst_root I) r) v - ; nres_root_peer_match : + ; res_root_peer_match : forall r, In (inst_root I, r) (inst_peer I) -> p_optional r = true -> NSet.In (p_name r) (dirs I (inst_root I)) -> forall v, Installs S pi (rootPkg I) (peerKeyAt I (inst_root I) r) v -> VSet.In v (peerCandsAt I (inst_root I) r) - ; nres_parents : + ; res_parents : forall c q, Conc.ParentRel.In (c, q) pi -> PkgSet.In c S /\ PkgSet.In q S /\ KeySet.In (fst c) (childKeys I (base q)) }. @@ -477,20 +475,18 @@ Module Npm (N V : UsualOrderedType) (PM : SemverMatch V). (childKeys I (base q))) (realPkgs I)). - Definition transR (I : Inst) : T.PkgSet.t := + Definition reduceReal (I : Inst) : T.PkgSet.t := SOmt.unionMap (fun n => SOwt.map (fun x => (n, x)) (versions I n)) (targetNames I). - Lemma mem_transR : forall I n x, - T.PkgSet.In (n, x) (transR I) <-> + Lemma mem_reduceReal : forall I n x, + T.PkgSet.In (n, x) (reduceReal I) <-> NmSet.In n (targetNames I) /\ T.VSet.In x (versions I n). Proof. - intros I n x; unfold transR; rewrite SOmt.mem_unionMap; split. - - intros [n0 [Hnm Hm]]; apply SOwt.mem_map in Hm. - destruct Hm as [x0 [Hx He]]. - assert (n0 = n) by congruence; assert (x0 = x) by congruence. - subst n0 x0; split; assumption. + intros I n x; unfold reduceReal; rewrite SOmt.mem_unionMap; split. + - intros [n0 [Hnm Hm]]; apply SOwt.mem_map in Hm; mem_destruct. + split; assumption. - intros [Hnm Hx]; exists n; split; [exact Hnm |]. apply SOwt.mem_map; exists x; split; [exact Hx | reflexivity]. Qed. @@ -510,25 +506,23 @@ Module Npm (N V : UsualOrderedType) (PM : SemverMatch V). Definition depEdges (s : T.Pkg.t) (hs : T.DependeesSet.t) : T.DepRel.t := SOhd.map (fun h => (s, h)) hs. - Definition transD (I : Inst) : T.DepRel.t := - SOqd.unionMap (fun s => depEdges s (dependees I s)) (transR I). + Definition reduceDeps (I : Inst) : T.DepRel.t := + SOqd.unionMap (fun s => depEdges s (dependees I s)) (reduceReal I). - Lemma mem_transD : forall I s h, - T.DepRel.In (s, h) (transD I) <-> - T.PkgSet.In s (transR I) /\ + Lemma mem_reduceDeps : forall I s h, + T.DepRel.In (s, h) (reduceDeps I) <-> + T.PkgSet.In s (reduceReal I) /\ T.DependeesSet.In h (dependees I s). Proof. - intros I s h; unfold transD; rewrite SOqd.mem_unionMap; split. + intros I s h; unfold reduceDeps; rewrite SOqd.mem_unionMap; split. - intros [s0 [Hs0 Hm]]; unfold depEdges in Hm. - apply SOhd.mem_map in Hm; destruct Hm as [h0 [Hh0 He]]. - assert (s0 = s) by congruence; assert (h0 = h) by congruence. - subst s0 h0; split; assumption. + apply SOhd.mem_map in Hm; mem_destruct; split; assumption. - intros [Hs Hh]; exists s; split; [exact Hs |]. unfold depEdges; apply SOhd.mem_map. exists h; split; [exact Hh | reflexivity]. Qed. - Definition transRoot (I : Inst) : T.Pkg.t := + Definition embedRoot (I : Inst) : T.Pkg.t := Conc.Reduction.embedPkg idg (rootPkg I). Definition npmResolution (S : T.PkgSet.t) : PkgSet.t := @@ -555,16 +549,13 @@ Module Npm (N V : UsualOrderedType) (PM : SemverMatch V). unfold npmParents; rewrite SOtp.mem_filterMap; split. - intros [[n x] [Hs He]]; destruct n as [k' w | k' v' m']; destruct x as [u' | w']; try discriminate He. - destruct (T.PkgSet.mem (Conc.Reduction.embedPkg idg (k', v')) S) eqn:Hm; - [| discriminate He]. - injection He as He1 He2 He3 He4; subst. + cbn beta iota in He; apply if_some_iff in He as [Hm He]. + injection He as <- <- <- <-. split; [exact Hs | apply T.PkgSet.mem_spec; exact Hm]. - intros [H1 H2]. exists (Nm.Intermediate k v m, Vs.Orig u); split; [exact H1 |]. - assert (T.PkgSet.mem (Conc.Reduction.embedPkg idg (k, v)) S = true) - as Hm - by (apply T.PkgSet.mem_spec; exact H2). - rewrite Hm; reflexivity. + apply if_some_iff; split; [apply T.PkgSet.mem_spec; exact H2 |]. + reflexivity. Qed. Lemma dependees_embedPkg : forall I q, @@ -576,21 +567,21 @@ Module Npm (N V : UsualOrderedType) (PM : SemverMatch V). Qed. Lemma exit_selected : forall I S k v m u, - T.IsResolution (transR I) (transD I) (transRoot I) S -> + T.IsResolution (reduceReal I) (reduceDeps I) (embedRoot I) S -> T.PkgSet.In (Nm.Intermediate k v m, Vs.Orig u) S -> T.PkgSet.In (Conc.Reduction.embedPkg idg (m, u)) S. Proof. intros I S k v m u [Hsub Hroot Hdep Huniq] Hin. destruct (Hdep _ Hin (Nm.Granular m u) (T.VSet.singleton (Vs.Orig u))) as [x [Hx HxS]]. - { apply mem_transD; split; [exact (Hsub _ Hin) |]. + { apply mem_reduceDeps; split; [exact (Hsub _ Hin) |]. cbn [dependees]; apply SOhh.add_in; left; reflexivity. } apply SOvcv.singleton_in in Hx; subst x. unfold Conc.Reduction.embedPkg, idg; cbn [fst snd]; exact HxS. Qed. Lemma entry_selected : forall I S q a, - T.IsResolution (transR I) (transD I) (transRoot I) S -> + T.IsResolution (reduceReal I) (reduceDeps I) (embedRoot I) S -> T.PkgSet.In (Conc.Reduction.embedPkg idg q) S -> NSet.In a (dirs I (base q)) -> exists v, VSet.In v (slotCands I (base q) a) /\ @@ -603,7 +594,7 @@ Module Npm (N V : UsualOrderedType) (PM : SemverMatch V). (Nm.Intermediate (fst q) (snd q) (slotKey I (base q) a)) (Conc.Reduction.embedVS (slotCands I (base q) a))) as [x [Hx HxS]]. - { apply mem_transD; split; [exact (Hsub _ Hq) |]. + { apply mem_reduceDeps; split; [exact (Hsub _ Hq) |]. rewrite dependees_embedPkg. apply T.DependeesSet.union_spec; left; apply mem_entryEdges. exists a; split; [exact Ha | reflexivity]. } @@ -612,7 +603,7 @@ Module Npm (N V : UsualOrderedType) (PM : SemverMatch V). Qed. Lemma root_peer_selected : forall I S r, - T.IsResolution (transR I) (transD I) (transRoot I) S -> + T.IsResolution (reduceReal I) (reduceDeps I) (embedRoot I) S -> In (inst_root I, r) (inst_peer I) -> peerActive I (inst_root I) r = true -> exists v, VSet.In v (peerCandsAt I (inst_root I) r) /\ @@ -627,8 +618,8 @@ Module Npm (N V : UsualOrderedType) (PM : SemverMatch V). (Conc.Reduction.embedVS (peerCandsAt I (inst_root I) r))) as [x [Hx HxS]]. - { apply mem_transD; split; [exact (Hsub _ Hroot) |]. - unfold transRoot; rewrite dependees_embedPkg. + { apply mem_reduceDeps; split; [exact (Hsub _ Hroot) |]. + unfold embedRoot; rewrite dependees_embedPkg. apply T.DependeesSet.union_spec; right; apply mem_rootPeerEdges. split; [reflexivity |]; rewrite base_rootPkg. exists r; split; [exact Hr | split; [exact Hact | reflexivity]]. } @@ -637,7 +628,7 @@ Module Npm (N V : UsualOrderedType) (PM : SemverMatch V). Qed. Lemma peer_selected : forall I S q m u r, - T.IsResolution (transR I) (transD I) (transRoot I) S -> + T.IsResolution (reduceReal I) (reduceDeps I) (embedRoot I) S -> T.PkgSet.In (Nm.Intermediate (fst q) (snd q) m, Vs.Orig u) S -> In ((snd m, u), r) (inst_peer I) -> peerActive I (base q) r = true -> @@ -651,7 +642,7 @@ Module Npm (N V : UsualOrderedType) (PM : SemverMatch V). (Nm.Intermediate (fst q) (snd q) (peerKeyAt I (base q) r)) (Conc.Reduction.embedVS (peerCandsAt I (base q) r))) as [x [Hx HxS]]. - { apply mem_transD; split; [exact (Hsub _ Hin) |]. + { apply mem_reduceDeps; split; [exact (Hsub _ Hin) |]. cbn [dependees]; apply SOhh.add_in; right. apply mem_peerEdgesAt; exists r; split; [exact Hr | split; [exact Hact | reflexivity]]. } @@ -660,7 +651,7 @@ Module Npm (N V : UsualOrderedType) (PM : SemverMatch V). Qed. Theorem npm_soundness : forall I S, - T.IsResolution (transR I) (transD I) (transRoot I) S -> + T.IsResolution (reduceReal I) (reduceDeps I) (embedRoot I) S -> IsResolution I (npmResolution S) (npmParents S). Proof. intros I S Hres. @@ -676,12 +667,11 @@ Module Npm (N V : UsualOrderedType) (PM : SemverMatch V). - apply mem_npmParents; cbn [fst snd]; split; assumption. } constructor. - intros [k w] Hq; apply Conc.Reduction.mem_concurrentResolution in Hq. - pose proof (Hsub _ Hq) as Hr; apply mem_transR in Hr. + pose proof (Hsub _ Hq) as Hr; apply mem_reduceReal in Hr. destruct Hr as [_ Hv]. cbn [versions Conc.Reduction.embedPkg fst snd] in Hv. unfold idg in Hv. - destruct (PkgSet.mem (k, w) (realPkgs I)) eqn:Hm; - [| destruct (SOvcv.empty_in _ Hv)]. + apply SOvcv.in_if_empty in Hv as [Hm _]. apply PkgSet.mem_spec in Hm; apply mem_realPkgs; exact Hm. - apply Conc.Reduction.mem_concurrentResolution; exact Hroot. - intros p m v v' [_ H1] [_ H2]. @@ -734,10 +724,37 @@ Module Npm (N V : UsualOrderedType) (PM : SemverMatch V). + apply Conc.Reduction.mem_concurrentResolution. exact (exit_selected I S k w m u Hres Hi). + apply Conc.Reduction.mem_concurrentResolution; exact Hq. - + apply Hsub, mem_transR in Hi; destruct Hi as [Hn _]. + + apply Hsub, mem_reduceReal in Hi; destruct Hi as [Hn _]. exact (targetNames_int I k w m Hn). Qed. + Corollary peer_installed : forall I S, + T.IsResolution (reduceReal I) (reduceDeps I) (embedRoot I) S -> + forall k v m u, + T.PkgSet.In (Conc.Reduction.embedPkg idg (k, v)) S -> + T.PkgSet.In (Nm.Intermediate k v m, Vs.Orig u) S -> + forall r, In ((snd m, u), r) (inst_peer I) -> + p_optional r = false -> + exists w, + PkgSet.In (peerKeyAt I (snd k, v) r, w) (npmResolution S) /\ + Conc.ParentRel.In + ((peerKeyAt I (snd k, v) r, w), (k, v)) (npmParents S) /\ + VSet.In w (peerCandsAt I (snd k, v) r). + Proof. + intros I S Hres k v m u Hq Hi r Hr Hopt. + pose proof (npm_soundness I S Hres) as Hsrc. + assert (Hp : PkgSet.In (k, v) (npmResolution S)) + by (apply Conc.Reduction.mem_concurrentResolution; exact Hq). + assert (HI : Installs (npmResolution S) (npmParents S) (k, v) m u). + { split. + - apply Conc.Reduction.mem_concurrentResolution. + exact (exit_selected I S k v m u Hres Hi). + - apply mem_npmParents; cbn [fst snd]; split; assumption. } + destruct (res_peer_install _ _ _ Hsrc (k, v) Hp m u HI r Hr Hopt) + as [w [Hw [HwS Hwpi]]]. + exists w; split; [exact HwS | split; [exact Hwpi | exact Hw]]. + Qed. + Lemma installs_childCands : forall I S pi p m v, IsResolution I S pi -> PkgSet.In p S -> KeySet.In m (childKeys I (base p)) -> @@ -750,15 +767,15 @@ Module Npm (N V : UsualOrderedType) (PM : SemverMatch V). unfold childCands; rewrite slotKey_fst, KeyEqb.eqb_refl. destruct (NSet.mem a (dirs I (base p))) eqn:Hsa. - apply NSet.mem_spec in Hsa. - destruct (nres_slot _ _ _ Hres p Hp a Hsa) as [v' [Hv' Hi']]. - rewrite (nres_unique _ _ _ Hres p _ v v' Hi Hi'); exact Hv'. + destruct (res_slot _ _ _ Hres p Hp a Hsa) as [v' [Hv' Hi']]. + rewrite (res_unique _ _ _ Hres p _ v v' Hi Hi'); exact Hv'. - unfold childDirs in Ha; apply NSet.union_spec in Ha. destruct Ha as [Ha | Ha]; [apply NSet.mem_spec in Ha; rewrite Ha in Hsa; discriminate |]. assert (Hpa : NSet.mem a (peerDirs I) = true) by (apply NSet.mem_spec; exact Ha). rewrite Hpa; destruct Hi as [HinS _]. - destruct (nres_subset _ _ _ Hres _ HinS) as [_ Hb]; unfold base in Hb. + destruct (res_subset _ _ _ Hres _ HinS) as [_ Hb]; unfold base in Hb. cbn [fst snd] in Hb; apply mem_realVersions; exact Hb. Qed. @@ -771,16 +788,16 @@ Module Npm (N V : UsualOrderedType) (PM : SemverMatch V). Proof. intros I S pi r Hres Hr Hact. destruct (p_optional r) eqn:Hopt; - [| exact (nres_root_peer _ _ _ Hres r Hr Hopt)]. + [| exact (res_root_peer _ _ _ Hres r Hr Hopt)]. unfold peerActive in Hact; rewrite Hopt in Hact; cbn [negb orb] in Hact; apply NSet.mem_spec in Hact. assert (Hdir : NSet.In (p_name r) (dirs I (base (rootPkg I)))) by (rewrite base_rootPkg; exact Hact). - destruct (nres_slot _ _ _ Hres (rootPkg I) (nres_root _ _ _ Hres) + destruct (res_slot _ _ _ Hres (rootPkg I) (res_root _ _ _ Hres) (p_name r) Hdir) as [w [_ Hi]]. rewrite base_rootPkg in Hi. exists w; unfold peerKeyAt; split; - [exact (nres_root_peer_match _ _ _ Hres r Hr Hopt Hact w Hi) + [exact (res_root_peer_match _ _ _ Hres r Hr Hopt Hact w Hi) | exact Hi]. Qed. @@ -796,15 +813,9 @@ Module Npm (N V : UsualOrderedType) (PM : SemverMatch V). s = (Nm.Intermediate (fst p) (snd p) m, Vs.Orig u). Proof. intros S pi p m u s; unfold instNode. - destruct (PkgSet.mem (m, u) S) eqn:H1; - destruct (Conc.ParentRel.mem ((m, u), p) pi) eqn:H2; cbn [andb]; - split; try discriminate. - - intro H; split; [apply PkgSet.mem_spec; exact H1 |]. - split; [apply Conc.ParentRel.mem_spec; exact H2 | congruence]. - - intros [_ [_ ->]]; reflexivity. - - intros [_ [H _]]; apply Conc.ParentRel.mem_spec in H; congruence. - - intros [H _]; apply PkgSet.mem_spec in H; congruence. - - intros [H _]; apply PkgSet.mem_spec in H; congruence. + rewrite if_some_iff, Bool.andb_true_iff, PkgSet.mem_spec, + Conc.ParentRel.mem_spec. + intuition congruence. Qed. Definition coreResolution (I : Inst) @@ -883,17 +894,17 @@ Module Npm (N V : UsualOrderedType) (PM : SemverMatch V). Theorem npm_completeness : forall I S pi, IsResolution I S pi -> - T.IsResolution (transR I) (transD I) (transRoot I) + T.IsResolution (reduceReal I) (reduceDeps I) (embedRoot I) (coreResolution I S pi). Proof. intros I S pi Hres. - pose proof (nres_subset _ _ _ Hres) as Hsub. - pose proof (nres_slot _ _ _ Hres) as Hslot. + pose proof (res_subset _ _ _ Hres) as Hsub. + pose proof (res_slot _ _ _ Hres) as Hslot. assert (Hreal : forall q, PkgSet.In q S -> PkgSet.In q (realPkgs I)) by (intros q Hq; apply mem_realPkgs; exact (Hsub _ Hq)). assert (Hgran : forall k v, PkgSet.In (k, v) S -> - T.PkgSet.In (Nm.Granular k v, Vs.Orig v) (transR I)). - { intros k v Hq; apply mem_transR; split. + T.PkgSet.In (Nm.Granular k v, Vs.Orig v) (reduceReal I)). + { intros k v Hq; apply mem_reduceReal; split. - pose proof (mem_targetNames_gran I (k, v) (Hreal _ Hq)) as Ht. cbn [fst snd] in Ht; exact Ht. - cbn [versions]. @@ -905,7 +916,7 @@ Module Npm (N V : UsualOrderedType) (PM : SemverMatch V). destruct Hs as [[k [v [Hp ->]]] | [p [m [u [Hp [Hm [Hu [HS [Hpi ->]]]]]]]]]; [exact (Hgran k v Hp) |]. - apply mem_transR; split. + apply mem_reduceReal; split. + exact (mem_targetNames_int I p m (Hreal _ Hp) Hm). + cbn [versions]; apply SOvcv.mem_map; exists u; split; [| reflexivity]. @@ -913,10 +924,10 @@ Module Npm (N V : UsualOrderedType) (PM : SemverMatch V). (conj HS Hpi)). - apply mem_coreResolution; left. exists (rootKey I), (snd (inst_root I)); split; - [exact (nres_root _ _ _ Hres) |]. - unfold transRoot, rootPkg, Conc.Reduction.embedPkg, idg; reflexivity. + [exact (res_root _ _ _ Hres) |]. + unfold embedRoot, rootPkg, Conc.Reduction.embedPkg, idg; reflexivity. - intros s Hs n vs Hd. - apply mem_transD in Hd; destruct Hd as [_ Hd]. + apply mem_reduceDeps in Hd; destruct Hd as [_ Hd]. apply mem_coreResolution in Hs. destruct Hs as [[k [v [Hp He]]] | [p [m [u [Hp [Hm [Hu [HS [Hpi He]]]]]]]]]. @@ -978,9 +989,9 @@ Module Npm (N V : UsualOrderedType) (PM : SemverMatch V). apply NSet.mem_spec in Hact. destruct (Hslot (pk, pv) Hp (p_name r) Hact) as [w [_ Hi]]. exists w; split; [| exact Hi]. - exact (nres_peer_match _ _ _ Hres (pk, pv) Hp m u HI r Hr + exact (res_peer_match _ _ _ Hres (pk, pv) Hp m u HI r Hr Hopt Hact w Hi). - - exact (nres_peer_install _ _ _ Hres (pk, pv) Hp m u HI r Hr + - exact (res_peer_install _ _ _ Hres (pk, pv) Hp m u HI r Hr Hopt). } destruct Hgot as [w [Hw [HwS Hwpi]]]. exists (Vs.Orig w); split. @@ -1013,75 +1024,11 @@ Module Npm (N V : UsualOrderedType) (PM : SemverMatch V). assert (k1 = k2) by congruence; assert (v1 = v2) by congruence; assert (m1 = m2) by congruence; subst. assert (u1 = u2) as Hu - by exact (nres_unique _ _ _ Hres (k2, v2) m2 u1 u2 + by exact (res_unique _ _ _ Hres (k2, v2) m2 u1 u2 (conj HS1 Hpi1) (conj HS2 Hpi2)). congruence. Qed. - Theorem npmResolution_coreResolution : forall I S pi, - npmResolution (coreResolution I S pi) = S. - Proof. - intros I S pi; apply PkgSet.ext; intros [k v]. - unfold npmResolution; rewrite Conc.Reduction.mem_concurrentResolution. - rewrite mem_coreResolution. - unfold Conc.Reduction.embedPkg, idg; cbn [fst snd]; split. - - intros [[k' [v' [Hp He]]] | [p [m [u [_ [_ [_ [_ [_ He]]]]]]]]]; - [| discriminate He]. - injection He as E1 E2 E3; subst; exact Hp. - - intro Hp; left; exists k, v; split; [exact Hp | reflexivity]. - Qed. - - (* Only this direction holds: a core resolution may carry - intermediates the witness would not rebuild. *) - Theorem npmParents_coreResolution : forall I S pi, - IsResolution I S pi -> - npmParents (coreResolution I S pi) = pi. - Proof. - intros I S pi Hres. - apply Conc.ParentRel.ext; intros [[m u] [k v]]. - rewrite mem_npmParents, !mem_coreResolution; cbn [fst snd]; split. - - intros [[[k' [v' [_ He]]] | [p [m' [u' [_ [_ [_ [_ [Hpi He]]]]]]]]] _]; - [discriminate He |]. - destruct p as [pk pv]; cbn [fst snd] in He. - injection He as E1 E2 E3 E4; subst; exact Hpi. - - intro Hcq; destruct (nres_parents _ _ _ Hres _ _ Hcq) - as [Hc [Hq Hk]]. - split. - + right; exists (k, v), m, u. - split; [exact Hq |]; split; [exact Hk |]. - split; [| split; [exact Hc | split; [exact Hcq | reflexivity]]]. - apply mem_realVersions; exact (proj2 (nres_subset _ _ _ Hres _ Hc)). - + left; exists k, v; split; - [exact Hq | unfold Conc.Reduction.embedPkg, idg; reflexivity]. - Qed. - - Corollary peer_installed : forall I S, - T.IsResolution (transR I) (transD I) (transRoot I) S -> - forall k v m u, - T.PkgSet.In (Conc.Reduction.embedPkg idg (k, v)) S -> - T.PkgSet.In (Nm.Intermediate k v m, Vs.Orig u) S -> - forall r, In ((snd m, u), r) (inst_peer I) -> - p_optional r = false -> - exists w, - PkgSet.In (peerKeyAt I (snd k, v) r, w) (npmResolution S) /\ - Conc.ParentRel.In - ((peerKeyAt I (snd k, v) r, w), (k, v)) (npmParents S) /\ - VSet.In w (peerCandsAt I (snd k, v) r). - Proof. - intros I S Hres k v m u Hq Hi r Hr Hopt. - pose proof (npm_soundness I S Hres) as Hsrc. - assert (Hp : PkgSet.In (k, v) (npmResolution S)) - by (apply Conc.Reduction.mem_concurrentResolution; exact Hq). - assert (HI : Installs (npmResolution S) (npmParents S) (k, v) m u). - { split. - - apply Conc.Reduction.mem_concurrentResolution. - exact (exit_selected I S k v m u Hres Hi). - - apply mem_npmParents; cbn [fst snd]; split; assumption. } - destruct (nres_peer_install _ _ _ Hsrc (k, v) Hp m u HI r Hr Hopt) - as [w [Hw [HwS Hwpi]]]. - exists w; split; [exact HwS | split; [exact Hwpi | exact Hw]]. - Qed. - Lemma targetNames_gran_real : forall I k w, NmSet.In (Nm.Granular k w) (targetNames I) -> PkgSet.In (k, w) (realPkgs I). @@ -1143,20 +1090,16 @@ Module Npm (N V : UsualOrderedType) (PM : SemverMatch V). cbn [snd] in Hn |- *; rewrite Hn; reflexivity. Qed. - (* Every dependee of a package of transR names a node of targetNames, - so a lookup that starts at the root and follows dependees never - leaves the names on which versions and dependees agree with transR - and transD. *) Theorem dependees_targetNames : forall I s h, - T.PkgSet.In s (transR I) -> T.DependeesSet.In h (dependees I s) -> + T.PkgSet.In s (reduceReal I) -> T.DependeesSet.In h (dependees I s) -> NmSet.In (fst h) (targetNames I). Proof. - intros I [n x] h Hs Hh; apply mem_transR in Hs; destruct Hs as [Hn Hx]. + intros I [n x] h Hs Hh; apply mem_reduceReal in Hs. + destruct Hs as [Hn Hx]. destruct n as [k w | k v m]. - apply targetNames_gran_real in Hn. cbn [versions] in Hx. - destruct (PkgSet.mem (k, w) (realPkgs I)); - [| destruct (SOvcv.empty_in _ Hx)]. + apply SOvcv.in_if_empty in Hx as [_ Hx]. apply SOvcv.singleton_in in Hx; subst x. rewrite dependees_gran in Hh; apply T.DependeesSet.union_spec in Hh. destruct Hh as [Hh | Hh]. @@ -1175,8 +1118,7 @@ Module Npm (N V : UsualOrderedType) (PM : SemverMatch V). destruct Hh as [-> | Hh]. + cbn [fst]; apply (mem_targetNames_gran I (m, u)). unfold childCands in Hu. - destruct (KeyEqb.eqb m (slotKey I (snd k, v) (fst m))) eqn:Hk; - [| destruct (SOrv.empty_in _ Hu)]. + apply SOrv.in_if_empty in Hu as [Hk Hu]. apply KeyEqb.eqb_true_iff in Hk. apply mem_realPkgs; unfold Available, base; cbn [fst snd]. destruct (NSet.mem (fst m) (dirs I (snd k, v))) eqn:Hd. @@ -1184,8 +1126,7 @@ Module Npm (N V : UsualOrderedType) (PM : SemverMatch V). split; [rewrite Hk; apply slotKey_keysOf; left; exact Hd |]. pose proof (slotCands_real I _ _ u Hu) as Hr. rewrite <- Hk in Hr; exact Hr. - * destruct (NSet.mem (fst m) (peerDirs I)) eqn:Hp; - [| destruct (SOrv.empty_in _ Hu)]. + * apply SOrv.in_if_empty in Hu as [Hp Hu]. apply NSet.mem_spec in Hp. split; [rewrite Hk; apply slotKey_keysOf; right; exact Hp |]. apply mem_realVersions; exact Hu. @@ -1195,11 +1136,8 @@ Module Npm (N V : UsualOrderedType) (PM : SemverMatch V). exact (peerKeyAt_childKeys I _ _ r Hr). Qed. - (* The packages a lookup-driven solver can reach: the root, and any - version its versions lookup offers at the target of a dependee of - a package already reached. *) Inductive Reached (I : Inst) : T.Pkg.t -> Prop := - | reached_root : Reached I (transRoot I) + | reached_root : Reached I (embedRoot I) | reached_dependee : forall s h x, Reached I s -> T.DependeesSet.In h (dependees I s) -> T.VSet.In x (versions I (fst h)) -> Reached I (fst h, x). @@ -1212,37 +1150,35 @@ Module Npm (N V : UsualOrderedType) (PM : SemverMatch V). rewrite H; apply T.VSet.singleton_spec; reflexivity. Qed. - Theorem reached_transR : forall I s, + Theorem reached_reduceReal : forall I s, RepoSet.In (inst_root I) (inst_repo I) -> - Reached I s -> T.PkgSet.In s (transR I). + Reached I s -> T.PkgSet.In s (reduceReal I). Proof. intros I s Hroot H; induction H as [| s h x Hs IH Hh Hx]. - assert (Hr : PkgSet.In (rootPkg I) (realPkgs I)). { apply mem_realPkgs; split; [| rewrite base_rootPkg; exact Hroot]. unfold keysOf; apply KeySet.add_spec; left; reflexivity. } - unfold transRoot, Conc.Reduction.embedPkg, idg. - apply mem_transR; split; [exact (mem_targetNames_gran I _ Hr) |]. + unfold embedRoot, Conc.Reduction.embedPkg, idg. + apply mem_reduceReal; split; [exact (mem_targetNames_gran I _ Hr) |]. exact (versions_gran_real I (fst (rootPkg I)) (snd (rootPkg I)) Hr). - - apply mem_transR; split; [| exact Hx]. + - apply mem_reduceReal; split; [| exact Hx]. exact (dependees_targetNames I s h IH Hh). Qed. - (* A set of reached packages that the lookups close is a resolution of - the whole translated instance. *) Theorem lookup_resolution : forall I S, RepoSet.In (inst_root I) (inst_repo I) -> (forall s, T.PkgSet.In s S -> Reached I s) -> - T.PkgSet.In (transRoot I) S -> + T.PkgSet.In (embedRoot I) S -> (forall s, T.PkgSet.In s S -> forall n vs, T.DependeesSet.In (n, vs) (dependees I s) -> exists v, T.VSet.In v vs /\ T.PkgSet.In (n, v) S) -> T.VersionUnique S -> - T.IsResolution (transR I) (transD I) (transRoot I) S. + T.IsResolution (reduceReal I) (reduceDeps I) (embedRoot I) S. Proof. intros I S Hroot Hreach HrS Hclo Huniq; constructor. - - intros s Hs; exact (reached_transR I s Hroot (Hreach s Hs)). + - intros s Hs; exact (reached_reduceReal I s Hroot (Hreach s Hs)). - exact HrS. - - intros s Hs n vs Hd; apply mem_transD in Hd. + - intros s Hs n vs Hd; apply mem_reduceDeps in Hd. exact (Hclo s Hs n vs (proj2 Hd)). - exact Huniq. Qed. @@ -1436,10 +1372,7 @@ Module Npm (N V : UsualOrderedType) (PM : SemverMatch V). (fun q => KeyEqb.eqb (p_name (snd q), p_name (snd q)) k) (inst_peer I). - (* keysOf is asked only whether it holds k, so any one dependency - introducing k answers, or failing that any one peer dependency; - the repository is asked only about the one package. *) - Definition GranSubInst (I : Inst) (k : NKey.t) (w : V.t) + Definition granSubInst (I : Inst) (k : NKey.t) (w : V.t) (I' : Inst) : Prop := inst_root I' = inst_root I /\ (RepoSet.In (snd k, w) (inst_repo I') <-> @@ -1451,7 +1384,7 @@ Module Npm (N V : UsualOrderedType) (PM : SemverMatch V). inst_peer I' <> nil). Lemma keysOf_granSubInst : forall I k w I', - GranSubInst I k w I' -> + granSubInst I k w I' -> (KeySet.In k (keysOf I') <-> KeySet.In k (keysOf I)). Proof. intros I k w I' [Hroot [_ [Hd [Hdne [Hp Hpne]]]]]. @@ -1497,8 +1430,8 @@ Module Npm (N V : UsualOrderedType) (PM : SemverMatch V). left; reflexivity. Qed. - Theorem versions_lookupGran : forall I k w I', - GranSubInst I k w I' -> + Theorem versions_lookupGranular : forall I k w I', + granSubInst I k w I' -> versions I' (Nm.Granular k w) = versions I (Nm.Granular k w). Proof. intros I k w I' Hsub; cbn [versions]. @@ -1512,7 +1445,7 @@ Module Npm (N V : UsualOrderedType) (PM : SemverMatch V). subInst I (NSet.add (snd m) (slotTargets I p)) (ownDependencies I p) (peerDependenciesNamed I (fst m)). - Theorem versions_lookupInt : forall I k v m, + Theorem versions_lookupIntermediate : forall I k v m, versions (intSubInst I (snd k, v) m) (Nm.Intermediate k v m) = versions I (Nm.Intermediate k v m). Proof. @@ -1569,7 +1502,7 @@ Module Npm (N V : UsualOrderedType) (PM : SemverMatch V). [reflexivity | apply slotKey_peerTargets; exact Hr]. Qed. - Theorem dependees_lookupGran : forall I k v, + Theorem dependees_lookupGranular : forall I k v, dependees (pkgSubInst I (snd k, v)) (Nm.Granular k v, Vs.Orig v) = dependees I (Nm.Granular k v, Vs.Orig v). @@ -1600,7 +1533,7 @@ Module Npm (N V : UsualOrderedType) (PM : SemverMatch V). subInst I (NSet.union (slotTargets I p) (peerNamesAt I (snd m, u))) (ownDependencies I p) (ownPeerDependencies I (snd m, u)). - Theorem dependees_lookupInt : forall I k v m u, + Theorem dependees_lookupIntermediate : forall I k v m u, dependees (peerSubInst I (snd k, v) m u) (Nm.Intermediate k v m, Vs.Orig u) = dependees I (Nm.Intermediate k v m, Vs.Orig u). @@ -1612,187 +1545,41 @@ Module Npm (N V : UsualOrderedType) (PM : SemverMatch V). End Lookup. + Theorem npmResolution_coreResolution : forall I S pi, + npmResolution (coreResolution I S pi) = S. + Proof. + intros I S pi; apply PkgSet.ext; intros [k v]. + unfold npmResolution; rewrite Conc.Reduction.mem_concurrentResolution. + rewrite mem_coreResolution. + unfold Conc.Reduction.embedPkg, idg; cbn [fst snd]; split. + - intros [[k' [v' [Hp He]]] | [p [m [u [_ [_ [_ [_ [_ He]]]]]]]]]; + [| discriminate He]. + injection He as E1 E2 E3; subst; exact Hp. + - intro Hp; left; exists k, v; split; [exact Hp | reflexivity]. + Qed. + + Theorem npmParents_coreResolution : forall I S pi, + IsResolution I S pi -> + npmParents (coreResolution I S pi) = pi. + Proof. + intros I S pi Hres. + apply Conc.ParentRel.ext; intros [[m u] [k v]]. + rewrite mem_npmParents, !mem_coreResolution; cbn [fst snd]; split. + - intros [[[k' [v' [_ He]]] | [p [m' [u' [_ [_ [_ [_ [Hpi He]]]]]]]]] _]; + [discriminate He |]. + destruct p as [pk pv]; cbn [fst snd] in He. + injection He as E1 E2 E3 E4; subst; exact Hpi. + - intro Hcq; destruct (res_parents _ _ _ Hres _ _ Hcq) + as [Hc [Hq Hk]]. + split. + + right; exists (k, v), m, u. + split; [exact Hq |]; split; [exact Hk |]. + split; [| split; [exact Hc | split; [exact Hcq | reflexivity]]]. + apply mem_realVersions; exact (proj2 (res_subset _ _ _ Hres _ Hc)). + + left; exists k, v; split; + [exact Hq | unfold Conc.Reduction.embedPkg, idg; reflexivity]. + Qed. + End Reduction. End Npm. - -(* Smoke instances. Functor bodies are checked abstractly, so some errors - surface only at application time, and the reflexivity examples fail if - any definition stops computing to a normal form. *) - -Module NatVM <: SemverMatch Nat_as_OT. - Definition isPre (_ : nat) : bool := false. - Definition sameCore (a b : nat) : bool := Nat.eqb a b. -End NatVM. - -Module NpmS := Npm Nat_as_OT Nat_as_OT NatVM. - -Definition npmA : nat := 1. -Definition npmB : nat := 2. -Definition npmC : nat := 3. -Definition npmX : nat := 4. - -Definition npmEq (v : nat) : NpmS.Range := (NpmS.COp OpEq v :: nil) :: nil. - -Definition npmBetween (lo hi : nat) : NpmS.Range := - (NpmS.COp OpGe lo :: NpmS.COp OpLt hi :: nil) :: nil. - -Definition npmRepo : NpmS.RepoSet.t := - fold_right NpmS.RepoSet.add NpmS.RepoSet.empty - ((npmA, 1) :: (npmB, 1) :: (npmC, 1) :: (npmC, 2) :: (npmC, 3) :: nil). - -Definition npmDepB : NpmS.Dependency := NpmS.MkDep npmB npmB (npmEq 1) false. -Definition npmDepC : NpmS.Dependency := - NpmS.MkDep npmC npmC (npmBetween 2 4) false. -Definition npmPeerC : NpmS.PeerDependency := - NpmS.MkPeer npmC (npmBetween 1 3) false. -Definition npmPeerCOpt : NpmS.PeerDependency := - NpmS.MkPeer npmC (npmBetween 1 3) true. - -Definition kA : NpmS.NKey.t := (npmA, npmA). -Definition kB : NpmS.NKey.t := (npmB, npmB). -Definition kC : NpmS.NKey.t := (npmC, npmC). -Definition kX : NpmS.NKey.t := (npmX, npmC). - -Definition npmShow (h : NpmS.T.Dependees.t) - : NpmS.Nm.t * list NpmS.Vs.t := - (fst h, NpmS.T.VSet.elements (snd h)). - -Definition npmDeps (I : NpmS.Inst) (s : NpmS.T.Pkg.t) := - List.map npmShow - (NpmS.T.DependeesSet.elements (NpmS.Reduction.dependees I s)). - -Definition npmInst : NpmS.Inst := - NpmS.MkInst npmRepo - (((npmA, 1), npmDepB) :: ((npmA, 1), npmDepC) :: nil) - (((npmB, 1), npmPeerC) :: nil) nil (npmA, 1). - -Definition npmInstAuto : NpmS.Inst := - NpmS.MkInst npmRepo (((npmA, 1), npmDepB) :: nil) - (((npmB, 1), npmPeerC) :: nil) nil (npmA, 1). - -Definition npmInstRootPeer : NpmS.Inst := - NpmS.MkInst npmRepo (((npmA, 1), npmDepC) :: nil) - (((npmA, 1), npmPeerC) :: nil) nil (npmA, 1). - -Definition npmInstRootPeerOpt : NpmS.Inst := - NpmS.MkInst npmRepo (((npmA, 1), npmDepC) :: nil) - (((npmA, 1), npmPeerCOpt) :: nil) nil (npmA, 1). - -Definition npmInstRootPeerOptBare : NpmS.Inst := - NpmS.MkInst npmRepo (((npmA, 1), npmDepB) :: nil) - (((npmA, 1), npmPeerCOpt) :: nil) nil (npmA, 1). - -Definition npmInstOpt : NpmS.Inst := - NpmS.MkInst npmRepo (((npmA, 1), npmDepB) :: nil) - (((npmB, 1), npmPeerCOpt) :: nil) nil (npmA, 1). - -Definition npmDepAlias : NpmS.Dependency := - NpmS.MkDep npmX npmC (npmEq 1) false. - -Definition npmInstAlias : NpmS.Inst := - NpmS.MkInst npmRepo - (((npmA, 1), npmDepC) :: ((npmA, 1), npmDepAlias) :: nil) - nil nil (npmA, 1). - -Definition npmInstOvr : NpmS.Inst := - NpmS.MkInst npmRepo (((npmA, 1), npmDepC) :: nil) nil - ((npmC, npmEq 3) :: nil) (npmA, 1). - -Example npm_versions_computes : - NpmS.T.VSet.elements - (NpmS.Reduction.versions npmInst (NpmS.Nm.Granular kC 2)) - = NpmS.Vs.Orig 2 :: nil. -Proof. reflexivity. Qed. - -Example npm_entry_edges_computes : - npmDeps npmInst (NpmS.Nm.Granular kA 1, NpmS.Vs.Orig 1) - = (NpmS.Nm.Intermediate kA 1 kB, NpmS.Vs.Orig 1 :: nil) - :: (NpmS.Nm.Intermediate kA 1 kC, - NpmS.Vs.Orig 2 :: NpmS.Vs.Orig 3 :: nil) :: nil. -Proof. reflexivity. Qed. - -Example npm_slot_versions_computes : - NpmS.T.VSet.elements - (NpmS.Reduction.versions npmInst (NpmS.Nm.Intermediate kA 1 kC)) - = NpmS.Vs.Orig 2 :: NpmS.Vs.Orig 3 :: nil. -Proof. reflexivity. Qed. - -Example npm_peer_edge_computes : - npmDeps npmInst (NpmS.Nm.Intermediate kA 1 kB, NpmS.Vs.Orig 1) - = (NpmS.Nm.Granular kB 1, NpmS.Vs.Orig 1 :: nil) - :: (NpmS.Nm.Intermediate kA 1 kC, - NpmS.Vs.Orig 1 :: NpmS.Vs.Orig 2 :: nil) :: nil. -Proof. reflexivity. Qed. - -Example npm_auto_versions_computes : - NpmS.T.VSet.elements - (NpmS.Reduction.versions npmInstAuto - (NpmS.Nm.Intermediate kA 1 kC)) - = NpmS.Vs.Orig 1 :: NpmS.Vs.Orig 2 :: NpmS.Vs.Orig 3 :: nil. -Proof. reflexivity. Qed. - -Example npm_auto_edge_computes : - npmDeps npmInstAuto (NpmS.Nm.Intermediate kA 1 kB, NpmS.Vs.Orig 1) - = (NpmS.Nm.Granular kB 1, NpmS.Vs.Orig 1 :: nil) - :: (NpmS.Nm.Intermediate kA 1 kC, - NpmS.Vs.Orig 1 :: NpmS.Vs.Orig 2 :: nil) :: nil. -Proof. reflexivity. Qed. - -Example npm_optional_edge_computes : - npmDeps npmInstOpt (NpmS.Nm.Intermediate kA 1 kB, NpmS.Vs.Orig 1) - = (NpmS.Nm.Granular kB 1, NpmS.Vs.Orig 1 :: nil) :: nil. -Proof. reflexivity. Qed. - -Example npm_root_peer_computes : - npmDeps npmInstRootPeer (NpmS.Nm.Granular kA 1, NpmS.Vs.Orig 1) - = (NpmS.Nm.Intermediate kA 1 kC, NpmS.Vs.Orig 1 :: NpmS.Vs.Orig 2 :: nil) - :: (NpmS.Nm.Intermediate kA 1 kC, - NpmS.Vs.Orig 2 :: NpmS.Vs.Orig 3 :: nil) :: nil. -Proof. reflexivity. Qed. - -Example npm_root_peer_optional_computes : - npmDeps npmInstRootPeerOpt (NpmS.Nm.Granular kA 1, NpmS.Vs.Orig 1) - = npmDeps npmInstRootPeer (NpmS.Nm.Granular kA 1, NpmS.Vs.Orig 1). -Proof. reflexivity. Qed. - -Example npm_root_peer_optional_bare_computes : - npmDeps npmInstRootPeerOptBare (NpmS.Nm.Granular kA 1, NpmS.Vs.Orig 1) - = (NpmS.Nm.Intermediate kA 1 kB, NpmS.Vs.Orig 1 :: nil) :: nil. -Proof. reflexivity. Qed. - -Example npm_alias_computes : - npmDeps npmInstAlias (NpmS.Nm.Granular kA 1, NpmS.Vs.Orig 1) - = (NpmS.Nm.Intermediate kA 1 kC, - NpmS.Vs.Orig 2 :: NpmS.Vs.Orig 3 :: nil) - :: (NpmS.Nm.Intermediate kA 1 kX, NpmS.Vs.Orig 1 :: nil) :: nil. -Proof. reflexivity. Qed. - -Example npm_override_computes : - npmDeps npmInstOvr (NpmS.Nm.Granular kA 1, NpmS.Vs.Orig 1) - = (NpmS.Nm.Intermediate kA 1 kC, NpmS.Vs.Orig 3 :: nil) :: nil. -Proof. reflexivity. Qed. - -Module NatVMPre <: SemverMatch Nat_as_OT. - Definition isPre (v : nat) : bool := Nat.odd v. - Definition sameCore (a b : nat) : bool := - Nat.eqb (Nat.div a 2) (Nat.div b 2). -End NatVMPre. - -Module NpmP := Npm Nat_as_OT Nat_as_OT NatVMPre. - -Definition npmPreRepo : NpmP.RepoSet.t := - fold_right NpmP.RepoSet.add NpmP.RepoSet.empty - ((npmC, 4) :: (npmC, 5) :: (npmC, 6) :: (npmC, 7) :: nil). - -Example npm_prerelease_excluded : - NpmP.VSet.elements - (NpmP.rangeEval ((NpmP.COp OpGe 4 :: NpmP.COp OpLt 8 :: nil) :: nil) - (NpmP.realVersions npmPreRepo npmC)) = 4 :: 6 :: nil. -Proof. reflexivity. Qed. - -Example npm_prerelease_admitted : - NpmP.VSet.elements - (NpmP.rangeEval ((NpmP.COp OpGe 5 :: NpmP.COp OpLt 8 :: nil) :: nil) - (NpmP.realVersions npmPreRepo npmC)) = 5 :: 6 :: nil. -Proof. reflexivity. Qed. diff --git a/theories/Opam.v b/theories/Opam.v index a614b19..7d91fe5 100644 --- a/theories/Opam.v +++ b/theories/Opam.v @@ -129,7 +129,6 @@ Module Opam (N V X Y E : UsualOrderedType). Record Inst : Type := MkInst { inst_repo : PkgSet.t ; inst_dep : list (Pkg.t * OFormula) - ; inst_dpo : list (Pkg.t * (N.t * (Filter * VConstraint))) ; inst_cfl : list (Pkg.t * (N.t * (Filter * VConstraint))) ; inst_cls : ClsRel.t ; inst_avl : list (Pkg.t * Filter) @@ -144,25 +143,25 @@ Module Opam (N V X Y E : UsualOrderedType). Record IsResolution (rho : Valuation) (I : Inst) (S : PkgSet.t) : Prop := MkRes - { ores_subset : PkgSet.Subset S (inst_repo I) - ; ores_version_unique : C.VersionUnique S - ; ores_available : forall p, PkgSet.In p S -> availOK rho I p - ; ores_goal : oSat rho S (inst_goal I) - ; ores_invariant : oSat rho S (inst_inv I) - ; ores_dep_closure : + { res_subset : PkgSet.Subset S (inst_repo I) + ; res_version_unique : C.VersionUnique S + ; res_available : forall p, PkgSet.In p S -> availOK rho I p + ; res_goal : oSat rho S (inst_goal I) + ; res_invariant : oSat rho S (inst_inv I) + ; res_dep_closure : forall p, PkgSet.In p S -> forall f, In (p, f) (inst_dep I) -> oSat rho S f - ; ores_conflict_avoidance : + ; res_conflict_avoidance : forall p, PkgSet.In p S -> forall n g c, In (p, (n, (g, c))) (inst_cfl I) -> defTrue rho g = true -> forall v, PkgSet.In (n, v) S -> fst p <> n -> vcHolds c v = true -> False - ; ores_class_exclusion : Cls.ClassExclusion (inst_cls I) S - ; ores_pins : + ; res_class_exclusion : Cls.ClassExclusion (inst_cls I) S + ; res_pins : forall n v, PkgSet.In (n, v) (inst_pins I) -> forall v', PkgSet.In (n, v') S -> v' = v - ; ores_pin_depends : + ; res_pin_depends : forall p, PkgSet.In p S -> PkgSet.In p (inst_pins I) -> forall n v u, In (p, ((n, v), u)) (inst_pind I) -> forall v', PkgSet.In (n, v') S -> v' = v }. @@ -439,7 +438,7 @@ Module Opam (N V X Y E : UsualOrderedType). | TName.Cls k => clsVersions (inst_cls I) k end. - Definition transR (rho : Valuation) (I : Inst) : PF.PkgSet.t := + Definition reduceReal (rho : Valuation) (I : Inst) : PF.PkgSet.t := PF.PkgSet.union (embedSet (effRepo rho I)) (PF.PkgSet.union (PF.PkgSet.singleton rootPkg) (clsPkgs (inst_cls I))). @@ -449,14 +448,14 @@ Module Opam (N V X Y E : UsualOrderedType). SOfd.map (fun f => (q, f)) fs. Module SOqd := SetOps PF.Pkg PF.DepElt PF.PkgSet PF.DepRel. - Definition transD (rho : Valuation) (I : Inst) : PF.DepRel.t := + Definition reduceDeps (rho : Valuation) (I : Inst) : PF.DepRel.t := SOqd.unionMap (fun q => depEdges q (dependees rho I q)) - (transR rho I). + (reduceReal rho I). Definition clsSel (cls : ClsRel.t) (S : PkgSet.t) : PF.PkgSet.t := SOcp.map clsPkg (ClsRel.filter (fun qk => PkgSet.mem (fst qk) S) cls). - Definition transS (cls : ClsRel.t) (S : PkgSet.t) : PF.PkgSet.t := + Definition coreResolution (cls : ClsRel.t) (S : PkgSet.t) : PF.PkgSet.t := PF.PkgSet.union (embedSet S) (PF.PkgSet.union (PF.PkgSet.singleton rootPkg) (clsSel cls S)). @@ -590,36 +589,36 @@ Module Opam (N V X Y E : UsualOrderedType). exact (Hav _ Hg). Qed. - Lemma mem_transR : forall rho I q, - PF.PkgSet.In q (transR rho I) <-> + Lemma mem_reduceReal : forall rho I q, + PF.PkgSet.In q (reduceReal rho I) <-> (exists p, PkgSet.In p (effRepo rho I) /\ q = embedPkg p) \/ q = rootPkg \/ (exists p k, ClsRel.In (p, k) (inst_cls I) /\ q = (TName.Cls k, TVer.NV (fst p))). Proof. - intros rho I q; unfold transR, embedSet. + intros rho I q; unfold reduceReal, embedSet. rewrite !PF.PkgSet.union_spec, PF.PkgSet.singleton_spec, SOpt.mem_map, mem_clsPkgs. tauto. Qed. - Lemma mem_transS : forall cls S q, - PF.PkgSet.In q (transS cls S) <-> + Lemma mem_coreResolution : forall cls S q, + PF.PkgSet.In q (coreResolution cls S) <-> (exists p, PkgSet.In p S /\ q = embedPkg p) \/ q = rootPkg \/ (exists p k, PkgSet.In p S /\ ClsRel.In (p, k) cls /\ q = (TName.Cls k, TVer.NV (fst p))). Proof. - intros cls S q; unfold transS, embedSet. + intros cls S q; unfold coreResolution, embedSet. rewrite !PF.PkgSet.union_spec, PF.PkgSet.singleton_spec, SOpt.mem_map, mem_clsSel. tauto. Qed. - Lemma mem_transS_real : forall cls S n v, - PF.PkgSet.In (TName.Real n, TVer.RV v) (transS cls S) <-> + Lemma mem_coreResolution_real : forall cls S n v, + PF.PkgSet.In (TName.Real n, TVer.RV v) (coreResolution cls S) <-> PkgSet.In (n, v) S. Proof. - intros cls S n v; rewrite mem_transS; split. + intros cls S n v; rewrite mem_coreResolution; split. - intros [[p [Hp He]] | [He | [p [k [_ [_ He]]]]]]; try discriminate. destruct p as [m w]; unfold embedPkg in He; simpl in He. @@ -627,40 +626,41 @@ Module Opam (N V X Y E : UsualOrderedType). - intro H; left; exists (n, v); split; [exact H | reflexivity]. Qed. - Lemma decode_transS : forall cls S, decodeS (transS cls S) = S. + Lemma decodeS_coreResolution : forall cls S, + decodeS (coreResolution cls S) = S. Proof. intros cls S; apply PkgSet.ext; intros [n v]. - rewrite mem_decodeS, mem_transS_real; reflexivity. + rewrite mem_decodeS, mem_coreResolution_real; reflexivity. Qed. - (* Each target name draws its versions from one branch of transS, so + (* Each target name draws its versions from one branch of coreResolution, so version uniqueness splits three ways rather than nine. *) - Lemma transS_at_root : forall cls S tv, - PF.PkgSet.In (TName.Root, tv) (transS cls S) -> tv = TVer.UnitV. + Lemma coreResolution_at_root : forall cls S tv, + PF.PkgSet.In (TName.Root, tv) (coreResolution cls S) -> tv = TVer.UnitV. Proof. - intros cls S tv H; apply mem_transS in H. + intros cls S tv H; apply mem_coreResolution in H. destruct H as [[[m w] [_ He]] | [He | [p [k [_ [_ He]]]]]]; unfold embedPkg, rootPkg in He; try discriminate. injection He as ->; reflexivity. Qed. - Lemma transS_at_real : forall cls S n tv, - PF.PkgSet.In (TName.Real n, tv) (transS cls S) -> + Lemma coreResolution_at_real : forall cls S n tv, + PF.PkgSet.In (TName.Real n, tv) (coreResolution cls S) -> exists v, tv = TVer.RV v /\ PkgSet.In (n, v) S. Proof. - intros cls S n tv H; apply mem_transS in H. + intros cls S n tv H; apply mem_coreResolution in H. destruct H as [[[m w] [Hp He]] | [He | [p [k [_ [_ He]]]]]]; unfold embedPkg, rootPkg in He; cbn [fst snd] in He; try discriminate. injection He as -> ->; exists w; split; [reflexivity | exact Hp]. Qed. - Lemma transS_at_cls : forall cls S k tv, - PF.PkgSet.In (TName.Cls k, tv) (transS cls S) -> + Lemma coreResolution_at_cls : forall cls S k tv, + PF.PkgSet.In (TName.Cls k, tv) (coreResolution cls S) -> exists p, tv = TVer.NV (fst p) /\ PkgSet.In p S /\ ClsRel.In (p, k) cls. Proof. - intros cls S k tv H; apply mem_transS in H. + intros cls S k tv H; apply mem_coreResolution in H. destruct H as [[[m w] [_ He]] | [He | [p [k' [Hp [Hpk He]]]]]]; unfold embedPkg, rootPkg in He; cbn [fst snd] in He; try discriminate. @@ -767,12 +767,8 @@ Module Opam (N V X Y E : UsualOrderedType). + destruct H as [nc [He Hnc]]; apply ownedBy_in in Hnc. right; left; exists nc; auto. + destruct H as [[q k] [Hq He]]; cbn beta iota in He. - revert Hq; revert He. - match goal with - | |- (if ?d then _ else _) = _ -> _ => destruct d as [-> | NE] - end; intro He; cbn iota in He; [| discriminate He]. - injection He as <-; intro Hq. - right; right; left; exists k; auto. + destruct (Pkg.eq_dec q (n, v)) as [-> |]; [| discriminate He]. + mem_destruct; right; right; left; exists k; auto. + right; right; right; exact H. - intros [H | [H | [H | H]]]. + destruct H as [f0 [Hin ->]]. @@ -787,16 +783,15 @@ Module Opam (N V X Y E : UsualOrderedType). + right; right; right; exact H. Qed. - Lemma mem_transD : forall rho I q f, - PF.DepRel.In (q, f) (transD rho I) <-> - PF.PkgSet.In q (transR rho I) /\ + Lemma mem_reduceDeps : forall rho I q f, + PF.DepRel.In (q, f) (reduceDeps rho I) <-> + PF.PkgSet.In q (reduceReal rho I) /\ FSet.In f (dependees rho I q). Proof. - intros rho I q f; unfold transD; rewrite SOqd.mem_unionMap. + intros rho I q f; unfold reduceDeps; rewrite SOqd.mem_unionMap. split. - intros [q0 [Hq0 Hf]]; unfold depEdges in Hf. - apply SOfd.mem_map in Hf; destruct Hf as [f0 [Hf0 He]]. - injection He as <- <-; split; assumption. + apply SOfd.mem_map in Hf; mem_destruct; split; assumption. - intros [Hq Hf]; exists q; split; [exact Hq |]. unfold depEdges; apply SOfd.mem_map; exists f; split; [exact Hf | reflexivity]. @@ -806,15 +801,15 @@ Module Opam (N V X Y E : UsualOrderedType). IsResolution rho I S -> PkgSet.Subset S (effRepo rho I). Proof. intros rho I S HR [n v] Hp; apply mem_effRepo. - split; [exact (ores_subset _ _ _ HR _ Hp) |]. + split; [exact (res_subset _ _ _ HR _ Hp) |]. split. - intros m w Hm Hn; simpl in Hn; subst m. - symmetry; exact (ores_pins _ _ _ HR _ _ Hm _ Hp). - - exact (ores_available _ _ _ HR _ Hp). + symmetry; exact (res_pins _ _ _ HR _ _ Hm _ Hp). + - exact (res_available _ _ _ HR _ Hp). Qed. Theorem opam_soundness : forall rho I S', - PF.IsResolution (transR rho I) (transD rho I) rootPkg S' -> + PF.IsResolution (reduceReal rho I) (reduceDeps rho I) rootPkg S' -> IsResolution rho I (decodeS S'). Proof. intros rho I S' HR. @@ -823,7 +818,7 @@ Module Opam (N V X Y E : UsualOrderedType). PkgSet.In (n, v) (effRepo rho I)). { intros n v Hnv; apply mem_decodeS in Hnv. apply (PF.res_subset _ _ _ _ HR) in Hnv. - apply mem_transR in Hnv. + apply mem_reduceReal in Hnv. destruct Hnv as [[p [Hp He]] | [He | [p [k [_ He]]]]]; try discriminate. destruct p as [m w]; unfold embedPkg in He; simpl in He. @@ -837,11 +832,11 @@ Module Opam (N V X Y E : UsualOrderedType). PF.PkgSet.In (embedPkg (n, v)) S'). { intros n v Hnv; apply mem_decodeS in Hnv; exact Hnv. } assert (Hroot := PF.res_root_mem _ _ _ _ HR). - assert (HrootR : PF.PkgSet.In rootPkg (transR rho I)). - { apply mem_transR; right; left; reflexivity. } + assert (HrootR : PF.PkgSet.In rootPkg (reduceReal rho I)). + { apply mem_reduceReal; right; left; reflexivity. } assert (Hdep : PF.DepRel.In (rootPkg, rootForm rho - (srcVersions rho I) I) (transD rho I)). - { apply mem_transD; split; [exact HrootR |]. + (srcVersions rho I) I) (reduceDeps rho I)). + { apply mem_reduceDeps; split; [exact HrootR |]. unfold dependees, dependeesBy, rootPkg. apply FSet.singleton_spec; reflexivity. } assert (Hrootdep := @@ -854,8 +849,8 @@ Module Opam (N V X Y E : UsualOrderedType). PF.Satisfies S' f). { intros n v f Hnv Hf. apply (PF.res_formula_closure _ _ _ _ HR _ (Hemb _ _ Hnv)). - apply mem_transD; split; [| exact Hf]. - apply mem_transR; left; exists (n, v); split; + apply mem_reduceDeps; split; [| exact Hf]. + apply mem_reduceReal; left; exists (n, v); split; [exact (Hsub _ _ Hnv) | reflexivity]. } constructor. - intros [n v] Hp. @@ -934,28 +929,28 @@ Module Opam (N V X Y E : UsualOrderedType). Theorem opam_completeness : forall rho I S, IsResolution rho I S -> - PF.IsResolution (transR rho I) (transD rho I) rootPkg - (transS (inst_cls I) S). + PF.IsResolution (reduceReal rho I) (reduceDeps rho I) rootPkg + (coreResolution (inst_cls I) S). Proof. intros rho I S HR. assert (Hse := res_sub_eff _ _ _ HR). assert (HV : forall n v, - PkgSet.In (n, v) (decodeS (transS (inst_cls I) S)) -> + PkgSet.In (n, v) (decodeS (coreResolution (inst_cls I) S)) -> VSet.In v (srcVersions rho I n)). - { intros n v Hm; rewrite decode_transS in Hm. + { intros n v Hm; rewrite decodeS_coreResolution in Hm. apply mem_srcVersions; exact (Hse _ Hm). } - assert (Hr : PF.PkgSet.In rootPkg (transS (inst_cls I) S)) - by (apply mem_transS; right; left; reflexivity). + assert (Hr : PF.PkgSet.In rootPkg (coreResolution (inst_cls I) S)) + by (apply mem_coreResolution; right; left; reflexivity). constructor. - - intros q Hq; apply mem_transS in Hq; apply mem_transR. + - intros q Hq; apply mem_coreResolution in Hq; apply mem_reduceReal. destruct Hq as [[p [Hp ->]] | [H | [p [k [_ [Hpk ->]]]]]]; [| tauto |]. + left; exists p; split; [exact (Hse _ Hp) | reflexivity]. + right; right; exists p, k; split; [exact Hpk | reflexivity]. - - apply mem_transS; right; left; reflexivity. + - apply mem_coreResolution; right; left; reflexivity. - intros p' Hp' f' Hf'. - apply mem_transD in Hf'; destruct Hf' as [_ Hf']. - apply mem_transS in Hp'. + apply mem_reduceDeps in Hf'; destruct Hf' as [_ Hf']. + apply mem_coreResolution in Hp'. destruct Hp' as [[[pn pv] [Hp0 ->]] | [-> | [p [k [_ [_ ->]]]]]]. + unfold dependees in Hf'. apply mem_dependees_real in Hf'. @@ -963,597 +958,591 @@ Module Opam (N V X Y E : UsualOrderedType). as [[f0 [Hin ->]] | [[nc [Hin ->]] | [[k [Hpk ->]] | [Hpin [nvu [Hin ->]]]]]]. * apply (encodeOF_correct rho _ _ HV Hr). - rewrite decode_transS. - exact (ores_dep_closure _ _ _ HR _ Hp0 _ Hin). + rewrite decodeS_coreResolution. + exact (res_dep_closure _ _ _ HR _ Hp0 _ Hin). * destruct nc as [n [g c]]; unfold cflForm; cbn [fst snd]. destruct (defTrue rho g) eqn:Hg; - [| exact (PTrue_sat (transS (inst_cls I) S) Hr)]. + [| exact (PTrue_sat (coreResolution (inst_cls I) S) Hr)]. cbn [PF.Satisfies]; intros [tv [Htv Hm]]. unfold confVS in Htv. destruct (N.eq_dec (fst (pn, pv)) n) as [| Hne]. { destruct (PF.VSet.empty_spec Htv). } apply mem_versSetBy in Htv; destruct Htv as [v [-> [Hra Hh]]]. - apply mem_transS_real in Hm. - exact (ores_conflict_avoidance _ _ _ HR _ Hp0 _ _ _ Hin + apply mem_coreResolution_real in Hm. + exact (res_conflict_avoidance _ _ _ HR _ Hp0 _ _ _ Hin Hg _ Hm Hne Hh). * cbn [PF.Satisfies]. exists (TVer.NV pn); split; [apply PF.VSet.singleton_spec; reflexivity |]. - apply mem_transS; right; right. + apply mem_coreResolution; right; right. exists (pn, pv), k; split; [exact Hp0 | split; [exact Hpk | reflexivity]]. * destruct nvu as [[n v] u]; unfold pindForm; simpl. intros [tv [Htv Hm]]. apply SOvv.mem_map in Htv; destruct Htv as [v' [Hv' ->]]. apply VSet.remove_spec in Hv'; destruct Hv' as [_ NE]. - apply mem_transS_real in Hm. - exact (NE (ores_pin_depends _ _ _ HR _ Hp0 Hpin _ _ _ Hin + apply mem_coreResolution_real in Hm. + exact (NE (res_pin_depends _ _ _ HR _ Hp0 Hpin _ _ _ Hin _ Hm)). + unfold dependees, dependeesBy, rootPkg in Hf'. apply FSet.singleton_spec in Hf'; subst f'. unfold rootForm; cbn [PF.Satisfies]. split; apply (encodeOF_correct rho _ _ HV Hr); - rewrite decode_transS; - [exact (ores_goal _ _ _ HR) | exact (ores_invariant _ _ _ HR)]. + rewrite decodeS_coreResolution; + [exact (res_goal _ _ _ HR) | exact (res_invariant _ _ _ HR)]. + unfold dependees, dependeesBy in Hf'; cbn beta iota in Hf'. destruct (FSet.empty_spec Hf'). - intros tn tv tv' Hv Hv'; destruct tn as [| n | k]. - + rewrite (transS_at_root _ _ _ Hv), - (transS_at_root _ _ _ Hv'); reflexivity. - + destruct (transS_at_real _ _ _ _ Hv) as [v [-> Hp]]. - destruct (transS_at_real _ _ _ _ Hv') as [w [-> Hq]]. - f_equal; exact (ores_version_unique _ _ _ HR _ _ _ Hp Hq). - + destruct (transS_at_cls _ _ _ _ Hv) as [p [-> [Hp Hpk]]]. - destruct (transS_at_cls _ _ _ _ Hv') as [q [-> [Hq Hqk]]]. - rewrite (ores_class_exclusion _ _ _ HR _ _ _ Hp Hq Hpk Hqk); + + rewrite (coreResolution_at_root _ _ _ Hv), + (coreResolution_at_root _ _ _ Hv'); reflexivity. + + destruct (coreResolution_at_real _ _ _ _ Hv) as [v [-> Hp]]. + destruct (coreResolution_at_real _ _ _ _ Hv') as [w [-> Hq]]. + f_equal; exact (res_version_unique _ _ _ HR _ _ _ Hp Hq). + + destruct (coreResolution_at_cls _ _ _ _ Hv) as [p [-> [Hp Hpk]]]. + destruct (coreResolution_at_cls _ _ _ _ Hv') as [q [-> [Hq Hqk]]]. + rewrite (res_class_exclusion _ _ _ HR _ _ _ Hp Hq Hpk Hqk); reflexivity. Qed. - Module PkgPre := PreimageOfKeys N Pkg NSet PkgSet. - Definition realPreimage (ns : NSet.t) (R : PkgSet.t) : PkgSet.t := - PkgPre.ofKeys fst ns R. + Module Lookup. + Module PkgPre := PreimageOfKeys N Pkg NSet PkgSet. + Definition realPreimage (ns : NSet.t) (R : PkgSet.t) : PkgSet.t := + PkgPre.ofKeys fst ns R. - Fixpoint ofNames (f : OFormula) : NSet.t := - match f with - | OFAtom n _ _ => NSet.singleton n - | OFAnd a b => NSet.union (ofNames a) (ofNames b) - | OFOr a b => NSet.union (ofNames a) (ofNames b) - end. - - Definition listNames {A : Type} (names : A -> NSet.t) (l : list A) - : NSet.t := - List.fold_right (fun a acc => NSet.union (names a) acc) NSet.empty l. - - Definition declaredNames (I : Inst) (p : Pkg.t) : NSet.t := - NSet.union (listNames ofNames (ownedBy p (inst_dep I))) - (NSet.union - (listNames (fun nc => NSet.singleton (fst nc)) - (ownedBy p (inst_cfl I))) - (listNames (fun nvu => NSet.singleton (fst (fst nvu))) - (ownedBy p (inst_pind I)))). - - Definition clsFibre (cls : ClsRel.t) (p : Pkg.t) : ClsRel.t := - ClsRel.filter - (fun qk => if Pkg.eq_dec (fst qk) p then true else false) cls. - - Definition pkgSubInst (I : Inst) (p : Pkg.t) : Inst := - MkInst (realPreimage (declaredNames I p) (inst_repo I)) - (List.filter (ownb p) (inst_dep I)) - (List.filter (ownb p) (inst_dpo I)) - (List.filter (ownb p) (inst_cfl I)) - (clsFibre (inst_cls I) p) - (inst_avl I) - (List.filter (ownb p) (inst_dxt I)) - (inst_pins I) - (List.filter (ownb p) (inst_pind I)) - (inst_goal I) (inst_inv I). - - Definition nameSubInst (I : Inst) (n : N.t) : Inst := - MkInst (realPreimage (NSet.singleton n) (inst_repo I)) - (inst_dep I) (inst_dpo I) (inst_cfl I) (inst_cls I) - (inst_avl I) (inst_dxt I) (inst_pins I) - (inst_pind I) (inst_goal I) (inst_inv I). - - Definition classSubInst (I : Inst) (k : N.t) : Inst := - MkInst PkgSet.empty nil nil nil - (Cls.Reduction.Lookup.classRelAt (inst_cls I) k) - nil nil PkgSet.empty nil (inst_goal I) (inst_inv I). - - Definition rootSubInst (I : Inst) : Inst := - MkInst - (realPreimage - (NSet.union (ofNames (inst_goal I)) (ofNames (inst_inv I))) - (inst_repo I)) - nil nil nil ClsRel.empty (inst_avl I) nil - (inst_pins I) nil (inst_goal I) (inst_inv I). - - Lemma srcVersions_restrict : forall rho I ns n, - NSet.In n ns -> - realVersions - (effRepo rho - (MkInst (realPreimage ns (inst_repo I)) (inst_dep I) - (inst_dpo I) (inst_cfl I) (inst_cls I) (inst_avl I) - (inst_dxt I) (inst_pins I) (inst_pind I) - (inst_goal I) (inst_inv I))) n = - srcVersions rho I n. - Proof. - intros rho I ns n Hn; apply VSet.ext; intro v. - rewrite mem_realVersions. - unfold srcVersions; rewrite mem_realVersions. - rewrite !mem_effRepo; simpl. - unfold realPreimage; rewrite PkgPre.mem_ofKeys; simpl. - unfold PinOK, availOK; simpl; intuition. - Qed. - - Lemma srcVersions_subInst_agree : forall rho I sl ns n, - inst_repo sl = realPreimage ns (inst_repo I) -> - inst_avl sl = inst_avl I -> inst_pins sl = inst_pins I -> - NSet.In n ns -> - srcVersions rho sl n = srcVersions rho I n. - Proof. - intros rho I sl ns n Hr Ha Hp Hn. - unfold srcVersions at 1. - assert (E : effRepo rho sl = - effRepo rho - (MkInst (realPreimage ns (inst_repo I)) (inst_dep I) - (inst_dpo I) (inst_cfl I) (inst_cls I) - (inst_avl I) (inst_dxt I) - (inst_pins I) (inst_pind I) (inst_goal I) - (inst_inv I))). - { unfold effRepo; rewrite Hr, Ha, Hp; reflexivity. } - rewrite E; apply (srcVersions_restrict rho I ns n Hn). - Qed. - - Lemma versSetBy_agree : forall Vq Vq' n c, - Vq n = Vq' n -> versSetBy Vq n c = versSetBy Vq' n c. - Proof. intros Vq Vq' n c H; unfold versSetBy; rewrite H; - reflexivity. Qed. - - Lemma encR_agree : forall rho Vq Vq' f, - (forall n, NSet.In n (ofNames f) -> Vq n = Vq' n) -> - forall g, redOF rho f = Some g -> encR Vq g = encR Vq' g. - Proof. - intros rho Vq Vq'. - induction f as [n g0 c | a IHa b IHb | a IHa b IHb]; - intros H g Hred; simpl in Hred. - 2,3: assert (Ha : forall m, NSet.In m (ofNames a) -> Vq m = Vq' m) - by (intros m Hm; apply H; simpl; apply NSet.union_spec; auto); - assert (Hb : forall m, NSet.In m (ofNames b) -> Vq m = Vq' m) - by (intros m Hm; apply H; simpl; apply NSet.union_spec; auto); - destruct (redOF rho a) eqn:Ea; destruct (redOF rho b) eqn:Eb; - simpl in Hred; try discriminate; injection Hred as <-; simpl; - [rewrite (IHa Ha _ eq_refl), (IHb Hb _ eq_refl); reflexivity - | exact (IHa Ha _ eq_refl) | exact (IHb Hb _ eq_refl)]. - destruct (defTrue rho g0); [| discriminate]. - injection Hred as <-; simpl. - rewrite (versSetBy_agree Vq Vq' n c); [reflexivity |]. - apply H; simpl; apply NSet.singleton_spec; reflexivity. - Qed. - - Lemma encodeOF_agree : forall rho Vq Vq' f, - (forall n, NSet.In n (ofNames f) -> Vq n = Vq' n) -> - encodeOF rho Vq f = encodeOF rho Vq' f. - Proof. - intros rho Vq Vq' f H; unfold encodeOF. - destruct (redOF rho f) as [g |] eqn:Hred; - [exact (encR_agree rho Vq Vq' f H g Hred) | reflexivity]. - Qed. - - Lemma cflForm_agree : forall rho Vq Vq' p nc, - Vq (fst nc) = Vq' (fst nc) -> - cflForm rho Vq p nc = cflForm rho Vq' p nc. - Proof. - intros rho Vq Vq' p [n [g c]] H; unfold cflForm, confVS; - cbn [fst snd]. - cbn [fst snd] in H. - destruct (defTrue rho g); [| reflexivity]. - destruct (N.eq_dec (fst p) n); [reflexivity |]. - rewrite (versSetBy_agree Vq Vq' n c H); reflexivity. - Qed. - - Lemma pindForm_agree : forall Vq Vq' nvu, - Vq (fst (fst nvu)) = Vq' (fst (fst nvu)) -> - pindForm Vq nvu = pindForm Vq' nvu. - Proof. - intros Vq Vq' [[n v] u] H; unfold pindForm; simpl in *. - rewrite H; reflexivity. - Qed. - - Lemma listNames_in : forall (A : Type) (names : A -> NSet.t) l n a, - In a l -> NSet.In n (names a) -> NSet.In n (listNames names l). - Proof. - intros A names l n a; induction l as [| b l IH]; simpl; - [intros [] |]. - intros [-> | Hin] Hn; apply NSet.union_spec; - [left; exact Hn | right; exact (IH Hin Hn)]. - Qed. - - Lemma ownedBy_filter : forall (A : Type) p (l : list (Pkg.t * A)), - ownedBy p (List.filter (ownb p) l) = ownedBy p l. - Proof. - intros A p l; unfold ownedBy; f_equal. - induction l as [| a l IH]; simpl; [reflexivity |]. - destruct (ownb p a) eqn:E; simpl; rewrite ?E, IH; reflexivity. - Qed. - - Theorem versions_lookupReal : forall rho I n, - versions rho (nameSubInst I n) (TName.Real n) = - versions rho I (TName.Real n). - Proof. - intros rho I n; simpl. - rewrite (srcVersions_subInst_agree rho I (nameSubInst I n) - (NSet.singleton n) n); try reflexivity. - apply NSet.singleton_spec; reflexivity. - Qed. - - (* A class package is the conflict class package calculus' at any R holding - every declarer, not at the effective repository: opam reads a - class's versions off every declaration, and the extra ones are - claimed by no package that can be selected. *) - Module SOcd := SetOps ClsElt Pkg ClsRel PkgSet. - Definition declarers (cls : ClsRel.t) : PkgSet.t := SOcd.map fst cls. - - Lemma clsVersions_reduceReal : forall cls R k tv, - (forall q k', ClsRel.In (q, k') cls -> PkgSet.In q R) -> - PF.VSet.In tv (clsVersions cls k) <-> - exists n, tv = TVer.NV n /\ - Cls.Reduction.T.VSet.In (Cls.Reduction.Version.Name n) - (Cls.Reduction.T.versions (Cls.Reduction.reduceReal R cls) - (Cls.Reduction.Name.Cls k)). - Proof. - intros cls R k tv HR. - rewrite mem_clsVersions, Cls.Reduction.Lookup.versions_cls. - split. - - intros [q [Hq ->]]; exists (fst q); split; [reflexivity |]. - apply Cls.Reduction.Lookup.SOpv.mem_map; exists q; split; - [apply Cls.Reduction.Lookup.mem_inClass; split; - [exact (HR _ _ Hq) | exact Hq] - | reflexivity]. - - intros [n [-> Hn]]; apply Cls.Reduction.Lookup.SOpv.mem_map in Hn. - destruct Hn as [q [Hq E]]; injection E as ->. - apply Cls.Reduction.Lookup.mem_inClass in Hq. - exists q; split; [exact (proj2 Hq) | reflexivity]. - Qed. - - (* The one lookup whose sub-instance is a preimage: answering it needs every - declarer of k, which no single package's declarations name. A driver - uncovering the repository as it goes must therefore recompute this - answer at every ask rather than hold it, so a declarer parsed later - is simply there. *) - Theorem versions_lookupCls : forall rho I k, - versions rho (classSubInst I k) (TName.Cls k) = - versions rho I (TName.Cls k). - Proof. - intros rho I k; cbn [versions classSubInst inst_cls]. - assert (HD : forall q k', ClsRel.In (q, k') (inst_cls I) -> - PkgSet.In q (declarers (inst_cls I))) - by (intros q k' H; apply SOcd.mem_map; exists (q, k'); - split; [exact H | reflexivity]). - apply PF.VSet.ext; intro tv. - rewrite (clsVersions_reduceReal (inst_cls I) _ _ _ HD), - (Cls.Reduction.Lookup.versions_lookupClass (declarers (inst_cls I))). - apply clsVersions_reduceReal; intros q k' H. - apply Cls.Reduction.Lookup.mem_classRelAt in H; destruct H as [H ->]. - apply Cls.Reduction.Lookup.mem_inClass; split; - [exact (HD _ _ H) | exact H]. - Qed. - - Theorem dependees_lookupRoot : forall rho I, - dependees rho (rootSubInst I) rootPkg = dependees rho I rootPkg. - Proof. - intros rho I; unfold dependees, dependeesBy, rootPkg, rootForm. - assert (H : forall n, - NSet.In n (NSet.union (ofNames (inst_goal I)) - (ofNames (inst_inv I))) -> - srcVersions rho (rootSubInst I) n = srcVersions rho I n) - by (intros n Hn; - apply (srcVersions_subInst_agree rho I (rootSubInst I) - (NSet.union (ofNames (inst_goal I)) - (ofNames (inst_inv I))) n); - reflexivity || exact Hn). - cbn [rootSubInst inst_goal inst_inv]. - rewrite !(encodeOF_agree rho (srcVersions rho (rootSubInst I)) - (srcVersions rho I)) - by (intros n Hn; apply H, NSet.union_spec; auto). - reflexivity. - Qed. - - Theorem dependees_lookupReal : forall rho I n v, - dependees rho (pkgSubInst I (n, v)) (embedPkg (n, v)) = - dependees rho I (embedPkg (n, v)). - Proof. - intros rho I n v; unfold dependees. - assert (HVq : forall m, NSet.In m (declaredNames I (n, v)) -> - srcVersions rho (pkgSubInst I (n, v)) m = - srcVersions rho I m). - { intros m Hm. - apply (srcVersions_subInst_agree rho I (pkgSubInst I (n, v)) - (declaredNames I (n, v)) m); reflexivity || exact Hm. } - unfold embedPkg, declaredNames in *; cbn [fst snd dependeesBy]. - unfold depForms, cflForms, pindForms. - cbn [pkgSubInst inst_dep inst_cfl inst_cls inst_pins inst_pind]. - rewrite !ownedBy_filter. - f_equal; [| f_equal; [| f_equal]]. - - f_equal; apply List.map_ext_in; intros f0 Hin. - apply encodeOF_agree; intros m Hm; apply HVq. - apply NSet.union_spec; left; exact (listNames_in _ _ _ _ _ Hin Hm). - - f_equal; apply List.map_ext_in; intros [m nc] Hin. - apply cflForm_agree, HVq; rewrite !NSet.union_spec; right; left. - apply (listNames_in _ _ _ _ _ Hin), NSet.singleton_spec; reflexivity. - - apply FSet.ext; intro f; apply SOcf.filterMap_restrict. - + intros qk Hqk; apply ClsRel.filter_spec' in Hqk; apply Hqk. - + intros [q k] Hqk Hf; apply ClsRel.filter_spec'; split; [exact Hqk |]. - cbn beta iota in Hf; cbn [fst]. - destruct (Pkg.eq_dec q (n, v)); [reflexivity | discriminate Hf]. - - destruct (PkgSet.mem (n, v) (inst_pins I)); [| reflexivity]. - f_equal; apply List.map_ext_in; intros nvu Hin. - apply pindForm_agree, HVq; rewrite !NSet.union_spec; right; right. - apply (listNames_in _ _ _ _ _ Hin), NSet.singleton_spec; reflexivity. - Qed. - - Lemma versions_transR : forall rho I tn, - PF.C.versions (transR rho I) tn = versions rho I tn. - Proof. - intros rho I tn; apply PF.VSet.ext; intro tv. - rewrite PF.C.mem_versions, mem_transR. - destruct tn as [| n | k]; cbn [versions]. - - rewrite PF.VSet.singleton_spec; split. - + intros [[p [_ E]] | [E | [p [k [_ E]]]]]; - unfold embedPkg, rootPkg in E; try discriminate E. - injection E as ->; reflexivity. - + intros ->; right; left; reflexivity. - - rewrite SOvv.mem_map; split. - + intros [[[m w] [Hp E]] | [E | [p [k [_ E]]]]]; - unfold embedPkg, rootPkg in E; cbn [fst snd] in E; - try discriminate E. - injection E as -> ->; exists w; split; - [apply mem_srcVersions; exact Hp | reflexivity]. - + intros [v [Hv ->]]; left; exists (n, v); split; - [apply mem_srcVersions; exact Hv | reflexivity]. - - rewrite mem_clsVersions; split. - + intros [[p [_ E]] | [E | [p [k' [Hpk E]]]]]; - unfold embedPkg, rootPkg in E; try discriminate E. - injection E as -> ->; exists p; split; [exact Hpk | reflexivity]. - + intros [p [Hpk ->]]; right; right; exists p, k; split; - [exact Hpk | reflexivity]. - Qed. - - Lemma transD_tailFibre : forall rho I q, - PF.PkgSet.In q (transR rho I) -> - PF.Reduction.Lookup.DepRelFibred.tailFibre (transD rho I) q = - depEdges q (dependees rho I q). - Proof. - intros rho I q Hq; apply PF.DepRel.ext; intros [q' f]. - rewrite PF.Reduction.Lookup.DepRelFibred.mem_tailFibre, mem_transD. - unfold depEdges; rewrite SOfd.mem_map. - split. - - intros [[_ Hf] ->]; exists f; split; [exact Hf | reflexivity]. - - intros [f0 [Hf0 E]]; injection E as -> ->. - split; [split; [exact Hq | exact Hf0] | reflexivity]. - Qed. - - Lemma negNames_encR : forall Vq g x, - ~ PF.Reduction.NSet.In x (PF.Reduction.Lookup.negNames (encR Vq g)). - Proof. - intros Vq g x; - induction g as [n c | a IHa b IHb | a IHa b IHb]; - cbn [encR PF.Reduction.Lookup.negNames]. - - apply PF.Reduction.NSet.empty_spec. - - rewrite PF.Reduction.NSet.union_spec; tauto. - - rewrite PF.Reduction.NSet.union_spec; tauto. - Qed. - - Lemma dependees_negNames : forall rho Vq I q f x, - FSet.In f (dependeesBy rho Vq I q) -> - PF.Reduction.NSet.In x (PF.Reduction.Lookup.negNames f) -> - exists m, x = TName.Real m. - Proof. - intros rho Vq I [tn tv] f x Hf Hx. - assert (HT : ~ PF.Reduction.NSet.In x - (PF.Reduction.Lookup.negNames PTrue)) - by apply PF.Reduction.NSet.empty_spec. - assert (Henc : forall f0, - ~ PF.Reduction.NSet.In x - (PF.Reduction.Lookup.negNames (encodeOF rho Vq f0))). - { intro f0; unfold encodeOF. - destruct (redOF rho f0); [apply negNames_encR | exact HT]. } - destruct tn as [| n | k]; destruct tv as [v | | m]; - try (cbn [dependeesBy] in Hf; destruct (FSet.empty_spec Hf)). - - cbn [dependeesBy] in Hf; apply FSet.singleton_spec in Hf; subst f. - unfold rootForm in Hx; cbn [PF.Reduction.Lookup.negNames] in Hx. - apply PF.Reduction.NSet.union_spec in Hx. - destruct Hx as [Hx | Hx]; destruct (Henc _ Hx). - - apply mem_dependees_real in Hf. - destruct Hf as [[f0 [_ ->]] | [[[nc [g c]] [_ ->]] - | [[k [_ ->]] | [_ [[[m u] y] [_ ->]]]]]]. - + destruct (Henc f0 Hx). - + unfold cflForm in Hx; cbn [fst snd] in Hx. - destruct (defTrue rho g); [| destruct (HT Hx)]. - cbn [PF.Reduction.Lookup.negNames PF.Reduction.fnames] in Hx. - apply PF.Reduction.NSet.singleton_spec in Hx; exists nc; exact Hx. - + destruct (PF.Reduction.NSet.empty_spec Hx). - + unfold pindForm in Hx; - cbn [fst snd PF.Reduction.Lookup.negNames PF.Reduction.fnames] - in Hx. - apply PF.Reduction.NSet.singleton_spec in Hx; exists m; exact Hx. - Qed. - - (* The core lookups a driver answers: a package's formulas from its own - sub-instance, pushed through the package-formula reduction under the - driver's oracle. The oracle need agree with versions only at real - names, the only ones the encoder reads, so a driver's class answer - -- the declarers among the names loaded so far -- may be partial - when a package is reduced. *) - Lemma dependees_core : forall rho I Vq q, - PF.PkgSet.In q (transR rho I) -> - (forall m, Vq (TName.Real m) = versions rho I (TName.Real m)) -> - PF.Reduction.T.dependees - (PF.Reduction.reduceDeps (transR rho I) (transD rho I)) - (PF.Reduction.Name.Orig (fst q), PF.Reduction.Version.Orig (snd q)) = - PF.Reduction.T.dependees - (PF.Reduction.reduceDepsBy Vq (depEdges q (dependees rho I q))) - (PF.Reduction.Name.Orig (fst q), PF.Reduction.Version.Orig (snd q)). - Proof. - intros rho I Vq [tn tv] Hq HVq; cbn [fst snd]. - rewrite (PF.Reduction.Lookup.dependees_lookupOrigBy _ _ (versions rho I)) - by (intros n _; symmetry; apply versions_transR). - rewrite (transD_tailFibre rho I (tn, tv) Hq). - f_equal; apply PF.Reduction.Lookup.reduceDepsBy_agreeNeg. - intros p f x Hpf Hx. - unfold depEdges in Hpf; apply SOfd.mem_map in Hpf. - destruct Hpf as [f0 [Hf0 E]]; injection E as _ <-. - destruct (dependees_negNames _ _ _ _ _ _ Hf0 Hx) as [m ->]. - symmetry; apply HVq. - Qed. - - Theorem dependees_lookupRealCore : forall rho I Vq n v, - PkgSet.In (n, v) (effRepo rho I) -> - (forall m, Vq (TName.Real m) = versions rho I (TName.Real m)) -> - PF.Reduction.T.dependees - (PF.Reduction.reduceDeps (transR rho I) (transD rho I)) - (PF.Reduction.embedPkg (embedPkg (n, v))) = - PF.Reduction.T.dependees - (PF.Reduction.reduceDepsBy Vq - (depEdges (embedPkg (n, v)) - (dependees rho (pkgSubInst I (n, v)) (embedPkg (n, v))))) - (PF.Reduction.embedPkg (embedPkg (n, v))). - Proof. - intros rho I Vq n v Hnv HVq; rewrite dependees_lookupReal. - apply (dependees_core rho I Vq (embedPkg (n, v))); [| exact HVq]. - apply mem_transR; left; exists (n, v); split; - [exact Hnv | reflexivity]. - Qed. - - Theorem dependees_lookupRootCore : forall rho I Vq, - (forall m, Vq (TName.Real m) = versions rho I (TName.Real m)) -> - PF.Reduction.T.dependees - (PF.Reduction.reduceDeps (transR rho I) (transD rho I)) - (PF.Reduction.embedPkg rootPkg) = - PF.Reduction.T.dependees - (PF.Reduction.reduceDepsBy Vq - (depEdges rootPkg (dependees rho (rootSubInst I) rootPkg))) - (PF.Reduction.embedPkg rootPkg). - Proof. - intros rho I Vq HVq; rewrite dependees_lookupRoot. - apply (dependees_core rho I Vq rootPkg); [| exact HVq]. - apply mem_transR; right; left; reflexivity. - Qed. - - Theorem dependees_lookupClsCore : forall rho I k w, - PF.Reduction.T.dependees - (PF.Reduction.reduceDeps (transR rho I) (transD rho I)) - (PF.Reduction.Name.Orig (TName.Cls k), PF.Reduction.Version.Orig w) = - PF.Reduction.T.DependeesSet.empty. - Proof. - intros rho I k w; apply PF.Reduction.T.dependees_empty_iff; intros h H. - apply PF.Reduction.mem_reduceDeps in H. - destruct H as [[pn pv] [f [Hd He]]]. - assert (E := proj1 (PF.Reduction.Lookup.encodeNNF_src_orig_aux _ f) - _ _ _ _ He). - unfold PF.Reduction.embedPkg in E; injection E as -> ->. - apply mem_transD in Hd; destruct Hd as [_ Hf]. - unfold dependees, dependeesBy in Hf. - destruct w; destruct (FSet.empty_spec Hf). - Qed. - - Theorem dependees_lookupDisjunctCore : forall rho I I' Vq q fs i, - PF.PkgSet.In q (transR rho I) -> - dependees rho I' q = dependees rho I q -> - (forall m, Vq (TName.Real m) = versions rho I (TName.Real m)) -> - PF.Reduction.T.PkgSet.In (PF.Reduction.Name.Disjunct fs, i) - (PF.Reduction.reduceReal (PF.PkgSet.singleton q) - (depEdges q (dependees rho I' q))) -> - PF.Reduction.T.dependees - (PF.Reduction.reduceDeps (transR rho I) (transD rho I)) - (PF.Reduction.Name.Disjunct fs, i) = - PF.Reduction.T.dependees - (PF.Reduction.reduceDepsBy Vq (depEdges q (dependees rho I' q))) - (PF.Reduction.Name.Disjunct fs, i). - Proof. - intros rho I I' Vq q fs i Hq HI HVq Hin; rewrite HI in Hin |- *. - assert (Hsub : PF.DepRel.Subset (depEdges q (dependees rho I q)) - (transD rho I)). - { rewrite <- (transD_tailFibre rho I q Hq). - apply PF.Reduction.Lookup.DepRelFibred.tailFibre_subset. } - apply (PF.Reduction.Lookup.dependees_lookupDisjunctBy - _ _ _ _ _ _ _ Hsub Hin). - intros p f x Hpf Hx. - unfold depEdges in Hpf; apply SOfd.mem_map in Hpf. - destruct Hpf as [f0 [Hf0 E]]; injection E as _ <-. - destruct (dependees_negNames _ _ _ _ _ _ Hf0 Hx) as [m ->]. - rewrite HVq, versions_transR; reflexivity. - Qed. - - Lemma versions_core : forall rho I tn, - (exists tv, PF.PkgSet.In (tn, tv) (transR rho I)) \/ - (exists s h, - PF.Reduction.T.DepRel.In (s, (PF.Reduction.Name.Orig tn, h)) - (PF.Reduction.reduceDeps (transR rho I) (transD rho I))) -> - PF.Reduction.T.versions - (PF.Reduction.reduceReal (transR rho I) (transD rho I)) - (PF.Reduction.Name.Orig tn) = - PF.Reduction.T.VSet.add PF.Reduction.Version.Bot - (PF.Reduction.embedVS (versions rho I tn)). - Proof. - intros rho I tn Hreach. - assert (Hr : PF.PkgSet.In rootPkg (transR rho I)) - by (apply mem_transR; right; left; reflexivity). - destruct Hreach as [[tv Htv] | Hreach]; - [rewrite (PF.Reduction.Lookup.versions_lookupOrig _ _ (tn, tv) tn Htv - (or_intror eq_refl) eq_refl) - | rewrite (PF.Reduction.Lookup.versions_lookupOrig _ _ rootPkg tn Hr - (or_introl Hreach) eq_refl)]; - do 2 f_equal; rewrite <- versions_transR; - apply PF.C.versions_ext; intro v; - rewrite PF.Reduction.Lookup.PkgFibred.mem_tailFibre; tauto. - Qed. - - Theorem versions_lookupRealCore : forall rho I n, - (exists v, PkgSet.In (n, v) (effRepo rho I)) \/ - (exists s h, - PF.Reduction.T.DepRel.In - (s, (PF.Reduction.Name.Orig (TName.Real n), h)) - (PF.Reduction.reduceDeps (transR rho I) (transD rho I))) -> - PF.Reduction.T.versions - (PF.Reduction.reduceReal (transR rho I) (transD rho I)) - (PF.Reduction.Name.Orig (TName.Real n)) = - PF.Reduction.T.VSet.add PF.Reduction.Version.Bot - (PF.Reduction.embedVS - (versions rho (nameSubInst I n) (TName.Real n))). - Proof. - intros rho I n H; rewrite versions_lookupReal; apply versions_core. - destruct H as [[v Hv] | H]; [left | right; exact H]. - exists (TVer.RV v); apply mem_transR; left; exists (n, v); split; - [exact Hv | reflexivity]. - Qed. - - Theorem versions_lookupRootCore : forall rho I, - PF.Reduction.T.versions - (PF.Reduction.reduceReal (transR rho I) (transD rho I)) - (PF.Reduction.Name.Orig TName.Root) = - PF.Reduction.T.VSet.add PF.Reduction.Version.Bot - (PF.Reduction.embedVS (versions rho I TName.Root)). - Proof. - intros rho I; apply versions_core; left; exists TVer.UnitV. - apply mem_transR; right; left; reflexivity. - Qed. + Fixpoint ofNames (f : OFormula) : NSet.t := + match f with + | OFAtom n _ _ => NSet.singleton n + | OFAnd a b => NSet.union (ofNames a) (ofNames b) + | OFOr a b => NSet.union (ofNames a) (ofNames b) + end. - Theorem versions_lookupClsCore : forall rho I k, - (exists s h, - PF.Reduction.T.DepRel.In - (s, (PF.Reduction.Name.Orig (TName.Cls k), h)) - (PF.Reduction.reduceDeps (transR rho I) (transD rho I))) -> - PF.Reduction.T.versions - (PF.Reduction.reduceReal (transR rho I) (transD rho I)) - (PF.Reduction.Name.Orig (TName.Cls k)) = - PF.Reduction.T.VSet.add PF.Reduction.Version.Bot - (PF.Reduction.embedVS - (versions rho (classSubInst I k) (TName.Cls k))). - Proof. - intros rho I k H; rewrite versions_lookupCls; apply versions_core. - right; exact H. - Qed. + Definition listNames {A : Type} (names : A -> NSet.t) (l : list A) + : NSet.t := + List.fold_right (fun a acc => NSet.union (names a) acc) NSet.empty l. + + Definition declaredNames (I : Inst) (p : Pkg.t) : NSet.t := + NSet.union (listNames ofNames (ownedBy p (inst_dep I))) + (NSet.union + (listNames (fun nc => NSet.singleton (fst nc)) + (ownedBy p (inst_cfl I))) + (listNames (fun nvu => NSet.singleton (fst (fst nvu))) + (ownedBy p (inst_pind I)))). + + Definition clsFibre (cls : ClsRel.t) (p : Pkg.t) : ClsRel.t := + ClsRel.filter + (fun qk => if Pkg.eq_dec (fst qk) p then true else false) cls. + + Definition pkgSubInst (I : Inst) (p : Pkg.t) : Inst := + MkInst (realPreimage (declaredNames I p) (inst_repo I)) + (List.filter (ownb p) (inst_dep I)) + (List.filter (ownb p) (inst_cfl I)) + (clsFibre (inst_cls I) p) + (inst_avl I) + (List.filter (ownb p) (inst_dxt I)) + (inst_pins I) + (List.filter (ownb p) (inst_pind I)) + (inst_goal I) (inst_inv I). + + Definition nameSubInst (I : Inst) (n : N.t) : Inst := + MkInst (realPreimage (NSet.singleton n) (inst_repo I)) + (inst_dep I) (inst_cfl I) (inst_cls I) + (inst_avl I) (inst_dxt I) (inst_pins I) + (inst_pind I) (inst_goal I) (inst_inv I). + + Definition classSubInst (I : Inst) (k : N.t) : Inst := + MkInst PkgSet.empty nil nil + (Cls.Reduction.Lookup.classRelAt (inst_cls I) k) + nil nil PkgSet.empty nil (inst_goal I) (inst_inv I). + + Definition rootSubInst (I : Inst) : Inst := + MkInst + (realPreimage + (NSet.union (ofNames (inst_goal I)) (ofNames (inst_inv I))) + (inst_repo I)) + nil nil ClsRel.empty (inst_avl I) nil + (inst_pins I) nil (inst_goal I) (inst_inv I). + + Lemma srcVersions_restrict : forall rho I ns n, + NSet.In n ns -> + realVersions + (effRepo rho + (MkInst (realPreimage ns (inst_repo I)) (inst_dep I) + (inst_cfl I) (inst_cls I) (inst_avl I) + (inst_dxt I) (inst_pins I) (inst_pind I) + (inst_goal I) (inst_inv I))) n = + srcVersions rho I n. + Proof. + intros rho I ns n Hn; apply VSet.ext; intro v. + rewrite mem_realVersions. + unfold srcVersions; rewrite mem_realVersions. + rewrite !mem_effRepo; simpl. + unfold realPreimage; rewrite PkgPre.mem_ofKeys; simpl. + unfold PinOK, availOK; simpl; intuition. + Qed. + + Lemma srcVersions_subInst_agree : forall rho I sl ns n, + inst_repo sl = realPreimage ns (inst_repo I) -> + inst_avl sl = inst_avl I -> inst_pins sl = inst_pins I -> + NSet.In n ns -> + srcVersions rho sl n = srcVersions rho I n. + Proof. + intros rho I sl ns n Hr Ha Hp Hn. + unfold srcVersions at 1. + assert (E : effRepo rho sl = + effRepo rho + (MkInst (realPreimage ns (inst_repo I)) (inst_dep I) + (inst_cfl I) (inst_cls I) + (inst_avl I) (inst_dxt I) + (inst_pins I) (inst_pind I) (inst_goal I) + (inst_inv I))). + { unfold effRepo; rewrite Hr, Ha, Hp; reflexivity. } + rewrite E; apply (srcVersions_restrict rho I ns n Hn). + Qed. + + Lemma versSetBy_agree : forall Vq Vq' n c, + Vq n = Vq' n -> versSetBy Vq n c = versSetBy Vq' n c. + Proof. intros Vq Vq' n c H; unfold versSetBy; rewrite H; + reflexivity. Qed. + + Lemma encR_agree : forall rho Vq Vq' f, + (forall n, NSet.In n (ofNames f) -> Vq n = Vq' n) -> + forall g, redOF rho f = Some g -> encR Vq g = encR Vq' g. + Proof. + intros rho Vq Vq'. + induction f as [n g0 c | a IHa b IHb | a IHa b IHb]; + intros H g Hred; simpl in Hred. + 2,3: assert (Ha : forall m, NSet.In m (ofNames a) -> Vq m = Vq' m) + by (intros m Hm; apply H; simpl; apply NSet.union_spec; auto); + assert (Hb : forall m, NSet.In m (ofNames b) -> Vq m = Vq' m) + by (intros m Hm; apply H; simpl; apply NSet.union_spec; auto); + destruct (redOF rho a) eqn:Ea; destruct (redOF rho b) eqn:Eb; + simpl in Hred; try discriminate; injection Hred as <-; simpl; + [rewrite (IHa Ha _ eq_refl), (IHb Hb _ eq_refl); reflexivity + | exact (IHa Ha _ eq_refl) | exact (IHb Hb _ eq_refl)]. + destruct (defTrue rho g0); [| discriminate]. + injection Hred as <-; simpl. + rewrite (versSetBy_agree Vq Vq' n c); [reflexivity |]. + apply H; simpl; apply NSet.singleton_spec; reflexivity. + Qed. + + Lemma encodeOF_agree : forall rho Vq Vq' f, + (forall n, NSet.In n (ofNames f) -> Vq n = Vq' n) -> + encodeOF rho Vq f = encodeOF rho Vq' f. + Proof. + intros rho Vq Vq' f H; unfold encodeOF. + destruct (redOF rho f) as [g |] eqn:Hred; + [exact (encR_agree rho Vq Vq' f H g Hred) | reflexivity]. + Qed. + + Lemma cflForm_agree : forall rho Vq Vq' p nc, + Vq (fst nc) = Vq' (fst nc) -> + cflForm rho Vq p nc = cflForm rho Vq' p nc. + Proof. + intros rho Vq Vq' p [n [g c]] H; unfold cflForm, confVS; + cbn [fst snd]. + cbn [fst snd] in H. + destruct (defTrue rho g); [| reflexivity]. + destruct (N.eq_dec (fst p) n); [reflexivity |]. + rewrite (versSetBy_agree Vq Vq' n c H); reflexivity. + Qed. + + Lemma pindForm_agree : forall Vq Vq' nvu, + Vq (fst (fst nvu)) = Vq' (fst (fst nvu)) -> + pindForm Vq nvu = pindForm Vq' nvu. + Proof. + intros Vq Vq' [[n v] u] H; unfold pindForm; simpl in *. + rewrite H; reflexivity. + Qed. + + Lemma listNames_in : forall (A : Type) (names : A -> NSet.t) l n a, + In a l -> NSet.In n (names a) -> NSet.In n (listNames names l). + Proof. + intros A names l n a; induction l as [| b l IH]; simpl; + [intros [] |]. + intros [-> | Hin] Hn; apply NSet.union_spec; + [left; exact Hn | right; exact (IH Hin Hn)]. + Qed. + + Lemma ownedBy_filter : forall (A : Type) p (l : list (Pkg.t * A)), + ownedBy p (List.filter (ownb p) l) = ownedBy p l. + Proof. + intros A p l; unfold ownedBy; f_equal. + induction l as [| a l IH]; simpl; [reflexivity |]. + destruct (ownb p a) eqn:E; simpl; rewrite ?E, IH; reflexivity. + Qed. + + Theorem versions_lookupOrig : forall rho I n, + versions rho (nameSubInst I n) (TName.Real n) = + versions rho I (TName.Real n). + Proof. + intros rho I n; simpl. + rewrite (srcVersions_subInst_agree rho I (nameSubInst I n) + (NSet.singleton n) n); try reflexivity. + apply NSet.singleton_spec; reflexivity. + Qed. + + Module SOcd := SetOps ClsElt Pkg ClsRel PkgSet. + Definition declarers (cls : ClsRel.t) : PkgSet.t := SOcd.map fst cls. + + Lemma clsVersions_reduceReal : forall cls R k tv, + (forall q k', ClsRel.In (q, k') cls -> PkgSet.In q R) -> + PF.VSet.In tv (clsVersions cls k) <-> + exists n, tv = TVer.NV n /\ + Cls.Reduction.T.VSet.In (Cls.Reduction.Version.Name n) + (Cls.Reduction.T.versions (Cls.Reduction.reduceReal R cls) + (Cls.Reduction.Name.Cls k)). + Proof. + intros cls R k tv HR. + rewrite mem_clsVersions, Cls.Reduction.Lookup.versions_cls. + split. + - intros [q [Hq ->]]; exists (fst q); split; [reflexivity |]. + apply Cls.Reduction.Lookup.SOpv.mem_map; exists q; split; + [apply Cls.Reduction.Lookup.mem_inClass; split; + [exact (HR _ _ Hq) | exact Hq] + | reflexivity]. + - intros [n [-> Hn]]; apply Cls.Reduction.Lookup.SOpv.mem_map in Hn. + destruct Hn as [q [Hq E]]; injection E as ->. + apply Cls.Reduction.Lookup.mem_inClass in Hq. + exists q; split; [exact (proj2 Hq) | reflexivity]. + Qed. + + Theorem versions_lookupClass : forall rho I k, + versions rho (classSubInst I k) (TName.Cls k) = + versions rho I (TName.Cls k). + Proof. + intros rho I k; cbn [versions classSubInst inst_cls]. + assert (HD : forall q k', ClsRel.In (q, k') (inst_cls I) -> + PkgSet.In q (declarers (inst_cls I))) + by (intros q k' H; apply SOcd.mem_map; exists (q, k'); + split; [exact H | reflexivity]). + apply PF.VSet.ext; intro tv. + rewrite (clsVersions_reduceReal (inst_cls I) _ _ _ HD), + (Cls.Reduction.Lookup.versions_lookupClass (declarers (inst_cls I))). + apply clsVersions_reduceReal; intros q k' H. + apply Cls.Reduction.Lookup.mem_classRelAt in H; destruct H as [H ->]. + apply Cls.Reduction.Lookup.mem_inClass; split; + [exact (HD _ _ H) | exact H]. + Qed. + + Theorem dependees_lookupRoot : forall rho I, + dependees rho (rootSubInst I) rootPkg = dependees rho I rootPkg. + Proof. + intros rho I; unfold dependees, dependeesBy, rootPkg, rootForm. + assert (H : forall n, + NSet.In n (NSet.union (ofNames (inst_goal I)) + (ofNames (inst_inv I))) -> + srcVersions rho (rootSubInst I) n = srcVersions rho I n) + by (intros n Hn; + apply (srcVersions_subInst_agree rho I (rootSubInst I) + (NSet.union (ofNames (inst_goal I)) + (ofNames (inst_inv I))) n); + reflexivity || exact Hn). + cbn [rootSubInst inst_goal inst_inv]. + rewrite !(encodeOF_agree rho (srcVersions rho (rootSubInst I)) + (srcVersions rho I)) + by (intros n Hn; apply H, NSet.union_spec; auto). + reflexivity. + Qed. + + Theorem dependees_lookupOrig : forall rho I n v, + dependees rho (pkgSubInst I (n, v)) (embedPkg (n, v)) = + dependees rho I (embedPkg (n, v)). + Proof. + intros rho I n v; unfold dependees. + assert (HVq : forall m, NSet.In m (declaredNames I (n, v)) -> + srcVersions rho (pkgSubInst I (n, v)) m = + srcVersions rho I m). + { intros m Hm. + apply (srcVersions_subInst_agree rho I (pkgSubInst I (n, v)) + (declaredNames I (n, v)) m); reflexivity || exact Hm. } + unfold embedPkg, declaredNames in *; cbn [fst snd dependeesBy]. + unfold depForms, cflForms, pindForms. + cbn [pkgSubInst inst_dep inst_cfl inst_cls inst_pins inst_pind]. + rewrite !ownedBy_filter. + f_equal; [| f_equal; [| f_equal]]. + - f_equal; apply List.map_ext_in; intros f0 Hin. + apply encodeOF_agree; intros m Hm; apply HVq. + apply NSet.union_spec; left; exact (listNames_in _ _ _ _ _ Hin Hm). + - f_equal; apply List.map_ext_in; intros [m nc] Hin. + apply cflForm_agree, HVq; rewrite !NSet.union_spec; right; left. + apply (listNames_in _ _ _ _ _ Hin), NSet.singleton_spec; reflexivity. + - apply FSet.ext; intro f; apply SOcf.filterMap_restrict. + + intros qk Hqk; apply ClsRel.filter_spec' in Hqk; apply Hqk. + + intros [q k] Hqk Hf; apply ClsRel.filter_spec'. + split; [exact Hqk |]. + cbn beta iota in Hf; cbn [fst]. + destruct (Pkg.eq_dec q (n, v)); [reflexivity | discriminate Hf]. + - destruct (PkgSet.mem (n, v) (inst_pins I)); [| reflexivity]. + f_equal; apply List.map_ext_in; intros nvu Hin. + apply pindForm_agree, HVq; rewrite !NSet.union_spec; right; right. + apply (listNames_in _ _ _ _ _ Hin), NSet.singleton_spec; reflexivity. + Qed. + + Lemma versions_reduceReal : forall rho I tn, + PF.C.versions (reduceReal rho I) tn = versions rho I tn. + Proof. + intros rho I tn; apply PF.VSet.ext; intro tv. + rewrite PF.C.mem_versions, mem_reduceReal. + destruct tn as [| n | k]; cbn [versions]. + - rewrite PF.VSet.singleton_spec; split. + + intros [[p [_ E]] | [E | [p [k [_ E]]]]]; + unfold embedPkg, rootPkg in E; try discriminate E. + injection E as ->; reflexivity. + + intros ->; right; left; reflexivity. + - rewrite SOvv.mem_map; split. + + intros [[[m w] [Hp E]] | [E | [p [k [_ E]]]]]; + unfold embedPkg, rootPkg in E; cbn [fst snd] in E; + try discriminate E. + injection E as -> ->; exists w; split; + [apply mem_srcVersions; exact Hp | reflexivity]. + + intros [v [Hv ->]]; left; exists (n, v); split; + [apply mem_srcVersions; exact Hv | reflexivity]. + - rewrite mem_clsVersions; split. + + intros [[p [_ E]] | [E | [p [k' [Hpk E]]]]]; + unfold embedPkg, rootPkg in E; try discriminate E. + injection E as -> ->; exists p; split; [exact Hpk | reflexivity]. + + intros [p [Hpk ->]]; right; right; exists p, k; split; + [exact Hpk | reflexivity]. + Qed. + + Lemma reduceDeps_tailFibre : forall rho I q, + PF.PkgSet.In q (reduceReal rho I) -> + PF.Reduction.Lookup.DepRelFibred.tailFibre (reduceDeps rho I) q = + depEdges q (dependees rho I q). + Proof. + intros rho I q Hq; apply PF.DepRel.ext; intros [q' f]. + rewrite PF.Reduction.Lookup.DepRelFibred.mem_tailFibre, mem_reduceDeps. + unfold depEdges; rewrite SOfd.mem_map. + split. + - intros [[_ Hf] ->]; exists f; split; [exact Hf | reflexivity]. + - intros [f0 [Hf0 E]]; mem_destruct. + split; [split; [exact Hq | exact Hf0] | reflexivity]. + Qed. + + Lemma negNames_encR : forall Vq g x, + ~ PF.Reduction.NSet.In x (PF.Reduction.Lookup.negNames (encR Vq g)). + Proof. + intros Vq g x; + induction g as [n c | a IHa b IHb | a IHa b IHb]; + cbn [encR PF.Reduction.Lookup.negNames]. + - apply PF.Reduction.NSet.empty_spec. + - rewrite PF.Reduction.NSet.union_spec; tauto. + - rewrite PF.Reduction.NSet.union_spec; tauto. + Qed. + + Lemma dependees_negNames : forall rho Vq I q f x, + FSet.In f (dependeesBy rho Vq I q) -> + PF.Reduction.NSet.In x (PF.Reduction.Lookup.negNames f) -> + exists m, x = TName.Real m. + Proof. + intros rho Vq I [tn tv] f x Hf Hx. + assert (HT : ~ PF.Reduction.NSet.In x + (PF.Reduction.Lookup.negNames PTrue)) + by apply PF.Reduction.NSet.empty_spec. + assert (Henc : forall f0, + ~ PF.Reduction.NSet.In x + (PF.Reduction.Lookup.negNames (encodeOF rho Vq f0))). + { intro f0; unfold encodeOF. + destruct (redOF rho f0); [apply negNames_encR | exact HT]. } + destruct tn as [| n | k]; destruct tv as [v | | m]; + try (cbn [dependeesBy] in Hf; destruct (FSet.empty_spec Hf)). + - cbn [dependeesBy] in Hf; apply FSet.singleton_spec in Hf; subst f. + unfold rootForm in Hx; cbn [PF.Reduction.Lookup.negNames] in Hx. + apply PF.Reduction.NSet.union_spec in Hx. + destruct Hx as [Hx | Hx]; destruct (Henc _ Hx). + - apply mem_dependees_real in Hf. + destruct Hf as [[f0 [_ ->]] | [[[nc [g c]] [_ ->]] + | [[k [_ ->]] | [_ [[[m u] y] [_ ->]]]]]]. + + destruct (Henc f0 Hx). + + unfold cflForm in Hx; cbn [fst snd] in Hx. + destruct (defTrue rho g); [| destruct (HT Hx)]. + cbn [PF.Reduction.Lookup.negNames PF.Reduction.fnames] in Hx. + apply PF.Reduction.NSet.singleton_spec in Hx; exists nc; exact Hx. + + destruct (PF.Reduction.NSet.empty_spec Hx). + + unfold pindForm in Hx; + cbn [fst snd PF.Reduction.Lookup.negNames PF.Reduction.fnames] + in Hx. + apply PF.Reduction.NSet.singleton_spec in Hx; exists m; exact Hx. + Qed. + + Lemma dependees_core : forall rho I Vq q, + PF.PkgSet.In q (reduceReal rho I) -> + (forall m, Vq (TName.Real m) = versions rho I (TName.Real m)) -> + PF.Reduction.T.dependees + (PF.Reduction.reduceDeps (reduceReal rho I) (reduceDeps rho I)) + (PF.Reduction.Name.Orig (fst q), + PF.Reduction.Version.Orig (snd q)) = + PF.Reduction.T.dependees + (PF.Reduction.reduceDepsBy Vq (depEdges q (dependees rho I q))) + (PF.Reduction.Name.Orig (fst q), + PF.Reduction.Version.Orig (snd q)). + Proof. + intros rho I Vq [tn tv] Hq HVq; cbn [fst snd]. + rewrite + (PF.Reduction.Lookup.dependees_lookupOrigBy _ _ (versions rho I)) + by (intros n _; symmetry; apply versions_reduceReal). + rewrite (reduceDeps_tailFibre rho I (tn, tv) Hq). + f_equal; apply PF.Reduction.Lookup.reduceDepsBy_agreeNeg. + intros p f x Hpf Hx. + unfold depEdges in Hpf; apply SOfd.mem_map in Hpf as [f0 [Hf0 E]]. + mem_destruct. + destruct (dependees_negNames _ _ _ _ _ _ Hf0 Hx) as [m ->]. + symmetry; apply HVq. + Qed. + + Theorem dependees_lookupOrigCore : forall rho I Vq n v, + PkgSet.In (n, v) (effRepo rho I) -> + (forall m, Vq (TName.Real m) = versions rho I (TName.Real m)) -> + PF.Reduction.T.dependees + (PF.Reduction.reduceDeps (reduceReal rho I) (reduceDeps rho I)) + (PF.Reduction.embedPkg (embedPkg (n, v))) = + PF.Reduction.T.dependees + (PF.Reduction.reduceDepsBy Vq + (depEdges (embedPkg (n, v)) + (dependees rho (pkgSubInst I (n, v)) (embedPkg (n, v))))) + (PF.Reduction.embedPkg (embedPkg (n, v))). + Proof. + intros rho I Vq n v Hnv HVq; rewrite dependees_lookupOrig. + apply (dependees_core rho I Vq (embedPkg (n, v))); [| exact HVq]. + apply mem_reduceReal; left; exists (n, v); split; + [exact Hnv | reflexivity]. + Qed. + + Theorem dependees_lookupRootCore : forall rho I Vq, + (forall m, Vq (TName.Real m) = versions rho I (TName.Real m)) -> + PF.Reduction.T.dependees + (PF.Reduction.reduceDeps (reduceReal rho I) (reduceDeps rho I)) + (PF.Reduction.embedPkg rootPkg) = + PF.Reduction.T.dependees + (PF.Reduction.reduceDepsBy Vq + (depEdges rootPkg (dependees rho (rootSubInst I) rootPkg))) + (PF.Reduction.embedPkg rootPkg). + Proof. + intros rho I Vq HVq; rewrite dependees_lookupRoot. + apply (dependees_core rho I Vq rootPkg); [| exact HVq]. + apply mem_reduceReal; right; left; reflexivity. + Qed. + + Theorem dependees_lookupClassCore : forall rho I k w, + PF.Reduction.T.dependees + (PF.Reduction.reduceDeps (reduceReal rho I) (reduceDeps rho I)) + (PF.Reduction.Name.Orig (TName.Cls k), + PF.Reduction.Version.Orig w) = + PF.Reduction.T.DependeesSet.empty. + Proof. + intros rho I k w; apply PF.Reduction.T.dependees_empty_iff; intros h H. + apply PF.Reduction.mem_reduceDeps in H. + destruct H as [[pn pv] [f [Hd He]]]. + assert (E := proj1 (PF.Reduction.Lookup.encodeNNF_src_orig_aux _ f) + _ _ _ _ He). + unfold PF.Reduction.embedPkg in E; injection E as -> ->. + apply mem_reduceDeps in Hd; destruct Hd as [_ Hf]. + unfold dependees, dependeesBy in Hf. + destruct w; destruct (FSet.empty_spec Hf). + Qed. + + Theorem dependees_lookupDisjunctCore : forall rho I I' Vq q fs i, + PF.PkgSet.In q (reduceReal rho I) -> + dependees rho I' q = dependees rho I q -> + (forall m, Vq (TName.Real m) = versions rho I (TName.Real m)) -> + PF.Reduction.T.PkgSet.In (PF.Reduction.Name.Disjunct fs, i) + (PF.Reduction.reduceReal (PF.PkgSet.singleton q) + (depEdges q (dependees rho I' q))) -> + PF.Reduction.T.dependees + (PF.Reduction.reduceDeps (reduceReal rho I) (reduceDeps rho I)) + (PF.Reduction.Name.Disjunct fs, i) = + PF.Reduction.T.dependees + (PF.Reduction.reduceDepsBy Vq (depEdges q (dependees rho I' q))) + (PF.Reduction.Name.Disjunct fs, i). + Proof. + intros rho I I' Vq q fs i Hq HI HVq Hin; rewrite HI in Hin |- *. + assert (Hsub : PF.DepRel.Subset (depEdges q (dependees rho I q)) + (reduceDeps rho I)). + { rewrite <- (reduceDeps_tailFibre rho I q Hq). + apply PF.Reduction.Lookup.DepRelFibred.tailFibre_subset. } + apply (PF.Reduction.Lookup.dependees_lookupDisjunctBy + _ _ _ _ _ _ _ Hsub Hin). + intros p f x Hpf Hx. + unfold depEdges in Hpf; apply SOfd.mem_map in Hpf as [f0 [Hf0 E]]. + mem_destruct. + destruct (dependees_negNames _ _ _ _ _ _ Hf0 Hx) as [m ->]. + rewrite HVq, versions_reduceReal; reflexivity. + Qed. + + Lemma versions_core : forall rho I tn, + (exists tv, PF.PkgSet.In (tn, tv) (reduceReal rho I)) \/ + (exists s h, + PF.Reduction.T.DepRel.In (s, (PF.Reduction.Name.Orig tn, h)) + (PF.Reduction.reduceDeps (reduceReal rho I) + (reduceDeps rho I))) -> + PF.Reduction.T.versions + (PF.Reduction.reduceReal (reduceReal rho I) (reduceDeps rho I)) + (PF.Reduction.Name.Orig tn) = + PF.Reduction.T.VSet.add PF.Reduction.Version.Bot + (PF.Reduction.embedVS (versions rho I tn)). + Proof. + intros rho I tn Hreach. + assert (Hr : PF.PkgSet.In rootPkg (reduceReal rho I)) + by (apply mem_reduceReal; right; left; reflexivity). + destruct Hreach as [[tv Htv] | Hreach]; + [rewrite (PF.Reduction.Lookup.versions_lookupOrig _ _ (tn, tv) tn Htv + (or_intror eq_refl) eq_refl) + | rewrite (PF.Reduction.Lookup.versions_lookupOrig _ _ rootPkg tn Hr + (or_introl Hreach) eq_refl)]; + do 2 f_equal; rewrite <- versions_reduceReal; + apply PF.C.versions_ext; intro v; + rewrite PF.Reduction.Lookup.PkgFibred.mem_tailFibre; tauto. + Qed. + + Theorem versions_lookupOrigCore : forall rho I n, + (exists v, PkgSet.In (n, v) (effRepo rho I)) \/ + (exists s h, + PF.Reduction.T.DepRel.In + (s, (PF.Reduction.Name.Orig (TName.Real n), h)) + (PF.Reduction.reduceDeps (reduceReal rho I) + (reduceDeps rho I))) -> + PF.Reduction.T.versions + (PF.Reduction.reduceReal (reduceReal rho I) (reduceDeps rho I)) + (PF.Reduction.Name.Orig (TName.Real n)) = + PF.Reduction.T.VSet.add PF.Reduction.Version.Bot + (PF.Reduction.embedVS + (versions rho (nameSubInst I n) (TName.Real n))). + Proof. + intros rho I n H; rewrite versions_lookupOrig; apply versions_core. + destruct H as [[v Hv] | H]; [left | right; exact H]. + exists (TVer.RV v); apply mem_reduceReal; left; exists (n, v); split; + [exact Hv | reflexivity]. + Qed. + + Theorem versions_lookupRootCore : forall rho I, + PF.Reduction.T.versions + (PF.Reduction.reduceReal (reduceReal rho I) (reduceDeps rho I)) + (PF.Reduction.Name.Orig TName.Root) = + PF.Reduction.T.VSet.add PF.Reduction.Version.Bot + (PF.Reduction.embedVS (versions rho I TName.Root)). + Proof. + intros rho I; apply versions_core; left; exists TVer.UnitV. + apply mem_reduceReal; right; left; reflexivity. + Qed. + + Theorem versions_lookupClassCore : forall rho I k, + (exists s h, + PF.Reduction.T.DepRel.In + (s, (PF.Reduction.Name.Orig (TName.Cls k), h)) + (PF.Reduction.reduceDeps (reduceReal rho I) + (reduceDeps rho I))) -> + PF.Reduction.T.versions + (PF.Reduction.reduceReal (reduceReal rho I) (reduceDeps rho I)) + (PF.Reduction.Name.Orig (TName.Cls k)) = + PF.Reduction.T.VSet.add PF.Reduction.Version.Bot + (PF.Reduction.embedVS + (versions rho (classSubInst I k) (TName.Cls k))). + Proof. + intros rho I k H; rewrite versions_lookupClass; apply versions_core. + right; exact H. + Qed. + End Lookup. End Reduction. End Opam. diff --git a/theories/PackageFormula.v b/theories/PackageFormula.v index cff25b2..9e08ff8 100644 --- a/theories/PackageFormula.v +++ b/theories/PackageFormula.v @@ -9,8 +9,6 @@ Create Rewrite HintDb cmp_pkgf. into the products and conjunctions of the conjuncts themselves. *) Ltac split4 := split; [| split; [| split]]. -(* Which names the reduction gives the absent version: a negated atom on a - name without it can be met only by one of that name's versions. *) Module Type AbsentNames (N : UsualOrderedType). Parameter hasAbsent : N.t -> bool. End AbsentNames. @@ -636,9 +634,6 @@ Module FormulaCalculus (N V : UsualOrderedType) (Ab : AbsentNames N). - discriminate Hy. Qed. - (* A source model agrees with a core one wherever the core decides: - at names with the absent version, and at names the core holds a - real version of. *) Definition AgreesOn (S : T.PkgSet.t) (M : PkgSet.t) : Prop := forall m v, (Ab.hasAbsent m = true \/ @@ -1799,8 +1794,6 @@ Module FormulaCalculus (N V : UsualOrderedType) (Ab : AbsentNames N). | _ => None end. - (* An original package's edges start only at the package the - encoding was asked about: every other source is a disjunct. *) Lemma encodeNNF_src_orig_aux : forall Vq f, (forall (q : T.Pkg.t) m (w : Version.t) (d : T.Dependees.t), T.DepRel.In ((Name.Orig m, w), d) (encodeNNF Vq q f) -> @@ -1983,9 +1976,6 @@ Module FormulaCalculus (N V : UsualOrderedType) (Ab : AbsentNames N). | rewrite (proj1 (encodeNNF_agree_aux Vq Vq' f Hf))]; exact He. Qed. - (* A negated atom's complement is the encoder's only read of its - oracle, so a name a formula mentions only positively is never - asked: a driver's oracle may be partial there. *) Fixpoint negNames (f : Formula) : NSet.t := match f with | FDep _ _ => NSet.empty @@ -2294,16 +2284,6 @@ Module FormulaCalculus (N V : UsualOrderedType) (Ab : AbsentNames N). rewrite versions_realPreimage by exact Hn; symmetry; apply HVq; exact Hn. Qed. - Theorem root_not_absent : forall R D r S, - T.IsResolution (reduceReal R D) (reduceDeps R D) (embedPkg r) S -> - ~ T.PkgSet.In (Name.Orig (fst r), Version.Bot) S. - Proof. - intros R D [rn rv] S Hres Hb. - assert (E := T.res_version_unique _ _ _ _ Hres _ _ _ - (T.res_root_mem _ _ _ _ Hres) Hb). - discriminate E. - Qed. - Theorem dependees_lookupAbsent : forall R D m, T.dependees (reduceDeps R D) (Name.Orig m, Version.Bot) = T.DependeesSet.empty. diff --git a/theories/Prelude.v b/theories/Prelude.v index 1261118..ec06850 100644 --- a/theories/Prelude.v +++ b/theories/Prelude.v @@ -1,15 +1,5 @@ From Stdlib Require Import MSetList Lia. -(* Sets are MSetList.MakeWithLeibniz -- sorted duplicate-free lists -- because - the representation is canonical: two sets with the same elements are the same - term, so set equality is Leibniz =, statements never mention setoid - equivalences, and no Proper (respectfulness) side-conditions arise - anywhere. The cost is that "sorted" needs a total order on every element - type, including tuples, synthetic names, formulas, and sets themselves. - The stdlib's own compare-first path (OrderedTypeAlt) and product functors are - unergonomic because they land in setoid equality; this file contains the - small Leibniz-preserving replacement for that ecosystem gap. *) - (* enum is data, not an "exists a listing" fact (Stdlib's Finite): witnesses iterate it, so it must survive extraction. *) Module Type FiniteUsualOrderedType. @@ -168,6 +158,12 @@ Proof. [reflexivity | contradiction NE; reflexivity]. Qed. +(* A guard inside a pattern-matching comprehension body is only exposed + once the element is destructed, too late for mem_filterMap_if. *) +Lemma if_some_iff : forall (A : Type) (b : bool) (x y : A), + (if b then Some x else None) = Some y <-> b = true /\ x = y. +Proof. intros A [|] x y; cbn; intuition congruence. Qed. + (* Deciding equality inside a set-comprehension guard means an if-then-else on eq_dec, whose two branches then have to be re-derived at every proof that reads the guard back; this packages the test with its three laws. *) @@ -697,14 +693,6 @@ Module FibredLabelledRel (T N L : UsualOrderedType) Qed. End FibredLabelledRel. -(* The other way a lookup theorem cuts a set down: its elements carry a key -- - a package set read as a name-to-version relation projects to names -- and - the preimage of the wanted keys under that projection is all of the set a - computation that consults only those keys can see. Which keys are wanted - arrives as a test rather than as a set, so that the two entry points share - this one definition: keys already materialized (PreimageOfKeys.ofKeys), and - the keys a relation's edges point at (RelKeys.hasKey), which stays a - semijoin and never materializes them. *) Module Preimage (A : UsualOrderedType) (S : SetsOn A). Module SS := SetSpecs A S. @@ -842,10 +830,6 @@ Module SetOps (A B : UsualOrderedType) (SA : SetsOn A) (SB : SetsOn B). right; exists e; split; [apply elements_in; exact He | exact Hh]. Qed. - (* The comprehensions go through ofList/unions rather than a fold of add or - union, so that each builds its result with one merge sort instead of n - quadratic insertions; the specs are extensional, so nothing downstream - sees the change. *) Definition map (f : A.t -> B.t) (s : SA.t) : SB.t := ofList (List.map f (SA.elements s)). @@ -947,9 +931,6 @@ Module SetOps (A B : UsualOrderedType) (SA : SetsOn A) (SB : SetsOn B). - intros [x [Hx Hf]]; exists x; split; [exact (Hkeep _ Hx Hf) | exact Hf]. Qed. - (* The guarded comprehensions: a filterMap or unionMap whose body is an - if on a boolean test or a decision. Each reads back as the witness, - the test holding, and the body. *) Lemma mem_filterMap_if : forall (b : A.t -> bool) (f : A.t -> B.t) s y, SB.In y (filterMap (fun x => if b x then Some (f x) else None) s) <-> exists x : A.t, SA.In x s /\ b x = true /\ y = f x. diff --git a/theories/Smoke.v b/theories/Smoke.v index 1296db7..f0f180c 100644 --- a/theories/Smoke.v +++ b/theories/Smoke.v @@ -1,14 +1,8 @@ -(* Smoke tests. Functor bodies are checked abstractly, so some errors - surface only at application time; and the reflexivity examples fail if - any definition they exercise stops computing to a normal form (opaque - or classical terms in the computational path), which extraction - depends on. *) - -From Stdlib Require Import MSets. +From Stdlib Require Import MSets List. From PackageCalculus Require Import Prelude Core Complexity Versions Semver Conflict ConflictClass Concurrent PeerDependency Visibility Feature Virtual PackageFormula VariableFormula FeatureConcurrent Debian DebianMA - Opam Cargo Alpine. + Opam Cargo Alpine Npm. Module C := Core Nat_as_OT Nat_as_OT. Module Cx := Complexity Nat_as_OT Nat_as_OT Nat_as_OT. @@ -269,7 +263,6 @@ Definition opInst : Op.Inst := (((1, 10), Op.OFAtom 2 (Op.FlCmp OpEq false 1) (Op.VCCmp OpGe 15)) :: nil) nil - nil Op.ClsRel.empty nil (((2, 20), (7, Op.FlTrue)) :: nil) @@ -278,13 +271,13 @@ Definition opInst : Op.Inst := (Op.OFAtom 1 Op.FlTrue Op.VCTop) (Op.OFAtom 1 Op.FlFalse Op.VCTop). -Example opam_transR_computes : - Op.Reduction.PF.PkgSet.cardinal (Op.Reduction.transR opRho opInst) = 3. +Example opam_reduceReal_computes : + Op.Reduction.PF.PkgSet.cardinal (Op.Reduction.reduceReal opRho opInst) = 3. Proof. reflexivity. Qed. -Example opam_transD_computes : +Example opam_reduceDeps_computes : Op.Reduction.PF.DepRel.cardinal - (Op.Reduction.transD opRho opInst) = 2. + (Op.Reduction.reduceDeps opRho opInst) = 2. Proof. reflexivity. Qed. Example opam_depexts_computes : @@ -351,11 +344,10 @@ Definition alpI : Alp.Inst := (Alp.CondSet.add (Alp.DNeg (5, Alp.CAny)) Alp.CondSet.empty)) Alp.InstallIf.empty ; Alp.inst_world := Alp.WSet.add (Alp.DPos (1, Alp.CAny)) Alp.WSet.empty - ; Alp.inst_prio := Alp.Prio.empty - ; Alp.inst_repl := Alp.Repl.empty |}. + ; Alp.inst_prio := Alp.Prio.empty |}. -Example alpine_transR_computes : - Alp.Reduction.PF.PkgSet.cardinal (Alp.Reduction.transR alpI) = 5. +Example alpine_reduceReal_computes : + Alp.Reduction.PF.PkgSet.cardinal (Alp.Reduction.reduceReal alpI) = 5. Proof. reflexivity. Qed. Example alpine_root_dependees_computes : @@ -370,3 +362,180 @@ Proof. reflexivity. Qed. Example alpine_versions_computes : Alp.Reduction.PF.VSet.cardinal (Alp.Reduction.versions alpI 4) = 1. Proof. reflexivity. Qed. + +Module NpmVM <: SemverMatch Nat_as_OT. + Definition isPre (_ : nat) : bool := false. + Definition sameCore (a b : nat) : bool := Nat.eqb a b. +End NpmVM. + +Module NpmS := Npm Nat_as_OT Nat_as_OT NpmVM. + +Definition npmA : nat := 1. +Definition npmB : nat := 2. +Definition npmC : nat := 3. +Definition npmX : nat := 4. + +Definition npmEq (v : nat) : NpmS.Range := (NpmS.COp OpEq v :: nil) :: nil. + +Definition npmBetween (lo hi : nat) : NpmS.Range := + (NpmS.COp OpGe lo :: NpmS.COp OpLt hi :: nil) :: nil. + +Definition npmRepo : NpmS.RepoSet.t := + fold_right NpmS.RepoSet.add NpmS.RepoSet.empty + ((npmA, 1) :: (npmB, 1) :: (npmC, 1) :: (npmC, 2) :: (npmC, 3) :: nil). + +Definition npmDepB : NpmS.Dependency := NpmS.MkDep npmB npmB (npmEq 1) false. +Definition npmDepC : NpmS.Dependency := + NpmS.MkDep npmC npmC (npmBetween 2 4) false. +Definition npmPeerC : NpmS.PeerDependency := + NpmS.MkPeer npmC (npmBetween 1 3) false. +Definition npmPeerCOpt : NpmS.PeerDependency := + NpmS.MkPeer npmC (npmBetween 1 3) true. + +Definition kA : NpmS.NKey.t := (npmA, npmA). +Definition kB : NpmS.NKey.t := (npmB, npmB). +Definition kC : NpmS.NKey.t := (npmC, npmC). +Definition kX : NpmS.NKey.t := (npmX, npmC). + +Definition npmShow (h : NpmS.T.Dependees.t) + : NpmS.Nm.t * list NpmS.Vs.t := + (fst h, NpmS.T.VSet.elements (snd h)). + +Definition npmDeps (I : NpmS.Inst) (s : NpmS.T.Pkg.t) := + List.map npmShow + (NpmS.T.DependeesSet.elements (NpmS.Reduction.dependees I s)). + +Definition npmInst : NpmS.Inst := + NpmS.MkInst npmRepo + (((npmA, 1), npmDepB) :: ((npmA, 1), npmDepC) :: nil) + (((npmB, 1), npmPeerC) :: nil) nil (npmA, 1). + +Definition npmInstAuto : NpmS.Inst := + NpmS.MkInst npmRepo (((npmA, 1), npmDepB) :: nil) + (((npmB, 1), npmPeerC) :: nil) nil (npmA, 1). + +Definition npmInstRootPeer : NpmS.Inst := + NpmS.MkInst npmRepo (((npmA, 1), npmDepC) :: nil) + (((npmA, 1), npmPeerC) :: nil) nil (npmA, 1). + +Definition npmInstRootPeerOpt : NpmS.Inst := + NpmS.MkInst npmRepo (((npmA, 1), npmDepC) :: nil) + (((npmA, 1), npmPeerCOpt) :: nil) nil (npmA, 1). + +Definition npmInstRootPeerOptBare : NpmS.Inst := + NpmS.MkInst npmRepo (((npmA, 1), npmDepB) :: nil) + (((npmA, 1), npmPeerCOpt) :: nil) nil (npmA, 1). + +Definition npmInstOpt : NpmS.Inst := + NpmS.MkInst npmRepo (((npmA, 1), npmDepB) :: nil) + (((npmB, 1), npmPeerCOpt) :: nil) nil (npmA, 1). + +Definition npmDepAlias : NpmS.Dependency := + NpmS.MkDep npmX npmC (npmEq 1) false. + +Definition npmInstAlias : NpmS.Inst := + NpmS.MkInst npmRepo + (((npmA, 1), npmDepC) :: ((npmA, 1), npmDepAlias) :: nil) + nil nil (npmA, 1). + +Definition npmInstOvr : NpmS.Inst := + NpmS.MkInst npmRepo (((npmA, 1), npmDepC) :: nil) nil + ((npmC, npmEq 3) :: nil) (npmA, 1). + +Example npm_versions_computes : + NpmS.T.VSet.elements + (NpmS.Reduction.versions npmInst (NpmS.Nm.Granular kC 2)) + = NpmS.Vs.Orig 2 :: nil. +Proof. reflexivity. Qed. + +Example npm_entry_edges_computes : + npmDeps npmInst (NpmS.Nm.Granular kA 1, NpmS.Vs.Orig 1) + = (NpmS.Nm.Intermediate kA 1 kB, NpmS.Vs.Orig 1 :: nil) + :: (NpmS.Nm.Intermediate kA 1 kC, + NpmS.Vs.Orig 2 :: NpmS.Vs.Orig 3 :: nil) :: nil. +Proof. reflexivity. Qed. + +Example npm_slot_versions_computes : + NpmS.T.VSet.elements + (NpmS.Reduction.versions npmInst (NpmS.Nm.Intermediate kA 1 kC)) + = NpmS.Vs.Orig 2 :: NpmS.Vs.Orig 3 :: nil. +Proof. reflexivity. Qed. + +Example npm_peer_edge_computes : + npmDeps npmInst (NpmS.Nm.Intermediate kA 1 kB, NpmS.Vs.Orig 1) + = (NpmS.Nm.Granular kB 1, NpmS.Vs.Orig 1 :: nil) + :: (NpmS.Nm.Intermediate kA 1 kC, + NpmS.Vs.Orig 1 :: NpmS.Vs.Orig 2 :: nil) :: nil. +Proof. reflexivity. Qed. + +Example npm_auto_versions_computes : + NpmS.T.VSet.elements + (NpmS.Reduction.versions npmInstAuto + (NpmS.Nm.Intermediate kA 1 kC)) + = NpmS.Vs.Orig 1 :: NpmS.Vs.Orig 2 :: NpmS.Vs.Orig 3 :: nil. +Proof. reflexivity. Qed. + +Example npm_auto_edge_computes : + npmDeps npmInstAuto (NpmS.Nm.Intermediate kA 1 kB, NpmS.Vs.Orig 1) + = (NpmS.Nm.Granular kB 1, NpmS.Vs.Orig 1 :: nil) + :: (NpmS.Nm.Intermediate kA 1 kC, + NpmS.Vs.Orig 1 :: NpmS.Vs.Orig 2 :: nil) :: nil. +Proof. reflexivity. Qed. + +Example npm_optional_edge_computes : + npmDeps npmInstOpt (NpmS.Nm.Intermediate kA 1 kB, NpmS.Vs.Orig 1) + = (NpmS.Nm.Granular kB 1, NpmS.Vs.Orig 1 :: nil) :: nil. +Proof. reflexivity. Qed. + +Example npm_root_peer_computes : + npmDeps npmInstRootPeer (NpmS.Nm.Granular kA 1, NpmS.Vs.Orig 1) + = (NpmS.Nm.Intermediate kA 1 kC, NpmS.Vs.Orig 1 :: NpmS.Vs.Orig 2 :: nil) + :: (NpmS.Nm.Intermediate kA 1 kC, + NpmS.Vs.Orig 2 :: NpmS.Vs.Orig 3 :: nil) :: nil. +Proof. reflexivity. Qed. + +Example npm_root_peer_optional_computes : + npmDeps npmInstRootPeerOpt (NpmS.Nm.Granular kA 1, NpmS.Vs.Orig 1) + = npmDeps npmInstRootPeer (NpmS.Nm.Granular kA 1, NpmS.Vs.Orig 1). +Proof. reflexivity. Qed. + +Example npm_root_peer_optional_bare_computes : + npmDeps npmInstRootPeerOptBare (NpmS.Nm.Granular kA 1, NpmS.Vs.Orig 1) + = (NpmS.Nm.Intermediate kA 1 kB, NpmS.Vs.Orig 1 :: nil) :: nil. +Proof. reflexivity. Qed. + +Example npm_alias_computes : + npmDeps npmInstAlias (NpmS.Nm.Granular kA 1, NpmS.Vs.Orig 1) + = (NpmS.Nm.Intermediate kA 1 kC, + NpmS.Vs.Orig 2 :: NpmS.Vs.Orig 3 :: nil) + :: (NpmS.Nm.Intermediate kA 1 kX, NpmS.Vs.Orig 1 :: nil) :: nil. +Proof. reflexivity. Qed. + +Example npm_override_computes : + npmDeps npmInstOvr (NpmS.Nm.Granular kA 1, NpmS.Vs.Orig 1) + = (NpmS.Nm.Intermediate kA 1 kC, NpmS.Vs.Orig 3 :: nil) :: nil. +Proof. reflexivity. Qed. + +Module NpmPreVM <: SemverMatch Nat_as_OT. + Definition isPre (v : nat) : bool := Nat.odd v. + Definition sameCore (a b : nat) : bool := + Nat.eqb (Nat.div a 2) (Nat.div b 2). +End NpmPreVM. + +Module NpmP := Npm Nat_as_OT Nat_as_OT NpmPreVM. + +Definition npmPreRepo : NpmP.RepoSet.t := + fold_right NpmP.RepoSet.add NpmP.RepoSet.empty + ((npmC, 4) :: (npmC, 5) :: (npmC, 6) :: (npmC, 7) :: nil). + +Example npm_prerelease_excluded : + NpmP.VSet.elements + (NpmP.rangeEval ((NpmP.COp OpGe 4 :: NpmP.COp OpLt 8 :: nil) :: nil) + (NpmP.realVersions npmPreRepo npmC)) = 4 :: 6 :: nil. +Proof. reflexivity. Qed. + +Example npm_prerelease_admitted : + NpmP.VSet.elements + (NpmP.rangeEval ((NpmP.COp OpGe 5 :: NpmP.COp OpLt 8 :: nil) :: nil) + (NpmP.realVersions npmPreRepo npmC)) = 5 :: 6 :: nil. +Proof. reflexivity. Qed. diff --git a/theories/VariableFormula.v b/theories/VariableFormula.v index b087757..c15a4f2 100644 --- a/theories/VariableFormula.v +++ b/theories/VariableFormula.v @@ -21,10 +21,6 @@ Module VariableFormula (N V : UsualOrderedType) Definition opEvalY (op : CmpOp) (y' y : Y.t) : bool := cmpOpEvalBy Y.compare op y' y. - Lemma opEvalY_complement : forall op y' y, - opEvalY (cmpComplement op) y' y = negb (opEvalY op y' y). - Proof. intros op y' y; apply cmpOpEvalBy_complement. Qed. - Fixpoint Satisfies (S : PkgSet.t) (sigma : X.t -> Y.t) (f : Formula) : Prop := match f with | FDep m vs => exists v, VSet.In v vs /\ PkgSet.In (m, v) S @@ -175,7 +171,6 @@ Module VariableFormula (N V : UsualOrderedType) Module NX := SumUOT N X. Module VY := SumUOT V Y. - (* A variable always has a value, so its package never goes absent. *) Module Ab <: AbsentNames NX. Definition hasAbsent (n : NX.t) : bool := match n with inl _ => true | inr _ => false end. @@ -208,9 +203,6 @@ Module VariableFormula (N V : UsualOrderedType) if opEvalY op y' y then Some (inr y') else None) (Y_x x). - (* A comparison is an atom on its variable's package, admitting the - values that pass it; negation then takes the complement among the - values, with no absent version to fall back on. *) Fixpoint liftFormula (Y_x : X.t -> YSet.t) (f : Formula) : PF.Formula := match f with | FDep m vs => PF.FDep (inl m) (liftVS vs) @@ -453,8 +445,6 @@ Module VariableFormula (N V : UsualOrderedType) - intros [x ->]; exists x; split; [apply X.enum_complete | reflexivity]. Qed. - (* The source model a variable-formula resolution stands for: its - packages, and each variable's package at the assigned value. *) Definition liftModel (S : PkgSet.t) (sigma : X.t -> Y.t) : PF.PkgSet.t := PF.PkgSet.union (SOpl.map liftPkg S) (assignPkgs sigma). @@ -647,7 +637,6 @@ Module VariableFormula (N V : UsualOrderedType) Definition realPreimage (R : PkgSet.t) (ns : NSet.t) : PkgSet.t := RKeys.ofKeys fst ns R. - (* The value sets cut down to x's own. *) Definition valuesAt (Y_x : X.t -> YSet.t) (x : X.t) : X.t -> YSet.t := fun x' => if X.eq_dec x x' then Y_x x else YSet.empty. diff --git a/theories/Versions.v b/theories/Versions.v index 5623de6..038b9ef 100644 --- a/theories/Versions.v +++ b/theories/Versions.v @@ -29,12 +29,6 @@ Module OpComp <: ComparableType. End OpComp. Module OpOT := UOTFromCompare OpComp. -Definition cmpComplement (op : CmpOp) : CmpOp := - match op with - | OpGe => OpLt | OpGt => OpLe | OpLe => OpGt - | OpLt => OpGe | OpEq => OpNe | OpNe => OpEq - end. - Definition cmpOpEvalBy {A} (cmp : A -> A -> comparison) (op : CmpOp) (x c : A) : bool := match op with @@ -46,12 +40,6 @@ Definition cmpOpEvalBy {A} (cmp : A -> A -> comparison) | OpNe => match cmp x c with Eq => false | _ => true end end. -Lemma cmpOpEvalBy_complement : forall A (cmp : A -> A -> comparison) op x c, - cmpOpEvalBy cmp (cmpComplement op) x c = negb (cmpOpEvalBy cmp op x c). -Proof. - intros A cmp [ | | | | | ] x c; simpl; destruct (cmp x c); reflexivity. -Qed. - Module Versions (N V : UsualOrderedType). Module C := Core N V. Module Pkg := C.Pkg. @@ -257,8 +245,6 @@ Module Versions (N V : UsualOrderedType). Qed. Module PkgFibred := FibredRel N V Pkg PkgSet. - (* reduce leaves the real packages as they are, so the reduced - instance's versions at n are C.versions R n, whatever D is. *) Theorem versions_lookup : forall R (n : N.t), C.versions R n = C.versions (PkgFibred.tailFibre R n) n. Proof. diff --git a/theories/Virtual.v b/theories/Virtual.v index 0446302..0557117 100644 --- a/theories/Virtual.v +++ b/theories/Virtual.v @@ -195,12 +195,6 @@ Module Virtual (N V : UsualOrderedType). rewrite NEqb.eqb_refl; cbn [andb]; apply memTopb_iff; exact Hm. Qed. - (* A guard inside a pattern-matching comprehension body is only exposed - once the element is destructed, too late for mem_filterMap_if. *) - Lemma if_some_iff : forall (A : Type) (b : bool) (x y : A), - (if b then Some x else None) = Some y <-> b = true /\ x = y. - Proof. intros A [|] x y; cbn; intuition congruence. Qed. - Module SOpp := SetOps ProvElt T.Pkg ProvidesRel T.PkgSet. Definition realProviderBlock (Pi : ProvidesRel.t) (p : Pkg.t) (n : N.t) (vs : VSet.t) : T.PkgSet.t := diff --git a/theories/Visibility.v b/theories/Visibility.v index acea88a..d4dec93 100644 --- a/theories/Visibility.v +++ b/theories/Visibility.v @@ -1314,7 +1314,6 @@ Module Visibility (N V : UsualOrderedType). | apply mem_potentialOrigins; right; split; assumption]. Qed. - (* Unreached, q need not be a potential origin and the name is empty. *) Theorem versions_lookupOccurrence : forall R D pub r (n : N.t) (q : Pkg.t), (exists p h, T.DepRel.In (p, (Name.Occurrence n q, h)) @@ -1374,7 +1373,6 @@ Module Visibility (N V : UsualOrderedType). | apply carried_tailFibre; exact Hc]. Qed. - (* Unreached, q need not be a potential origin and the name is empty. *) Theorem versions_lookupIntermediate : forall R D pub r (n : N.t) (v : V.t) (m : N.t) (q : Pkg.t), (exists p h, T.DepRel.In (p, (Name.Intermediate n v m q, h))