diff --git a/.gitignore b/.gitignore new file mode 100644 index 0000000..7c71f67 --- /dev/null +++ b/.gitignore @@ -0,0 +1,7 @@ +*.vo +*.glob +*.v.d +*.aux +Makefile.coq +Makefile.coq.conf +.coqdeps.d diff --git a/Makefile b/Makefile new file mode 100644 index 0000000..90c87c5 --- /dev/null +++ b/Makefile @@ -0,0 +1,42 @@ +IMPACTEDML = extraction/impacted/ocaml/impacted.ml extraction/impacted/ocaml/impacted.mli +IMPACTEDRBTML = extraction/impacted-rbt/ocaml/impacted_rbt.ml extraction/impacted-rbt/ocaml/impacted_rbt.mli + +all: default + +default: Makefile.coq + $(MAKE) -f Makefile.coq + +quick: Makefile.coq + $(MAKE) -f Makefile.coq quick + +install: Makefile.coq + $(MAKE) -f Makefile.coq install + +clean: Makefile.coq + $(MAKE) -f Makefile.coq cleanall + rm -f Makefile.coq Makefile.coq.conf + $(MAKE) -C extraction/impacted clean + $(MAKE) -C extraction/impacted-rbt clean + +impacted: + +$(MAKE) -C extraction/impacted filtering.native filteringinv.native topfiltering.native + +impacted-rbt: + +$(MAKE) -C extraction/impacted-rbt filtering.native filteringinv.native topfiltering.native + +Makefile.coq: _CoqProject + coq_makefile -f _CoqProject -o Makefile.coq \ + -extra '$(IMPACTEDML)' \ + 'extraction/impacted/coq/extract_impacted.v core/finn.vo' \ + '$$(COQC) $$(COQDEBUG) $$(COQFLAGS) extraction/impacted/coq/extract_impacted.v' \ + -extra '$(IMPACTEDRBTML)' \ + 'extraction/impacted-rbt/coq/extract_impacted_rbt.v core/finn_set.vo' \ + '$$(COQC) $$(COQDEBUG) $$(COQFLAGS) extraction/impacted-rbt/coq/extract_impacted_rbt.v' + +$(IMPACTEDML) $(IMPACTEDRBTML): Makefile.coq + $(MAKE) -f Makefile.coq $@ + +.PHONY: all default quick clean impacted $(IMPACTEDML) $(IMPACTEDRBTML) + +.NOTPARALLEL: $(IMPACTEDML) +.NOTPARALLEL: $(IMPACTEDRBTML) diff --git a/README.md b/README.md new file mode 100644 index 0000000..c025b1b --- /dev/null +++ b/README.md @@ -0,0 +1,87 @@ +Change Impact Analysis in Coq and OCaml +======================================= + +A basic requirement is to install [OPAM](http://opam.ocaml.org/doc/Install.html). + +Then create an OPAM switch for OCaml 4.06.1: +``` +opam update +opam switch 4.06.1 +eval `opam config env` +``` + +Building the Coq development +---------------------------- + +First install the requirements: +``` +opam repo add coq-released https://coq.inria.fr/opam/released +opam pin add coq 8.8.1 +opam pin add coq-mathcomp-ssreflect 1.7.0 +opam install coq-mathcomp-fingroup +``` + +Then run: +``` +make +``` +This will build the whole project and check all the proofs. + +Building the Chip tool +---------------------- + +First install the Coq requirements as above. Then install the OCaml requirements: +``` +opam install ocamlbuild yojson extlib +``` + +To build regular Chip, run +``` +make impacted +``` +To then try the tool, go to `extraction/impacted` and run: +``` +./filtering.native test/new.json test/old.json +``` + +To build Chip with red-black trees, run: +``` +make impacted-rbt +``` +and look in `extraction/impacted-rbt`. + +Coq files +--------- + +Adapted and extended from work by [Cohen and Thery](https://github.com/CohenCyril/tarjan): + +- `core/extra.v`: auxiliary sequence lemmas +- `core/connect.v`: auxiliary connect and topological sort definitions and lemmas +- `core/kosaraju.v`: implementation and correctness proof of Kosaraju's strongly connected components algorithm +- `core/tarjan.v`: implementation and correctness proof of Tarjan's strongly connected components algorithm + +Adapted from work by [Nanevski et al.](https://github.com/imdea-software/fcsl-pcm): + +- `core/ordtype.v`: ordered type definition for the Mathematical Components library + +Core definitions and lemmas: + +- `core/closure.v`: basic definition of transitive closures of sets +- `core/run.v`: set-based definitions of dependency graphs, impactedness, and freshness +- `core/change.v`: correctness argument for basic change impact analysis definitions +- `core/hierarchical.v`: overapproximation strategy for change impact analysis in hierarchical systems +- `core/hierarchical_correct.v`: correctness proofs for overapproximation strategy +- `core/hierarchical_sub.v`: compositional strategy for change impact analysis in hierarchical systems +- `core/hierarchical_sub_correct.v`: correctness proofs for compositional strategy +- `core/acyclic.v`: definition of and basic lemmas for acyclicity, parameterized acyclicity checker +- `core/kosaraju_acyclic.v`: acyclicity checking based on Kosaraju's algorithm +- `core/tarjan_acyclic.v`: acyclicity checking based on Tarjan's algorithm +- `core/topos.v`: definitions and lemmas on topological sorting of acyclic graphs + +Implementation-related definitions and lemmas: + +- `core/close_dfs.v`: refined sequence-based transitive closure computation +- `core/dfs_set.v`: refined transitive closure computation using MSet functor (to enable red-black trees) +- `core/run_seq.v`: sequence-based change impact analysis definitions, optimized topological sorting using impact analysis +- `core/finn.v`: regular instantiation of sequence-based definitions for the ordinal finite type +- `core/finn_set.v`: red-black tree instantiation of sequence-based definitions for the ordinal finite type diff --git a/_CoqProject b/_CoqProject new file mode 100644 index 0000000..e4b5fe6 --- /dev/null +++ b/_CoqProject @@ -0,0 +1,29 @@ +-Q core chip +-Q extraction/impacted/coq chip +-Q extraction/impacted-rbt/coq chip +-arg "-w -notation-overridden,-local-declaration,-redundant-canonical-projection,-projection-no-head-constant" +core/extra.v +core/connect.v +core/acyclic.v +core/closure.v +core/closure_example.v +core/tarjan.v +core/kosaraju.v +core/kosaraju_acyclic.v +core/tarjan_acyclic.v +core/change.v +core/run.v +core/string.v +core/finn.v +core/finn_set.v +core/run_seq.v +core/topos.v +core/ordtype.v +core/dfs_set.v +core/close_dfs.v +core/hierarchical.v +core/hierarchical_correct.v +core/hierarchical_sub.v +core/hierarchical_sub_correct.v +extraction/impacted/coq/extract_impacted.v +extraction/impacted-rbt/coq/extract_impacted_rbt.v diff --git a/core/acyclic.v b/core/acyclic.v new file mode 100644 index 0000000..acda729 --- /dev/null +++ b/core/acyclic.v @@ -0,0 +1,362 @@ +From mathcomp +Require Import all_ssreflect. + +From chip +Require Import connect. + +Set Implicit Arguments. +Unset Strict Implicit. +Unset Printing Implicit Defensive. + +Section Cycles. + +Variable V : finType. +Variable g : rel V. + +Lemma self_loop_cycle : forall x, g x x -> cycle g [:: x]. +Proof. +move => x H_in. +rewrite /cycle /=. +by apply/andP. +Qed. + +Lemma diconnect_path_cycle : + forall x y, x != y -> diconnect g x y -> exists p, cycle g (x :: p). +Proof. +move => x y H_neq /andP /= [H_x H_y]. +move/connectP: H_x; case => px H_px H_pl. +move/connectP: H_y; case => py H_py H_pl'. +case: py H_py H_pl' => /=; first by move => H_py H_eq; rewrite H_eq in H_neq; move/negP: H_neq. +move => y' py' /andP [H_in H_py'] H_x. +exists (px ++ belast y' py'). +rewrite rcons_cat /= {2}H_x -lastI cat_path -H_pl /=. +apply/andP; split => //. +by apply/andP. +Qed. + +Lemma cycle_path_diconnect : + forall x p, cycle g (x :: p) -> + x \in g x \/ (exists y, diconnect g x y /\ x != y). +Proof. +move => x p. +move: x. +rewrite /=. +case: p => //=. +- move => x /andP [H_p ?]. + by left. +- move => y p x. + case H_eq: (x == y). + * move/eqP: H_eq => H_eq. + rewrite H_eq. + move/andP => [H_in H_p]. + by left. + * move/negP: H_eq => H_eq. + move/andP => [H_in H_p]. + right. + exists y; split; last by apply/negP. + apply/andP. + split; first by apply/connectP; exists [:: y]; first by rewrite /=; apply/andP. + apply/connectP. + exists (rcons p x); first by []. + by rewrite last_rcons. +Qed. + +End Cycles. + +Section Acyclic. + +Variable V : finType. +Variable g : rel V. + +Definition acyclic := forall x p, path g x p -> ~~ cycle g (x :: p). + +Hypothesis g_acyclic: acyclic. + +Lemma acyclic_no_self_loop : forall x, ~~ g x x. +Proof. +move => x. +apply/negP. +case => Hg. +move/g_acyclic: (self_loop_cycle Hg). +move/negP; case => /=. +by apply/and3P; split. +Qed. + +Lemma acyclic_diconnect : forall x y, diconnect g x y -> x = y. +Proof. +move => x y Hd. +case Hx: (x == y); first by apply/eqP. +move/negP/negP: Hx => Hx. +have [p Hc] := diconnect_path_cycle Hx Hd. +have Hp: path g x p by move: Hc; rewrite /= rcons_path; move/andP => [Hp Ha]. +by move/negP: (g_acyclic Hp); case. +Qed. + +End Acyclic. + +Section AcyclicSub. + +Variable V : finType. +Variable g : rel V. + +Hypothesis g_acyclic : acyclic g. + +Variable P : pred V. + +Local Notation I := (sig_finType P). + +Local Notation gsub := [rel x y : I | g (val x) (val y)]. + +Lemma gsub_acyclic : acyclic gsub. +Proof. +move => x p. +move/gsub_path. +move/g_acyclic => Hc. +rewrite /= rcons_path. +apply/negP => Hc'. +move/andP: Hc' => [Hp Hg]. +move/negP: Hc. +case. +rewrite /= rcons_path. +apply/andP. +split; first by apply/gsub_path. +rewrite /= in Hg. +by rewrite last_map. +Qed. + +End AcyclicSub. + +Section AcyclicRev. + +Variable V : finType. + +Variable g : rel V. + +Hypothesis g_acyclic : acyclic g. + +Local Notation grev := [rel x y | g y x]. + +Lemma acyclic_rev : acyclic grev. +Proof. +move => x p Hp. +apply/negP => H_c; move: H_c. +move/cycle_path_diconnect. +case. +- move => H_in. + have Hg: g x x by []. + move/self_loop_cycle: Hg => Hg. + contradict Hg. + apply/negP. + exact: g_acyclic. +- move => [y [Hd Hn]]. + have H_rev: g =2 [rel x y | grev y x] by []. + have Hd': diconnect g x y. + have Heq := eq_diconnect H_rev. + rewrite Heq. + move/andP: Hd => [Hc1 Hc2]. + apply/andP. + by split; apply connect_rev. + have Hc := diconnect_path_cycle _ Hd'. + have [p' Hc'] := Hc Hn. + have Hp': path g x p'. + rewrite /= in Hc'. + rewrite rcons_path in Hc'. + by move/andP:Hc' => [Hp' Hgl]. + contradict Hc'. + apply/negP. + exact: g_acyclic. +Qed. + +End AcyclicRev. + +Section Acyclicity. + +Variable V : finType. +Variable sccs : rel V -> seq (seq V). +Variable g : rel V. + +Hypothesis uniq_flatten : uniq (flatten (sccs g)). + +Hypothesis all_in_flatten : forall v : V, v \in (flatten (sccs g)). + +Hypothesis class_diconnected : + forall c, c \in sccs g -> + exists x, forall y, (y \in c) = diconnect g x y. + +Lemma in_flatten (A : seq (seq V)) s : + s \in A -> + subseq s (flatten A). +Proof. +elim: A => //=. +move => vs c IH H_in. +have H_or: s = vs \/ s \in c. + move/orP: H_in. + case; first by move/eqP; left. + by right. +case: H_or => H_in'. + by rewrite H_in' prefix_subseq. +have IH' := IH H_in'. +have ->: s = [::] ++ s by []. +by apply cat_subseq; first exact: sub0seq. +Qed. + +Lemma non_singleton_neq : forall v v' vs, + [:: v, v' & vs] \in sccs g -> + v != v'. +Proof. +move => v v' vs H_ks. +apply/negP. +move/eqP => H_eq. +rewrite -H_eq {H_eq} in H_ks. +have H_fl := uniq_flatten. +apply in_flatten in H_ks. +apply subseq_uniq in H_ks => //. +rewrite /= in H_ks. +move/andP: H_ks. +rewrite inE. +move => [H_n H_u]. +move/negP: H_n => H_n. +case: H_n. +by apply/orP; left. +Qed. + +Lemma non_singleton_cycle : forall v v' vs, + [:: v, v' & vs] \in sccs g -> + exists x p, cycle g (x :: p). +Proof. +move => v v' vs H_ks. +have H_c := class_diconnected H_ks. +rewrite /class_diconnected /= in H_c. +move: H_c => /= [x H_y]. +have H_v := H_y v. +have H_v' := H_y v'. +have H_neq := non_singleton_neq H_ks. +have H_in_v: v \in [:: v, v' & vs] by rewrite inE; apply/orP; left. +have H_in_v': v' \in [:: v, v' & vs] by rewrite inE; apply/orP; right; apply/orP; left. +rewrite H_v {H_v} in H_in_v. +rewrite H_v' {H_v'} in H_in_v'. +rewrite /diconnect in H_in_v H_in_v'. +move/andP: H_in_v => [H_cn_v H_cn'_v]. +move/connectP: H_cn_v => [pv H_pv] H_vl. +move/connectP: H_cn'_v => [p'v H_p'v] H_vl'. +move/andP: H_in_v' => [H_cn_v' H_cn'_v']. +move/connectP: H_cn_v' => [pv' H_pv'] H_v'l. +move/connectP: H_cn'_v' => [p'v' H_p'v'] H_v'l'. +have H_pvv': connect g v v'. + apply/connectP. + exists (p'v ++ pv'); last by rewrite last_cat -H_vl'. + rewrite cat_path. + rewrite -H_vl'. + by apply/andP. +have H_p'vv': connect g v' v. + apply/connectP. + exists (p'v' ++ pv); last by rewrite last_cat -H_v'l'. + rewrite cat_path. + rewrite -H_v'l'. + by apply/andP. +have H_di: diconnect g v v'. + rewrite /diconnect. + by apply/andP. +have [p H_p] := diconnect_path_cycle H_neq H_di. +by exists v, p. +Qed. + +Lemma all_in_sccs : + forall v, exists vs, vs \in sccs g /\ v \in vs. +Proof. +move => v. +have H_all := all_in_flatten v. +move/flattenP: H_all => [vs [H_vs H_in]]. +by exists vs. +Qed. + +Lemma diconnect_neq_sccs : + forall x y, diconnect g x y -> x != y -> + exists v v' vs, [:: v, v' & vs] \in sccs g. +Proof. +move => x y H_y H_neq. +have [vs [H_vs H_in]] := all_in_sccs x. +have [x' H_c] := class_diconnected H_vs. +have H_eq: x \in vs by []. +have H_c' := H_c x. +rewrite H_c' in H_eq. +have H_di: diconnect g x' y. + move/andP: H_eq => [H_x'x H_xx']. + move/andP: H_y => [H_xy H_yx]. + apply/andP; split. + - move: H_x'x H_xy. + exact: connect_trans. + - move: H_yx H_xx'. + exact: connect_trans. +rewrite -H_c in H_di. +move {H_y H_c H_c' H_eq}. +case: vs H_in H_di H_vs => //. +move => v. +case. +- rewrite 2!inE. + move/eqP => H_xv. + rewrite -H_xv. + move/eqP => H_yx. + move/negP: H_neq => H_neq. + case: H_neq. + by apply/eqP. +- move => v' vs H_x H_y. + by exists v, v', vs. +Qed. + +Definition class_acyclic (c : seq V) := +match c with +| [::] => true +| [:: v] => ~~ g v v +| [:: _, _ & _] => false +end. + +Definition sccs_acyclic := + all [pred c | class_acyclic c] (sccs g). + +Lemma sccs_acyclicP : + reflect (acyclic g) sccs_acyclic. +Proof. + apply: (iffP idP). +- move/allP => /=. + move => H_in_ac v p H_p. + apply/negP => H_ce. + apply cycle_path_diconnect in H_ce. + case: H_ce => H_ce. + * have [vs [H_vs H_v]] := all_in_sccs v. + move: H_vs H_v. + move/H_in_ac. + case: vs => //=. + move => v'. + case => //=. + move/negP. + rewrite inE => H_in. + move/eqP => H_eq. + by rewrite H_eq in H_ce. + * move: H_ce => [y [H_d H_neq]]. + have [v0 [v1 [vs H_ks]]] := diconnect_neq_sccs H_d H_neq. + by move/H_in_ac: H_ks. +- move => H_gc. + apply/allP. + case => //= v. + case => //=. + * move => H_in. + apply/negP. + move => H_in'. + have H_ce: cycle g [:: v] by apply/andP. + contradict H_ce. + apply/negP. + exact: H_gc. + * move => v' vs. + move/non_singleton_cycle. + move => [x [p H_ce]]. + have H_ce' := H_ce. + rewrite /= in H_ce'. + rewrite rcons_path in H_ce'. + move/andP: H_ce' => [H_p H_l]. + contradict H_ce. + apply/negP. + exact: H_gc. +Qed. + +End Acyclicity. diff --git a/core/change.v b/core/change.v new file mode 100644 index 0000000..b7ac7f3 --- /dev/null +++ b/core/change.v @@ -0,0 +1,783 @@ +From mathcomp +Require Import all_ssreflect. + +From chip +Require Import extra connect acyclic closure run. + +Set Implicit Arguments. +Unset Strict Implicit. +Unset Printing Implicit Defensive. + +Section Changed. + +(* artifact *) +Variable A : eqType. + +(* paths *) +Variable V' : finType. + +Variable P : pred V'. + +Local Notation V := (sig_finType P). + +Variable f' : V' -> A. + +Variable f : V -> A. + +Variable g' : rel V'. + +Local Notation g'rev := [rel x y | g' y x]. + +Variable g : rel V. + +Local Notation grev := [rel x y | g y x]. + +Variable runnable' : pred V'. + +Variable runnable : pred V. + +Variable R : eqType. + +Variable run' : V' -> R. + +Variable run : V -> R. + +Definition insub_g (x y : V') := +match insub x, insub y with +| Some x', Some y' => g x' y' +| _, _ => false +end. + +Local Notation gV' := [rel x y : V' | insub_g x y]. + +Local Notation gV'rev := [rel x y | gV' y x]. + +Lemma ginsubexP (x y : V') : + reflect (exists x' y' : V, val x' = x /\ val y' = y /\ g x' y') (gV' x y). +Proof. +apply: (iffP idP). +- rewrite /gV' /=. + rewrite /insub_g. + have H_sp := (insubP [subType of V] x). + destruct H_sp. + * rewrite insubT //. + have H_sp := (insubP [subType of V] y). + destruct H_sp. + + rewrite insubT. + by exists (Sub x i), (Sub y i0). + + by rewrite insubN. + * by rewrite insubN. +- case => x'; case => y'. + move => [Hx [Hy Hg]]. + rewrite /gV' /=. + rewrite /insub_g. + case: x' Hx Hg => /= x0 Px0 -<-. + case: y' Hy => /= y0 Py0 -<-. + by rewrite (insubT _ Px0) (insubT _ Py0). +Qed. + +Lemma grevinsubexP (x y : V') : + reflect (exists x' y' : V, val x' = x /\ val y' = y /\ grev x' y') (gV'rev x y). +Proof. +apply: (iffP idP). +- rewrite /= => Hs. + move/ginsubexP: Hs. + move=> [y' [x' [Hx [Hy Hxy]]]]. + by exists x', y'. +- rewrite /=. + move => [y' [x' [Hy [Hx Hxy]]]]. + apply/ginsubexP. + by exists x', y'. +Qed. + +Lemma ginsubP x y : + reflect (g x y) (gV' (val x) (val y)). +Proof. +apply: (iffP idP). +- move/ginsubexP. + move => [x' [y' [Hx [Hy Hxy]]]]. + move/val_inj: Hx =>-<-. + by move/val_inj: Hy =>-<-. +- move => Hg. + apply/ginsubexP. + by exists x, y. +Qed. + +Lemma ginsub_eq x y : + g x y = gV' (val x) (val y). +Proof. +by apply/idP/ginsubP. +Qed. + +(* Assumption: dependencies are the same if artifact is the same *) +Hypothesis f_equal_g : + forall v, f v = f' (val v) -> forall v', gV' (val v) v' = g' (val v) v'. + +(* Assumption: runnability is the same if artifact is the same *) +Hypothesis runnable_V_V' : + forall v, f v = f' (val v) -> runnable v = runnable' (val v). + +(* +Assumption: +if the dependency (sub)graph rooted in a runnable vertex +is well-founded and unchanged, then the outcome of running +the vertex (in the new graph) is the same as the old outcome + *) +Hypothesis run_V_V' : + forall v, runnable v -> runnable' (val v) -> + (forall v', connect gV' (val v) v' = connect g' (val v) v') -> + (forall v', connect gV' (val v) (val v') -> f v' = f' (val v')) -> + run v = run' (val v). + +Variable V_result_cert : seq (V * R). + +Hypothesis V_result_certP : + forall v r, reflect (runnable v /\ run v = r) ((v,r) \in V_result_cert). + +Hypothesis V_result_cert_uniq : uniq [seq vr.1 | vr <- V_result_cert]. + +Lemma V_result_cert_complete : + forall v r, runnable v -> run v == r -> (v,r) \in V_result_cert. +Proof. +move => v r Hc. +move/eqP => Hr. +by apply/V_result_certP. +Qed. + +Lemma V_result_cert_sound : + forall v r, (v,r) \in V_result_cert -> runnable v /\ run v == r. +Proof. +move => v r. +move/V_result_certP => [Hc Hr]. +by move/eqP: Hr => Hr. +Qed. + +Definition V'_result_filter_cert := + [seq (val vr.1, vr.2) | vr <- V_result_cert & val vr.1 \notin impactedVV' g (modifiedV f' f)]. + +Lemma V_result_filter_cert_runnable' : + forall (v : V') (r : R), (v,r) \in V'_result_filter_cert -> runnable' v. +Proof. +move => v r. +move/mapP. +move => [[v' r'] Hv']. +case. +move =>->. +move => Hb; move: Hv'. +rewrite -Hb {Hb}. +rewrite mem_filter /=. +move/andP => [Hr Hin]. +have Hi': (val v' \notin impactedVV' g (modifiedV f' f)). + apply/negP. + move => Hv. + move/negP: Hr. + by case. +move/imsetP: Hi'. +move => Hvb. +have Hv': v' \notin impacted g^-1 (modifiedV f' f). + apply/negP. + move => Hv'. + case: Hvb. + by exists v'. +move/impactedVP: Hv'. +move => Hm. +move/V_result_certP: Hin. +move => [Hvc Hc]. +case Hf: (f v' == f' (val v')). + move/eqP: Hf. + by move/runnable_V_V'=>-<-. +move/negP/negP: Hf => Hf. +case: Hm. +exists v'; first by rewrite in_set. +apply/connectP. +by exists [::]. +Qed. + +Definition run_all_cert := + run_impactedV'_cert f' f g runnable' run' ++ V'_result_filter_cert. + +Lemma run_all_cert_cases : + forall v r, (v, r) \in run_all_cert -> + ((v, r) \in run_impactedV'_cert f' f g runnable' run' /\ (v, r) \notin V'_result_filter_cert) \/ + ((v, r) \in V'_result_filter_cert /\ (v,r) \notin run_impactedV'_cert f' f g runnable' run'). +Proof. +move => v b. +rewrite mem_cat. +move/orP. +case => Hi. +- left; split => //. + move/run_impactedV'_certP: Hi. + move => [Hc [Hv Hi]]. + apply/negP => Hp. + move: Hp. + move => Hc'. + case: Hc'. + move/mapP. + move => [[v' b'] Hb]. + rewrite /=. + case. + move => Hv' Hb'. + subst. + move: Hb. + rewrite mem_filter /=. + move/andP => [Hp Hp']. + move/negP: Hp. + case. + move/impactedV'P: Hi. + case; move => [Hi Hi'] //. + move/freshV'P: Hi => Hi. + have Hv' := Hi v'. + move/negP: Hv'. + case. + by apply/eqP. +- right; split => //. + apply/negP. + move => Hm. + move/run_impactedV'_certP: Hm. + move/mapP: Hi. + move => [[v' b'] Hb] /=. + case. + move => Hv' Hb'. + subst. + move: Hb. + rewrite mem_filter /=. + move/andP => [Hb Hc]. + move => [Hc1 [Hc2 Hi2]]. + move/negP: Hb. + case. + move/impactedV'P: Hi2. + case; move => [Hi Hi'] //. + move/freshV'P: Hi => Hi. + have Hv' := Hi v'. + move/negP: Hv'. + case. + by apply/eqP. +Qed. + +Definition run_all_cert_V' := + [seq vr.1 | vr <- run_all_cert]. + +Lemma run_all_cert_V'_uniq : uniq run_all_cert_V'. +Proof. +rewrite map_inj_in_uniq. +- rewrite cat_uniq. + apply/andP. + split; last (apply/andP; split). + * have Hu := run_impactedV'_cert_uniq f' f g runnable' run'. + move: Hu. + exact: map_uniq. + * apply/negP. + case. + move/hasP => [vr Hvr]. + move/mapP: Hvr => [vr' Hvr']. + case: vr' Hvr' => v' r'. + rewrite mem_filter. + case: vr => /= v r. + move/andP => [Hv Hvr]. + case => Hv'; move =>-> {r}. + move/mapP => [v0 Hv0]. + case => Hvv0 Hr'. + rewrite mem_enum -Hvv0 in Hv0. + move/negP: Hv. + case. + rewrite in_set in Hv0. + move/andP: Hv0 => [Hvi Hvc]. + rewrite in_set in Hvi. + move/orP: Hvi. + case; first by rewrite Hv'. + move/freshV'P => Hvv. + have Hvv' := Hvv v'. + move/negP: Hvv'. + case. + by rewrite Hv'. + * have Hm := map_uniq V_result_cert_uniq. + rewrite map_inj_in_uniq; first by rewrite filter_uniq. + case => v1 r1. + case => v2 r2. + rewrite /= => Hv1 Hv2. + case. + by move/val_inj =><-<-. +- case => v1 r1. + case => v2 r2. + rewrite /= 2!mem_cat. + move/orP. + case => Hv1; move/orP. + * case => Hv2 Hv. + + move: Hv Hv1 Hv2 =><-. + move/mapP => [v1' Hv1' Hc1]. + rewrite mem_enum in Hv1'. + case: Hc1 =><- Hr1. + move/mapP => [v2' Hv2' Hc2]. + rewrite mem_enum in Hv2'. + case: Hc2 =><- Hr2. + by rewrite Hr1 Hr2. + + move: Hv Hv1 Hv2 =><-. + move/mapP => [v1' Hv1' Hc1]. + case: Hc1 Hv1' =><-. + rewrite mem_enum => Hc. + rewrite in_set. + move/andP => [Hi H'c]. + move/mapP => [v' Hv' Heq]. + case: v' Hv' Heq => v2' r2'. + rewrite mem_filter. + move/andP => [Hv2' HV]. + case => Hv1 Hr2. + rewrite /= in Hv2'. + move/negP: Hv2'. + case. + rewrite -Hv1. + rewrite in_set in Hi. + move/orP: Hi. + case => //. + move/freshV'P => Hv. + have Hv' := Hv v2'. + move/negP: Hv'. + case. + apply/eqP. + by rewrite Hv1. + * case => Hv2 Hv. + + move: Hv Hv1 Hv2. + move =><-. + move/mapP => [v1' Hv1' Hc1]. + case: v1' Hc1 Hv1' => v1' r1'. + case =>->->. + rewrite mem_filter. + move/andP => [Hi H'c]. + move/mapP => [v' Hv' Heq]. + case: Heq Hv'. + rewrite mem_enum. + move =><-->. + move => Hc. + move/negP: Hi. + case. + rewrite in_set in Hc. + move/andP: Hc => [Hi Hc]. + rewrite in_set in Hi. + move/orP: Hi. + case => //. + move/freshV'P => Hv'. + have Hv'' := Hv' v1'. + move/negP: Hv''. + by case. + + move: Hv1 Hv2. + move/mapP. + case; case => v1' r1'. + rewrite mem_filter. + move/andP => [Hi Hv']. + case. + move => H_eq_v H_eq_r. + move/mapP. + case; case => v2' r2'. + rewrite mem_filter. + move/andP => [Hi' Hv'']. + case => H_eq_v' H_eq_r'. + rewrite Hv in H_eq_v, H_eq_v'. + rewrite H_eq_v in H_eq_v'. + apply val_inj in H_eq_v'. + rewrite -H_eq_v' in Hv''. + rewrite Hv H_eq_r H_eq_r'. + have Hu := uniq_prod_eq V_result_cert_uniq Hv' Hv''. + by rewrite -Hu. +Qed. + +Lemma run_all_cert_complete : + forall (v : V'), runnable' v -> v \in run_all_cert_V'. +Proof. +move => v Hc. +have H_sp := (insubP [subType of V] v). +destruct H_sp. +- (* 1. V'_result_filter_cert 2. impactedVV' *) + have Hv: v \notin freshV' P. + apply/negP. + move => Hv. + move/freshV'P: Hv => Hv. + move/negP: (Hv u) => Hv'. + case: Hv'. + by apply/eqP. + apply/mapP. + (* outline: + - either in filtered or impacted + - if in filtered, take run u + - if in impacted, take run' v + *) + case Hv': (v \in impactedV' f' f g). + - have Hv'': v \in impactedV' f' f g by []. + move {Hv'}. + exists (v, run' v); last by []. + rewrite mem_cat. + apply/orP. + left. + apply/run_impactedV'_certP. + by split. + - have Hv'': v \notin impactedV' f' f g by apply/negP; rewrite Hv'. + move {Hv'}. + exists (v, run u); last by []. + rewrite mem_cat. + apply/orP. + right. + apply/mapP. + exists (u, run u); last by rewrite /= e. + rewrite mem_filter. + apply/andP. + rewrite /= in e. + rewrite /=. + split. + * move/impactedV'P: Hv'' => Hv''. + apply/negP. + move => Hu. + case: Hv''. + left. + split => //. + by rewrite -e. + * apply/V_result_certP. + split => //. + suff H_suff: f u = f' (val u) by rewrite runnable_V_V' //= e. + apply/eqP. + apply/not_modifiedP. + apply/negP. + move => Hu. + move/negP: Hv'' => Hv''. + case: Hv''. + apply/impactedV'P. + left. + split => //. + apply/imsetP. + exists u; last by []. + apply/impactedVP. + by exists u. +- (*3. fresh *) + have Hv: v \in freshV' P. + rewrite -sub_freshV'. + move/negP: i => Hp. + apply/negP => Hs. + case: Hp. + have H_sp := (insubP [subType of V] v). + move: Hs. + by destruct H_sp. + apply/mapP. + exists (v, run' v) => //. + rewrite mem_cat. + apply/orP. + left. + apply/run_impactedV'_certP. + split => //. + split => //. + apply/impactedV'P. + right. + split => //. + apply/negP. + by move/impactedVV'_freshV'/negP. +Qed. + +Lemma connect_gV'_rev u : + (forall v : V, connect grev v u -> forall v', gV' (val v) v' = g' (val v) v') -> + (forall v : V, connect grev v u -> f v == f' (val v)) -> + forall v', connect gV' (val u) v' = connect g' (val u) v'. +Proof. +move => Hv. +have Hv': forall v : V, connect g u v -> forall v', gV' (val v) v' = g' (val v) v'. + move => v' Hc. + apply: Hv. + exact: connect_rev. +move {Hv}. +move => Hvf. +have Hvf': forall v' : V, connect g u v' -> f v' == f' (val v'). + move => v' Hc. + apply: Hvf. + exact: connect_rev. +move {Hvf}. +move => v'. +have H_eq: f u = f' (val u). + apply/eqP. + apply: Hvf'. + apply/connectP. + by exists [::]. +apply/connectP. +case: ifP. +- move/connectP => [p [Hp Hl]]. + have H_eq' := f_equal_g H_eq. + exists p; last by []. + clear Hl H_eq. + elim: p u Hp Hv' Hvf' H_eq' => //=. + move => v0 p IH u. + move/andP => [Hg Hp] Hc Hc' Hg'. + apply/andP. + rewrite -Hg' in Hg. + split. + * move/ginsubexP: Hg => [x [y [Hx [Hy Hxy]]]]. + rewrite -Hy. + rewrite ginsub_eq in Hxy. + by rewrite /gV' /= Hx in Hxy. + * move/ginsubexP: Hg => [x [y [Hx [Hy Hxy]]]]. + rewrite -Hy. + apply: IH => //; first by rewrite Hy. + + apply val_inj in Hx. + rewrite Hx in Hxy. + move => v1 Hc1. + apply: Hc. + move/connectP: Hc1 => [p' Hp'] Hl. + apply/connectP. + exists (y :: p'); last by []. + exact/andP. + + apply val_inj in Hx. + rewrite Hx in Hxy. + move => v1 Hc1. + apply: Hc'. + move/connectP: Hc1 => [p' Hp'] Hl. + apply/connectP. + exists (y :: p'); last by []. + exact/andP. + + apply val_inj in Hx. + rewrite Hx in Hxy. + apply f_equal_g. + apply/eqP. + apply: Hc'. + apply/connectP. + exists [:: y]; last by []. + exact/andP. +- move/connectP. + move => Hex Hex'. + case: Hex. + move: Hex' => [p [Hp Hl]]. + have H_eq' := f_equal_g H_eq. + exists p; last by []. + clear Hl H_eq. + elim: p u Hp Hv' Hvf' H_eq' => //=. + move => v0 p IH u. + move/andP => [Hg Hp] Hc Hc' Hg'. + apply/andP. + move/ginsubexP: Hg => [x [y [Hx [Hy Hxy]]]]. + split. + - rewrite -Hg' -Hy. + apply/ginsubP. + by move/val_inj: Hx =><-. + - rewrite -Hy. + rewrite -Hy in Hp. + apply: IH => //. + * move => v1 Hc1. + apply: Hc. + move/val_inj: Hx =><-. + move/connectP: Hc1 => [p' Hp'] Hl. + apply/connectP. + exists (y :: p'); last by []. + exact/andP. + * move => v1 Hc1. + apply: Hc'. + move/val_inj: Hx =><-. + move/connectP: Hc1 => [p' Hp'] Hl. + apply/connectP. + exists (y :: p'); last by []. + exact/andP. + * apply: Hc. + move/val_inj: Hx =><-. + apply/connectP. + exists [:: y]; last by []. + exact/andP. +Qed. + +Lemma connect_f_f'_eq u v0 : + (forall v' : V, connect grev v' u -> f v' == f' (val v')) -> + connect gV' (val u) (val v0) -> + f v0 = f' (val v0). +Proof. +move => Hgc Hc. +apply/eqP. +apply: Hgc. +apply/connect_rev. +move: Hc. +move/connectP => [p Hp] Hl. +apply/connectP. +exists (foldr (fun x (p' : seq V) => if insub x is Some x' then x' :: p' else p') [::] p). +- rewrite /=. + elim: p u v0 Hp Hl => //=. + move => v p IH u v0. + move/andP => [Hi Hp] Hl. + move: Hi. + rewrite /insub_g. + have H_sp := (insubP [subType of V] (sval u)). + move: H_sp. + case => //. + move => u0 HPu. + move/val_inj =>-> {u0}. + have H_sp := (insubP [subType of V] v). + move: H_sp. + case => //. + move => u0 HPv Heq Hg. + rewrite /=. + apply/andP. + split => //. + rewrite -Heq in Hp, Hl. + by apply: IH; eauto. +- rewrite /=. + elim: p u v0 Hp Hl => //=; first by move => u v0 Hl; apply val_inj. + move => v p IH u v0. + move/andP => [Hi Hp] Hl. + move: Hi. + rewrite /insub_g. + have H_sp := (insubP [subType of V] (sval u)). + move: H_sp. + case => //. + move => u0 HPu. + move/val_inj =>-> {u0}. + have H_sp := (insubP [subType of V] v). + move: H_sp. + case => //. + move => u0 HPv Heq Hg. + rewrite /=. + by apply IH; rewrite Heq. +Qed. + +Lemma run_all_cert_sound : + forall (v : V') (r : R), (v,r) \in run_all_cert -> + runnable' v /\ run' v = r. +Proof. +move => v r. +move/run_all_cert_cases. +case. +- (* impacted case *) + move => [Hi Hr]. + move/run_impactedV'_cert_run: Hi => [Hi [Hi' Hi'']]. + by move/eqP: Hi'. +- (* unimpacted case *) + move => [Hi Hr]. + have Hc: runnable' v. + move: Hi. + exact: V_result_filter_cert_runnable'. + split => //. + move/mapP: Hi. + case; case => u b'. + move => Hu. + case => Hu'. + move => Hb. + move: Hb Hu=><- {b'}. + rewrite mem_filter. + move/andP. + rewrite /=. + move => [Hi Hu]. + have Hv: v \notin freshV' P. + apply/negP. + move => Hv. + move/freshV'P: Hv => Hv. + move/negP: (Hv u) => Hv'. + case: Hv'. + by apply/eqP. + move/V_result_certP: Hu. + move => [Hca Hch]. + have Him' := Hi. + move: Him'. + move/imsetP. + move => Hx. + have Him': u \notin impacted g^-1 (modifiedV f' f). + apply/negP => Him'. + case: Hx. + by exists u. + have Him'' := Him'. + move/impactedVP: Him''. + move => Hx'. + have Hum: u \notin modifiedV f' f. + apply/negP. + move => Hu. + case: Hx'. + exists u; first by []. + apply/connectP. + by exists [::]. + have Hall: forall v', connect grev v' u -> v' \notin modifiedV f' f. + move => v' Hc'. + apply/negP => Hv'. + case: Hx'. + by exists v'. + move: Hall {Hx' Hi Hx} => Hall. + have Hu'': f u == f' (val u) by apply/not_modifiedP. + have Hall': forall v', connect grev v' u -> f v' == f' (val v'). + move => v' Hc'. + apply/not_modifiedP. + by apply Hall. + have Hallg': forall v, connect grev v u -> forall v', gV' (val v) v' = g' (val v) v'. + move => v' Hc'. + apply f_equal_g. + apply/eqP. + exact: Hall'. + rewrite -Hch. + rewrite Hu'. + apply sym_eq. + apply run_V_V' => //. + * rewrite -runnable_V_V' //. + apply/eqP. + by apply: Hall'. + * exact: connect_gV'_rev. + * move => v0. + exact: connect_f_f'_eq. +Qed. + +End Changed. + +Section Other. + +Variable A : eqType. +Variable V' : finType. +Variable P : pred V'. +Local Notation V := (sig_finType P). +Variable f' : V' -> A. +Variable f : V -> A. +Variable runnable' : pred V'. +Variable runnable : pred V. +Variable R : eqType. +Variable run : V -> R. +Variable run' : V' -> R. +Variables (g1 : rel V) (g2 : rel V). +Variable g' : rel V'. + +Local Notation g1V' := [rel x y : V' | insub_g g1 x y]. + +Hypothesis g1_g2_connect : connect g1 =2 connect g2. + +Hypothesis f_equal_g1 : + forall v, f v = f' (val v) -> forall v', g1V' (val v) v' = g' (val v) v'. + +Hypothesis runnable_V_V' : + forall v, f v = f' (val v) -> runnable v = runnable' (val v). + +Hypothesis run_V_V' : + forall v, runnable v -> runnable' (val v) -> + (forall v', connect g1V' (val v) v' = connect g' (val v) v') -> + (forall v', connect g1V' (val v) (val v') -> f v' = f' (val v')) -> + run v = run' (val v). + +Variable V_result_cert : seq (V * R). +Hypothesis V_result_certP : + forall (v : V) (r : R), reflect (runnable v /\ run v = r) ((v,r) \in V_result_cert). +Hypothesis V_result_cert_uniq : uniq [seq vr.1 | vr <- V_result_cert]. + +Lemma run_all_cert_V'_uniq_g2 : uniq (run_all_cert_V' f' f g2 runnable' run' V_result_cert). +Proof. +rewrite /run_all_cert_V' /run_all_cert /run_impactedV'_cert /runnable_impacted_fresh. +erewrite <- connect_runnable_impactedV'; eauto. +rewrite /V'_result_filter_cert /impactedVV'. +erewrite <- connect_impactedV_eq; eauto. +exact: run_all_cert_V'_uniq. +Qed. + +Lemma run_all_cert_complete_g2 : + forall v, runnable' v -> v \in run_all_cert_V' f' f g2 runnable' run' V_result_cert. +Proof. +move => v Hc. +rewrite /run_all_cert_V' /run_all_cert /run_impactedV'_cert /runnable_impacted_fresh. +erewrite <- connect_runnable_impactedV'; eauto. +rewrite /V'_result_filter_cert /impactedVV'. +erewrite <- connect_impactedV_eq; eauto. +by apply: run_all_cert_complete; eauto. +Qed. + +Lemma run_all_cert_sound_g2 : + forall (v : V') (r : R), (v,r) \in run_all_cert f' f g2 runnable' run' V_result_cert -> + runnable' v /\ run' v = r. +Proof. +move => v r. +rewrite /run_all_cert /run_impactedV'_cert /runnable_impacted_fresh. +erewrite <- connect_runnable_impactedV'; eauto. +rewrite /V'_result_filter_cert /impactedVV'. +erewrite <- connect_impactedV_eq; eauto. +by apply: run_all_cert_sound; eauto. +Qed. + +End Other. diff --git a/core/close_dfs.v b/core/close_dfs.v new file mode 100644 index 0000000..c56ac38 --- /dev/null +++ b/core/close_dfs.v @@ -0,0 +1,608 @@ +From mathcomp +Require Import all_ssreflect. + +Set Implicit Arguments. +Unset Strict Implicit. +Unset Printing Implicit Defensive. + +Section DFSearch. + +Variable T : finType. + +Lemma closureP (g : rel T) (s : pred T) x : + reflect (exists2 v, v \in s & connect g x v) (x \in closure g s). +Proof. +apply: (iffP idP). +- move/existsP => [y Hy]. + move/andP: Hy => [Hc Hy]. + by exists y. +- move => [v Hv] Hc. + apply/existsP. + exists v. + by apply/andP. +Qed. + +Definition rclosed (g : rel T) (a : seq T) := + forall x y, g x y -> x \in a -> y \in a. + +Lemma rclosed_connect : forall (g : rel T) (s : seq T), + rclosed g s -> forall x y, connect g x y -> x \in s -> y \in s. +Proof. +move => g s Hr x y. +move/connectP => [p Hp] Hl. +elim: p x Hp Hl => //=; first by move => Hp Hx; move =>->. +move => z p IH x. +move/andP => [Hz Hp] Hl Hx. +have Hzg := Hr _ _ Hz Hx. +move: Hzg. +exact: IH. +Qed. + +Definition rclosure (g : T -> seq T) := + foldr (fun x s => dfs g #|T| s x) [::]. + +Definition rclosure' (g : T -> seq T) := + foldl (dfs g #|T|) [::]. + +Lemma rclosure_exist : forall g s x, + x \in rclosure (rgraph g) s -> + exists2 v : T, v \in s & connect g v x. +Proof. +move => g. +elim => //=. +move => x s IH y Hyd. +case Hy: (y \in rclosure (rgraph g) s). + move/idP: Hy. + move/IH => [v Hv] Hc. + exists v => //. + rewrite in_cons. + apply/orP. + by right. +move/negP/negP: Hy => Hy. +move/dfs_pathP: Hyd => Hd. +have Ht: #|T| <= #|rclosure (rgraph g) s| + #|T| by exact: leq_addl. +have Hd' := Hd Ht Hy. +destruct Hd'. +exists x; first by rewrite in_cons; apply/orP; left. +apply/connectP. +exists p => //. +move: H. +rewrite /grel /rgraph /=. +elim: p x {H0 H1 Hd} => //=. +move => z p IH' x. +rewrite mem_enum. +move/andP => [He Hp]. +apply/andP. +split => //. +exact: IH'. +Qed. + +Lemma dfs_in : forall (g : T -> seq T) n s x y, + x \in s -> + x \in dfs g n s y. +Proof. +move => g. +case => /=; first by move => s x Hs; case: ifP. +move => n s x y Hx. +case: ifP => //. +move/negP/negP => Hs. +move/subsetP: (subset_dfs g n (y :: s) (g y)) => Hsb. +apply: Hsb. +rewrite in_cons. +by apply/orP; right. +Qed. + +Lemma dfs_subset : forall (g : T -> seq T) n s x, + s \subset dfs g n s x. +Proof. +move => g. +case => //=. +- move => s x. + by case: ifP => Hx; apply/subsetP. +- move => n s x. + case: ifP => Hx; first by apply/subsetP. + move/negP/negP: Hx => Hx. + move/subsetP: (subset_dfs g n (x :: s) (g x)) => Hs. + apply/subsetP. + move => y Hy. + apply Hs. + rewrite in_cons. + by apply/orP; right. +Qed. + +Lemma rclosed_rclosure : forall g s, + rclosed g (rclosure (rgraph g) s). +Proof. +move => g. +elim => //=. +move => x s IH. +move => y z Hg. +case Hy: (y \in rclosure (rgraph g) s). + move/idP: Hy. + move/(IH _ z Hg) => Hz Hy. + exact: dfs_in. +move/negP/negP: Hy => Hcx. +move => Hcy. +have Ht: #|T| <= #|rclosure (rgraph g) s| + #|T| by exact: leq_addl. +case Hz: (z \in rclosure (rgraph g) s); first by apply: dfs_in. +move/negP/negP: Hz => Hz. +apply/dfs_pathP => //. +move/dfs_pathP: Hcy => Hcy. +case (Hcy Ht Hcx) => [p Hp] Hl Hd. +rewrite disjoint_cons in Hd. +move/andP: Hd => [Hx Hd]. +exists (rcons p z). +- rewrite /grel /rgraph /=. + rewrite rcons_path /=. + rewrite -Hl. + apply/andP. + split => //. + by rewrite mem_enum. +- by rewrite last_rcons. +- rewrite disjoint_cons. + apply/andP. + split => //. + rewrite disjoint_has. + elim: p Hd {Hp Hl} => //=. + * move => Hd. + apply/negP. + case. + move/orP. + case => //. + move => Hz'. + by move/negP: Hz; case. + * move => z0 p IH'. + rewrite disjoint_cons. + move/andP => [Hz0 Hd]. + apply/norP. + split => //. + exact: IH'. +Qed. + +Lemma dfs_in_in : forall (g : T -> seq T) s x, + x \in dfs g #|T| s x. +Proof. +move => g s x. +case Hx: (x \in s); first by apply dfs_in. +move/negP/negP: Hx => Hx. +apply/dfs_pathP => //. +- exact: leq_addl. +- exists [::] => //. + rewrite disjoint_has. + rewrite /=. + apply/norP. + by split. +Qed. + +Lemma subset_closure : forall g s, + s \subset rclosure (rgraph g) s. +Proof. +move => g. +elim => //= x s IH. +move/subsetP: IH => IH. +apply/subsetP. +move => y. +rewrite in_cons. +move/orP; case. +- move/eqP =>-> {y}. + exact: dfs_in_in. +- move => Hy. + apply IH in Hy. + exact: dfs_in. +Qed. + +Lemma rclosureP g (modified : seq T) x : + reflect + (exists2 v, v \in modified & connect g v x) + (x \in rclosure (rgraph g) modified). +Proof. +apply: (iffP idP); first by move => Hx; apply: rclosure_exist. +move => [v Hm] Hc. +have Hcl := @rclosed_rclosure g modified. +move: Hcl. +move/rclosed_connect => Hcl. +move/Hcl: Hc. +apply. +move/subsetP: (subset_closure g modified) => Hp. +exact: Hp. +Qed. + +Lemma dfs_eq_in : forall (g1 g2 : T -> seq T) n s x, + x \in s -> + dfs g1 n s x =i dfs g2 n s x. +Proof. +move => g1 g2. +elim => //=. +move => n IH s x Hg Hs. +case: ifP => //. +move/negP. +by case. +Qed. + +Lemma dfs_mem : forall (g1 g2 : T -> seq T) s x, + g1 =1 g2 -> + dfs g1 #|T| s x =i dfs g2 #|T| s x. +Proof. +move => g1 g2 s x Hg y. +case Hy: (y \in s). + move/idP: Hy => Hy. + have Hd1 := dfs_in g1 #|T| x Hy. + have Hd2 := dfs_in g2 #|T| x Hy. + move: Hd1 Hd2. + by case (y \in dfs g1 #|T| s x). +move/negP/negP: Hy => Hy. +have Hn: #|T| <= #|s| + #|T| by apply: leq_addl. +apply/dfs_pathP/idP => //. +- case => p Hp Hl Hd. + apply/dfs_pathP => //. + exists p => //. + elim: p x Hp {Hl Hd} => //=. + move => z p IH x. + move/andP => [Hg1 Hp]. + apply/andP. + split; last by apply: IH. + by rewrite -Hg. +- move/dfs_pathP => Hd. + move/Hd: Hn => Hd'. + move/Hd': Hy. + case => p Hp Hl Hds. + exists p => //. + elim: p x Hp {Hl Hd Hd' Hds} => //=. + move => z p IH x. + move/andP => [Hg1 Hp]. + apply/andP. + split; last by apply: IH. + by rewrite Hg. +Qed. + +Lemma dfs_mem' : forall (g1 g2 : T -> seq T) s x, + (forall x, g1 x =i g2 x) -> + dfs g1 #|T| s x =i dfs g2 #|T| s x. +Proof. +move => g1 g2 s x Hg y. +case Hy: (y \in s). + move/idP: Hy => Hy. + have Hd1 := dfs_in g1 #|T| x Hy. + have Hd2 := dfs_in g2 #|T| x Hy. + move: Hd1 Hd2. + by case (y \in dfs g1 #|T| s x). +move/negP/negP: Hy => Hy. +have Hn: #|T| <= #|s| + #|T| by apply: leq_addl. +apply/dfs_pathP/idP => //. +- case => p Hp Hl Hd. + apply/dfs_pathP => //. + exists p => //. + elim: p x Hp {Hl Hd} => //=. + move => z p IH x. + move/andP => [Hg1 Hp]. + apply/andP. + split; last by apply: IH. + by rewrite -Hg. +- move/dfs_pathP => Hd. + move/Hd: Hn => Hd'. + move/Hd': Hy. + case => p Hp Hl Hds. + exists p => //. + elim: p x Hp {Hl Hd Hd' Hds} => //=. + move => z p IH x. + move/andP => [Hg1 Hp]. + apply/andP. + split; last by apply: IH. + by rewrite Hg. +Qed. + +Lemma subset_rclose : forall (g : T -> seq T) s s0, + s \subset foldr (fun x s => dfs g #|T| s x) s s0. +Proof. +move => g s s0. +elim: s0 s => //=. +move => x s IH s0. +apply/subsetP => y Hy. +apply: dfs_in. +move/subsetP: (IH s0) => Hs. +exact: Hs. +Qed. + +Lemma rclose_subset : forall (g : T -> seq T) s s0, + s \subset foldr (fun x s => dfs g #|T| s x) s0 s. +Proof. +move => g. +elim => //=; first by move => s0; apply/subsetP. +move => x s IH s0. +apply/subsetP. +move => y. +rewrite in_cons. +move/orP; case. +- move/eqP =>->. + exact: dfs_in_in. +- move => Hy. + apply: dfs_in. + move/subsetP: (IH s0) => Hs. + exact: Hs. +Qed. + +Lemma dfs_mems : forall (g : T -> seq T) s1 s2 x, + s1 =i s2 -> + dfs g #|T| s1 x =i dfs g #|T| s2 x. +Proof. +move => g s1 s2 x Hs y. +case Hy: (y \in s1). + move/idP: Hy => Hy. + have Hd1 := dfs_in g #|T| x Hy. + rewrite Hs in Hy. + have Hd2 := dfs_in g #|T| x Hy. + move: Hd1 Hd2. + by case (y \in dfs _ #|T| _ x). +move/negP: Hy => Hy. +have Hy' : ~ y \in s2. + move => Hy'. + rewrite -Hs in Hy'. + by case: Hy. +move/negP: Hy => Hy. +move/negP: Hy' => Hy'. +have Hn: #|T| <= #|s1| + #|T| by apply: leq_addl. +have Hn': #|T| <= #|s2| + #|T| by apply: leq_addl. +apply/dfs_pathP/idP => //. +- case => p Hp Hl Hd. + apply/dfs_pathP => //. + exists p => //. + move: Hd. + rewrite 2!disjoint_cons. + move/andP => [Hx Hd]. + apply/andP. + split; first by rewrite -Hs. + elim: p Hd {Hp Hl} => //=. + move => z p Hd. + rewrite 2!disjoint_cons. + rewrite Hs. + move/andP => [Hz Hd']. + apply/andP. + split => //. + exact: Hd. +- move/dfs_pathP => Hd. + move/Hd: Hn' => Hd'. + move/Hd': Hy'. + case => p Hp Hl Hds. + exists p => //. + move: Hds. + rewrite 2!disjoint_cons. + move/andP => [Hx Hd0]. + apply/andP. + split; first by rewrite Hs. + elim: p Hd0 {Hp Hl} => //=. + move => z p Hd0. + rewrite 2!disjoint_cons. + rewrite Hs. + move/andP => [Hz Hd1]. + apply/andP. + split => //. + exact: Hd0. +Qed. + +Lemma closure_g : forall g1 g2 s, + (forall x, g1 x =i g2 x) -> + rclosure g1 s =i rclosure g2 s. +Proof. +move => g1 g2 s Hg. +move: s. +elim => //=. +move => x s IH y. +by rewrite (dfs_mems _ _ IH) (@dfs_mem' g1 g2). +Qed. + +Lemma rclosurePg g (modified : seq T) x : + reflect + (exists2 v, v \in modified & connect (grel g) v x) + (x \in rclosure g modified). +Proof. +apply: (iffP idP). +- move => Hx. + apply: rclosure_exist. + have Hg := @closure_g g (rgraph (grel g)). + rewrite -Hg //. + move => y s. + by rewrite /rgraph /grel mem_enum. +- move/rclosureP. + have Hg := @closure_g g (rgraph (grel g)). + rewrite -Hg //. + move => y s. + by rewrite /rgraph /grel mem_enum. +Qed. + +Lemma closure_eqi : forall (g : T -> seq T) s1 s2, + s1 =i s2 -> + rclosure g s1 =i rclosure g s2. +Proof. +move => g s1 s2 Hs x. +apply/rclosurePg/idP. +- move => [v Hv] Hc. + apply/rclosurePg. + exists v => //. + by rewrite -Hs. +- move/rclosurePg. + move => [v Hv] Hc. + exists v => //. + by rewrite Hs. +Qed. + +Lemma rclosure_in_lr : forall (g : T -> seq T) s x, + x \in foldl (dfs g #|T|) [::] s -> + x \in foldr (fun x s => dfs g #|T| s x) [::] s. +Proof. +move => g s x. +have {1} ->: s = rev (rev s) by rewrite revK. +rewrite foldl_rev. +rewrite (@closure_eqi _ s (rev s)) //. +move => y. +have Hs := has_rev (pred1 y) s. +by rewrite 2!has_pred1 in Hs. +Qed. + +Lemma rclosure_in_rl : forall (g : T -> seq T) s x, + x \in foldr (fun x s => dfs g #|T| s x) [::] s -> + x \in foldl (dfs g #|T|) [::] s. +Proof. +move => g s x. +have {2} ->: s = rev (rev s) by rewrite revK. +rewrite foldl_rev. +rewrite (@closure_eqi _ s (rev s)) //. +move => y. +have Hs := has_rev (pred1 y) s. +by rewrite 2!has_pred1 in Hs. +Qed. + +Lemma rclosure_rclosure'_i : forall g s, + rclosure g s =i rclosure' g s. +Proof. +move => g s x. +case Hx: (x \in _); case Hx': (x \in _) => //. +- move/negP: Hx'. + case. + exact: rclosure_in_rl. +- move/negP: Hx. + case. + exact: rclosure_in_lr. +Qed. + +Lemma rclosure'P g (modified : seq T) x : + reflect + (exists2 v, v \in modified & connect g v x) + (x \in rclosure' (rgraph g) modified). +Proof. +apply: (iffP idP). +- rewrite -rclosure_rclosure'_i. + by move/rclosureP. +- move => Hx. + rewrite -rclosure_rclosure'_i. + by apply/rclosureP. +Qed. + +Lemma rclosed_rclosure' : forall g s, + rclosed g (rclosure' (rgraph g) s). +Proof. +move => g s x y Hg. +rewrite -2!rclosure_rclosure'_i. +exact: rclosed_rclosure. +Qed. + +Lemma rclosure'Pg g (modified : seq T) x : + reflect + (exists2 v, v \in modified & connect (grel g) v x) + (x \in rclosure' g modified). +Proof. +apply: (iffP idP). +- rewrite -rclosure_rclosure'_i. + by move/rclosurePg. +- move/rclosurePg. + by rewrite rclosure_rclosure'_i. +Qed. + +Lemma dfs_uniq : forall (g : T -> seq T) n s v, + uniq s -> + uniq (dfs g n s v). +Proof. +move => g. +elim => //=; first by move => s v; case: ifP. +move => n IH s v Hs. +have ->: g v = rev (rev (g v)) by rewrite revK. +case: ifP => //. +move/negP/negP => Hv. +rewrite foldl_rev. +generalize (rev (g v)). +elim => //=; first by apply/andP; split. +move => y s' Hu. +exact: IH. +Qed. + +Lemma rclosure_uniq : forall (g : T -> seq T) s, + uniq s -> + uniq (rclosure g s). +Proof. +move => g. +elim => //=. +move => x s IH. +move/andP => [Hx Hs]. +apply: dfs_uniq. +exact: IH. +Qed. + +Lemma rclosure'_uniq : forall (g : T -> seq T) s, + uniq s -> + uniq (rclosure' g s). +Proof. +move => g s. +rewrite /rclosure'. +have {2} ->: s = rev (rev s) by rewrite revK. +rewrite foldl_rev. +move => Hs. +apply: rclosure_uniq. +by rewrite rev_uniq. +Qed. + +Definition rclosures g (s : {set T}) : {set T} := + finset (mem (rclosure (rgraph g) (enum s))). + +Lemma rclosuresP (g : rel T) (modified : {set T}) x : + reflect + (exists2 v, v \in modified & connect g v x) + (x \in rclosures g modified). +Proof. +apply: (iffP idP). +- rewrite /rclosures 2!inE. + move/rclosureP. + move => [v Hv] Hc. + rewrite mem_enum in Hv. + by exists v. +- move => [v Hv] Hc. + have Hv': v \in enum modified by rewrite mem_enum. + have Hex: exists2 v, v \in enum modified & connect g v x by exists v. + move/rclosureP: Hex => Hcl. + by rewrite /rclosures 2!inE. +Qed. + +Lemma rclosures_connect : forall g s, + forall x y, connect g x y -> x \in (rclosures g s) -> y \in (rclosures g s). +Proof. +move => g s x y Hc. +have Hc' := rclosed_connect (@rclosed_rclosure g (enum s)) Hc. +move => Hx. +rewrite /rclosures inE /=. +apply: Hc'. +move: Hx. +by rewrite inE. +Qed. + +Definition rclosures' g (s : {set T}) : {set T} := + finset (mem (rclosure' (rgraph g) (enum s))). + +Lemma rclosures'P (g : rel T) (modified : {set T}) x : + reflect + (exists2 v, v \in modified & connect g v x) + (x \in rclosures' g modified). +Proof. +apply: (iffP idP). +- rewrite /rclosures' 2!inE. + move/rclosure'P. + move => [v Hv] Hc. + rewrite mem_enum in Hv. + by exists v. +- move => [v Hv] Hc. + have Hv': v \in enum modified by rewrite mem_enum. + have Hex: exists2 v, v \in enum modified & connect g v x by exists v. + move/rclosure'P: Hex => Hcl. + by rewrite /rclosures 2!inE. +Qed. + +Lemma rclosures'_connect : forall g s, + forall x y, connect g x y -> x \in (rclosures' g s) -> y \in (rclosures' g s). +Proof. +move => g s x y Hc. +have Hc' := rclosed_connect (@rclosed_rclosure' g (enum s)) Hc. +move => Hx. +rewrite /rclosures' inE /=. +apply: Hc'. +move: Hx. +by rewrite inE. +Qed. + +End DFSearch. diff --git a/core/closure.v b/core/closure.v new file mode 100644 index 0000000..862849a --- /dev/null +++ b/core/closure.v @@ -0,0 +1,46 @@ +From mathcomp +Require Import all_ssreflect. + +From chip +Require Import close_dfs. + +Set Implicit Arguments. +Unset Strict Implicit. +Unset Printing Implicit Defensive. + +Section Closure. + +Variable V : finType. +Variable g : rel V. +Variable modified : {set V}. + +Definition impacted := \bigcup_( x | x \in modified) [set y | connect g x y]. + +Lemma impactedP x : + reflect + (exists2 v, v \in modified & connect g v x) + (x \in impacted). +Proof. +apply: (iffP idP). +- move/bigcupP => [v H_v H_i]. + exists v; first by []. + by rewrite inE in H_i. +- move => [v H_m H_c]. + apply/bigcupP. + exists v; first by []. + by rewrite inE. +Qed. + +Lemma rclosed_impacted : + forall x y, connect g x y -> x \in impacted -> y \in impacted. +Proof. +move => x y Hc. +move/bigcupP => [v Hv] Hcx. +apply/bigcupP. +exists v => //. +rewrite inE. +rewrite inE in Hcx. +exact: connect_trans Hcx Hc. +Qed. + +End Closure. diff --git a/core/closure_example.v b/core/closure_example.v new file mode 100644 index 0000000..fb3de59 --- /dev/null +++ b/core/closure_example.v @@ -0,0 +1,109 @@ +From mathcomp +Require Import all_ssreflect. + +From chip +Require Import extra connect acyclic kosaraju_acyclic closure. + +Inductive food := +| rigatoni_arrabiata +| rigatoni +| sauce +| tomato_puree +| red_pepper +| garlic. + +Definition eq_food (f f' : food) := +match f, f' with +| rigatoni_arrabiata, rigatoni_arrabiata => true +| rigatoni, rigatoni => true +| sauce, sauce => true +| tomato_puree, tomato_puree => true +| red_pepper, red_pepper => true +| garlic, garlic => true +| _, _ => false +end. + +Lemma eq_foodP : Equality.axiom eq_food. +Proof. +case. +- case; try by constructor 2. + by constructor 1. +- case; try by constructor 2. + by constructor 1. +- case; try by constructor 2. + by constructor 1. +- case; try by constructor 2. + by constructor 1. +- case; try by constructor 2. + by constructor 1. +- case; try by constructor 2. + by constructor 1. +Defined. + +Definition food_eqMixin := + Eval hnf in EqMixin eq_foodP. +Canonical food_eqType := + Eval hnf in EqType food food_eqMixin. + +Definition food_pickle f := +match f with +| rigatoni_arrabiata => 0 +| rigatoni => 1 +| sauce => 2 +| tomato_puree => 3 +| red_pepper => 4 +| garlic => 5 +end. + +Definition food_unpickle n := +match n with +| 0 => Some rigatoni_arrabiata +| 1 => Some rigatoni +| 2 => Some sauce +| 3 => Some tomato_puree +| 4 => Some red_pepper +| 5 => Some garlic +| _ => None +end. + +Lemma food_pcancel : pcancel food_pickle food_unpickle. +Proof. by case. Defined. + +Definition food_choiceMixin := + PcanChoiceMixin food_pcancel. +Canonical food_choiceType := + Eval hnf in ChoiceType food food_choiceMixin. + +Definition food_countMixin := + CountMixin food_pcancel. +Canonical food_countType := + Eval hnf in CountType food food_countMixin. + +Definition food_enum := +[:: rigatoni_arrabiata; rigatoni; sauce; tomato_puree; red_pepper; garlic]. + +Lemma food_finite : Finite.axiom food_enum. +Proof. by case. Defined. + +Definition food_finMixin := + FinMixin food_finite. +Canonical food_finType := + Eval hnf in FinType food food_finMixin. + +Definition food_depends f := +match f with +| rigatoni_arrabiata => [:: rigatoni; sauce] +| rigatoni => [::] +| sauce => [:: tomato_puree; red_pepper; garlic] +| tomato_puree => [::] +| red_pepper => [::] +| garlic => [::] +end. + +Definition food_rel := grel food_depends. + +Definition food_acyclic := kosaraju_acyclic food_depends. + +Notation food_rel_rev := [rel x y | food_rel y x]. + +Definition food_rev_impacted := impacted food_rel_rev. diff --git a/core/connect.v b/core/connect.v new file mode 100644 index 0000000..e0051e8 --- /dev/null +++ b/core/connect.v @@ -0,0 +1,605 @@ +From mathcomp +Require Import all_ssreflect. + +From chip +Require Import extra. + +Set Implicit Arguments. +Unset Strict Implicit. +Unset Printing Implicit Defensive. + +Section Fin. + +Variable V : finType. + +Section Diconnect. + +Variable g : rel V. + +Local Notation "x -[]-> y" := + (connect g x y) (at level 10, format "x -[]-> y") . + +Lemma connect_rev (x y : V) : + connect g x y -> connect [rel x y | g y x] y x. +Proof. +move=> /connectP[p Pxp ->]. +elim: p x Pxp => // z p IH x /=/andP[xGy /IH sCz]. +by apply: connect_trans sCz (connect1 _). +Qed. + +Definition diconnect x y := connect g x y && connect g y x. + +Lemma diconnect0 : reflexive diconnect. +Proof. by move=> x; apply/andP. Qed. + +Lemma diconnect_sym : symmetric diconnect. +Proof. by move=> x y; apply/andP/andP=> [] []. Qed. + +Lemma diconnect_trans : transitive diconnect. +Proof. +move=> x y z /andP[Cyx Cxy] /andP[Cxz Czx]. +by rewrite /diconnect (connect_trans Cyx) ?(connect_trans Czx). +Qed. + +End Diconnect. + +Lemma eq_diconnect r1 r2 : r1 =2 r2 -> diconnect r1 =2 diconnect r2. +Proof. +by move=> r1Er2 x y; rewrite /diconnect !(eq_connect r1Er2). +Qed. + +Section Relto. + +Variable g : rel V. + +Local Notation "x -[ s ]-> y" := + (connect (rel_of_simpl_rel (relto s g)) x y) + (at level 10, format "x -[ s ]-> y"). + +Local Notation "x -[]-> y" := + (connect g x y) (at level 10, format "x -[]-> y") . + +Local Notation "x =[]= y" := (diconnect g x y) + (at level 10, format "x =[]= y"). + +Local Notation "x =[ a ]= y" := (diconnect (rel_of_simpl_rel (relto a g)) x y) + (at level 10, format "x =[ a ]= y"). + +Lemma connect_to_from a x y : + x -[a]-> y -> connect (relfrom a [rel x y | g y x]) y x. +Proof. +move => /connect_rev. +by apply: connect_sub => x1 y1 H; apply: connect1 . +Qed. + +Lemma connect_from_to a x y : + connect (relfrom a g) x y -> connect (relto a [rel x y | g y x]) y x. +Proof. +move => /connect_rev. +by apply: connect_sub => x1 y1 H; apply: connect1 . +Qed. + +Lemma connect_to1 (a : pred V) x y : a y -> g x y -> x -[a]-> y. +Proof. by move=> ay Rxy; apply: connect1; rewrite /= [_ \in _]ay. Qed. + +Lemma connect_toW a: + subrel (connect (relto a g)) (connect g). +Proof. by apply: connect_sub => x y /andP[_ H]; apply: connect1. Qed. + +Lemma connect_to_sub (a b : pred V) x y : + a \subset b -> x -[a]-> y -> x -[b]-> y. +Proof. +move=> /subsetP Hs. +apply/connect_sub => x1 y1 /= /andP[y1Ia x1Ry1]. +by apply: connect_to1 (Hs _ _) _. +Qed. + +Lemma diconnect_to_sub (a b : pred V) x y : + a \subset b -> x =[a]= y -> x =[b]= y. +Proof. +by move=> Hs /andP[Cxy Cyx]; rewrite /diconnect !(connect_to_sub Hs). +Qed. + +Lemma eq_diconnect_to (a b : pred V) x y : a =1 b -> x =[a]= y = x =[b]= y. +Proof. +move=> aEb; apply: eq_diconnect=> x1 y1. +by rewrite /= -!topredE /= aEb. +Qed. + +Lemma diconnect_to_predT : diconnect (relto predT g) =2 diconnect g. +Proof. by move=> x y. Qed. + +Lemma connect_toT : (connect (relto predT g)) =2 (connect g). +Proof. by []. Qed. + +Lemma connect_to_forced (a : pred V) x y : + (forall z, z != x -> x -[]-> z -> z -[]-> y -> a z) -> + x -[]-> y -> x -[a]-> y. +Proof. +move=> Hf /connectP[p {p}/shortenP[p Hp Up _ Hy]]. +apply/connectP. +elim: p {-2 4}x Hy Up Hp (connect0 (relto a g) x) => + [z /=-> _ _ Hz| z p IH /= z1 Hy /and3P[H1 H2 H3] /andP[Rxy Pp] Hz1]. + by exists [::]. +move: H1; rewrite inE negb_or => /andP[xDz H1]. +have Az : a z. + apply: Hf; first by rewrite eq_sym. + apply: connect_trans (connect_toW Hz1) (connect1 Rxy). + by apply/connectP; exists p. +have Raz : x -[a]-> z. + by apply: connect_trans Hz1 (connect_to1 Az Rxy). +have Uxp : uniq (x :: p) by rewrite /= H1. +have [p1 H1p1 H2p1] := IH _ Hy Uxp Pp Raz. +by exists (z :: p1); rewrite //= [_ \in _]Az Rxy. +Qed. + +Lemma reltoI a b : relto (predI a b) g =2 relto a (relto b g). +Proof. by move=> x y; rewrite /= andbA. Qed. + +Lemma connect_to_C1r x y z : + ~~ z -[]-> y -> x -[]-> y -> x -[predC1 z]-> y. +Proof. +move=> Hzy Hxy. +apply: connect_to_forced => //= z1 H1 H2 H3. +by apply/eqP=> H4; case/negP: Hzy; rewrite -H4. +Qed. + +Lemma connect_to_C1l x y z : + ~~ x -[]-> z -> x -[]-> y -> x -[predC1 z]-> y. +Proof. +move=> Hzy Hxy. +apply: connect_to_forced => //= z1 H1 H2 H3. +by apply/eqP=> H4; case/negP: Hzy; rewrite -H4. +Qed. + +Lemma connect_to_C1_id x y : x -[]-> y = x -[predC1 x]-> y. +Proof. +apply/idP/idP; last by apply: connect_toW. +case/connectP => p /shortenP[p' Pxp' Uxp' Sxp' Lyxp']. +apply/connectP; exists p' => //=. +rewrite path_to Pxp'; apply/allP=> z zIp' /=. +have /= /andP[H _] := Uxp'. +by apply: contraNneq H => <-. +Qed. + +(* Canonical element in a list : find the first element of l + that is equivalent to x walking only that satisfies a *) +Definition can_to x a l := nth x l (find (diconnect (relto a g) x) l). + +Local Notation "C[ x ]_( a , l ) " := (can_to x a l) + (at level 9, format "C[ x ]_( a , l )"). + +Lemma eq_can_to x a b l : a =1 b -> C[x]_(a, l) = C[x]_(b, l). +Proof. +move=> aEb; rewrite /can_to /=. +congr (nth _ _ _). +apply: eq_find => y. +by apply: eq_diconnect_to. +Qed. + +Lemma mem_can_to x a l : x \in l -> C[x]_(a, l) \in l. +Proof. +move=> xIp1; rewrite /can_to. +by case: (leqP (size l) (find (diconnect (relto a g) x) l)) => H1; + [rewrite nth_default | rewrite mem_nth]. +Qed. + +Lemma can_to_cons x y a l : + C[x]_(a, y :: l) = if x =[a]= y then y else C[x]_(a,l). +Proof. by rewrite /can_to /=; case: (boolP (diconnect _ _ _)) => Hr. Qed. + +Lemma can_to_cat x a l1 l2 : x \in l1 -> C[x]_(a, l1 ++ l2) = C[x]_(a, l1). +Proof. +move=> xIl1. +rewrite /can_to find_cat; case: (boolP (has _ _)). + by rewrite nth_cat has_find => ->. +by move/hasPn/(_ x xIl1); rewrite diconnect0. +Qed. + +Lemma diconnect_can_to x a l : x \in l -> C[x]_(a, l) =[a]= x. +Proof. +move=> xIl; rewrite diconnect_sym; apply: nth_find. +by apply/hasP; exists x => //; exact: diconnect0. +Qed. + +(* x occurs before y in l *) +Definition before (l : seq V) x y := index x l <= index y l. + +Local Notation "x =[ l ]< y" := (before l x y) + (at level 10, format "x =[ l ]< y"). + +Lemma before_filter_inv a x y l (l1 := [seq i <- l | a i]) : + x \in l1 -> y \in l1 -> x =[l1]< y -> x =[l]< y. +Proof. +rewrite {}/l1 /before; elim: l => //= z l IH. +case E : (a z) => /=. + rewrite !inE ![_ == z]eq_sym. + by case: eqP => //= Hx; case: eqP. +move=> xIl yIl; move: (xIl) (yIl). +rewrite !mem_filter. +case: eqP => [<-|_ _]; first by rewrite E. +case: eqP => [<-|_ _]; first by rewrite E. +by apply: IH. +Qed. + +Lemma before_filter x y l a (l1 := [seq i <- l | a i]) : + x \in l1 -> x =[l]< y -> x =[l1]< y. +Proof. +rewrite {}/l1 /before; elim: l => //= z l IH. +case E : (a z) => /=. + rewrite inE eq_sym. + by case: eqP => //= Hx; case: eqP. +move=> xIl Hi; apply: IH => //. +by case: eqP xIl Hi => [<-| _]; [rewrite mem_filter E | case: eqP]. +Qed. + +Lemma leq_index_nth x (l : seq V) i : index (nth x l i) l <= i. +Proof. +elim: l i => //= y l IH [|i /=]; first by rewrite eqxx. +by case: eqP => // _; apply: IH. +Qed. + +Lemma index_find x (l : seq V) a : has a l -> index (nth x l (find a l)) l = find a l. +Proof. +move=> Hal. +apply/eqP; rewrite eqn_leq leq_index_nth. +case: leqP => // /(before_find x). +by rewrite nth_index ?nth_find // mem_nth // -has_find. +Qed. + +Lemma before_can_to x y a l : + x \in l -> y \in l -> x =[a]= y -> C[x]_(a, l) =[l]< y. +Proof. +move=> Hx Hy; rewrite diconnect_sym => Hr. +have F : has (diconnect (relto a g) x) l. + by apply/hasP; exists y => //; rewrite diconnect_sym. +rewrite /before /can_to index_find //. +case: leqP => // /(before_find x). +by rewrite nth_index // diconnect_sym Hr. +Qed. + +Lemma before_can_toW x a b l : + x \in l -> b \subset a -> C[x]_(a, l) =[l]< C[x]_(b, l). +Proof. +move=> xIl Hs. +have Hs1 : has (diconnect (relto a g) x) l. + by apply/hasP; exists x => //; exact: diconnect0. +have Hs2 : has (diconnect (relto b g) x) l. + by apply/hasP; exists x => //; exact: diconnect0. +rewrite /before /can_to !index_find //. +apply: sub_find => z. +by apply: diconnect_to_sub. +Qed. + +End Relto. + +Section ConnectRelto. + +Variable g : rel V. + +Local Notation "x -[ s ]-> y" := + (connect (rel_of_simpl_rel (relto s g)) x y) + (at level 10, format "x -[ s ]-> y"). + +Local Notation "x -[]-> y" := + (connect g x y) (at level 10, format "x -[]-> y") . + +Local Notation "x =[]= y" := (diconnect g x y) + (at level 10, format "x =[]= y"). + +Local Notation "x =[ a ]= y" := (diconnect (rel_of_simpl_rel (relto a g)) x y) + (at level 10, format "x =[ a ]= y"). + +Local Notation "C[ x ]_( a , l )" := (can_to g x a l) + (at level 9, format "C[ x ]_( a , l )"). + +Local Notation "x =[ l ]< y" := (before l x y) + (at level 10, format "x =[ l ]< y"). + +(* The list l is topogically sorted with respect to a if + all elements of l respects a + and + the list is closed under connection with respect to a + and + canonical elements are before their connected elements +*) +Definition tsorted (a : pred V) (l : seq V) := + [/\ l \subset a, + forall x y, x \in l -> x -[a]-> y -> y \in l & + forall x y, x \in l -> x -[a]-> y -> C[x]_(a, l) =[l]< y + ]. + +Local Notation " TS[ a , l ]" := (tsorted a l) + (at level 10, format "TS[ a , l ]"). +Local Notation "TS[ l ] " := (tsorted predT l) + (at level 10, format "TS[ l ]"). + +Lemma tsortedE a l : + l \subset a -> + (forall x y, x \in l -> x -[a]-> y -> y \in l /\ C[x]_(a, l) =[l]< y) -> + TS[a, l]. +Proof. +by move=> lSa HR; split => // x y xIl xCy; have [] := HR _ _ xIl xCy. +Qed. + +Lemma eq_tsorted a b l : a =1 b -> TS[a, l] -> TS[b , l]. +Proof. +move=> aEb [/= lSa Ca Ba]. +have aE2b : relto a g =2 relto b g by move=> x y; rewrite /= -topredE /= aEb. +split => /= [|x y xIl xCy|x y xIl xCy]. +- apply: subset_trans lSa _. + by apply/subsetP=> i; rewrite -!topredE /= aEb. +- by apply: Ca xIl _; rewrite (eq_connect aE2b). +rewrite -(eq_can_to _ _ _ aEb). +by apply: Ba xIl _; rewrite (eq_connect aE2b). +Qed. + +Lemma tsorted_nil a : TS[a, [::]]. +Proof. by split=> //; apply/subsetP => x. Qed. + +(* Removing the equivalent element on top preserves the sorting *) +Lemma tsorted_inv x a l : + TS[a, x :: l] -> TS[a, [seq y <- x :: l | ~~ x =[a]= y]]. +Proof. +move=> [xlSa CR BR]; split => [|y z|y z]. +- rewrite /= diconnect0 /=. + apply/(subset_trans _ xlSa)/subsetP=> z /=. + by rewrite !inE orbC mem_filter => /andP[_ ->]. +- rewrite !mem_filter => /andP[xNDy yIxl] yCz. + apply/andP; split; last by apply: CR yCz. + apply: contra xNDy => xDz. + have : C[y]_(a, x :: l) =[x :: l]< x. + apply: BR yIxl (connect_trans yCz _). + by case/andP: xDz. + rewrite /before index_head /=; case: eqP => // -> _. + by apply: diconnect_can_to. +rewrite !mem_filter => /andP[xNDy yIxl] yCz. +have ->: C[y]_(a, [seq i <- x :: l | ~~ x =[a]= i]) = C[y]_(a, x :: l). + elim: (x :: l) => //= t l1 IH. + case : (boolP (_ =[_]= _)) => Ext /=; last first. + by rewrite /can_to /=; case : (boolP (_ =[_]= _)). + rewrite IH /can_to /=. + case : (boolP (_ =[_]= _)) => Eyt //=. + by case/negP: xNDy; apply: diconnect_trans Ext _; rewrite diconnect_sym. +apply: before_filter; last by apply: BR. +rewrite mem_filter mem_can_to // ?andbT. +apply: contra xNDy => xDc. +by apply: diconnect_trans xDc (diconnect_can_to _ _ _). +Qed. + +(* Computing the connected elements for the reversed graph gives + the equivalent class of the top element of a tologically sorted list *) +Lemma tsorted_diconnect x y a l : + TS[a, x :: l] -> x =[a]= y = (y \in x :: l) && y -[a]-> x. +Proof. +move=> [_ CR BR]. +apply/idP/idP=> [/andP[Cxy Cyx]|/andP[yIxl Cyx]]. + by rewrite (CR x y) // inE eqxx. +have F := diconnect_can_to _ _ yIxl. +have := BR y x yIxl Cyx. +by rewrite /before /= eqxx; case: eqP => //->. +Qed. + +(* Computing topological sort by concatenation *) +Lemma tsorted_cat a l1 l2 : + TS[a, l1] -> TS[[predD a & [pred x in l1]], l2] -> TS[a, l2 ++ l1]. +Proof. +set b := [predD _ & _]. +move=> [l1Sa Cl1 Bl1] [l2Sb Cl2] Bl2. +apply: tsortedE => [|x y]. + apply/subsetP => z. + rewrite mem_cat => /orP[/(subsetP l2Sb)|/(subsetP l1Sa) //]. + by rewrite inE => /andP[]. +have [xIl2 _ Hc|xNIl2] := boolP (x \in l2); last first. + rewrite mem_cat (negPf xNIl2) /= => xIl1 Cxy. + have yIl1 := Cl1 _ _ xIl1 Cxy. + have xBy := Bl1 _ _ xIl1 Cxy. + split; first by rewrite mem_cat yIl1 orbT. + rewrite /before [index y _]index_cat. + have [yIl2|yNil2] := boolP (y \in l2). + have/subsetP/(_ y yIl2)/= := l2Sb. + by rewrite !inE /= yIl1. + rewrite index_cat; have [rIl2| rNIl2] := boolP (_ \in l2). + by apply: leq_trans (index_size _ _) (leq_addr _ _). + rewrite leq_add2l. + move: rNIl2; rewrite /can_to find_cat. + have [HH|HH] := boolP (has _ _). + by rewrite nth_cat -has_find HH mem_nth // -has_find. + rewrite nth_cat ltnNge leq_addr /= => _. + by rewrite addnC addnK. +have [/forallP F|] := + boolP [forall z, [&& z != x, x -[a]-> z & z -[a]-> y] ==> + (z \notin l1)]. + have xCy : x -[b]-> y. + have /eq_connect-> : + relto [predD a & [pred x in l1]] g =2 + relto [predC [pred x in l1]] (relto a g). + by move=> x1 y1; rewrite /= !inE !andbA. + apply: connect_to_forced => // z zDx xCz zCy. + rewrite !inE /=. + have /implyP->// := F z. + by rewrite zDx xCz. + have yIl2 := Cl2 _ _ xIl2 xCy. + have xBy := Bl2 _ _ xIl2 xCy. + split; first by rewrite mem_cat yIl2. + rewrite /before [index y _]index_cat yIl2. + apply: leq_trans xBy. + rewrite can_to_cat // index_cat mem_can_to //. + apply: before_can_toW=> //; apply/subsetP=> i. + by rewrite !inE => /andP[]. +rewrite negb_forall => /existsP[z]. +rewrite negb_imply -!andbA negbK => /and4P[zDx xCz zCy zIl1]. +have yIl1 := Cl1 _ _ zIl1 zCy. +have zBy := Bl1 _ _ zIl1 zCy. +split; first by rewrite mem_cat yIl1 orbT. +rewrite /before [index y _]index_cat. +have [yIl2|_] := boolP (_ \in _). + have/subsetP/(_ y yIl2)/= := l2Sb. + by rewrite !inE yIl1. +rewrite index_cat. +have [_|/negP[]] := boolP (_ \in _). + by apply: leq_trans (index_size _ _) (leq_addr _ _). +rewrite /can_to; elim: (l2) xIl2 => //= a1 l IH. +rewrite inE => /orP[/eqP->|/IH]; first by rewrite diconnect0 inE eqxx. +case: (_ =[_]= _) => //=; first by rewrite inE eqxx. +by rewrite inE orbC => ->. +Qed. + +(* Elements that are notin l do not matter *) +Lemma tsorted_setU1_l x a l (b : pred V := [predD1 a & x]) : + x \notin l -> TS[a, l] -> TS[b, l]. +Proof. +move=> xNIl [lSa Cl Bl]; apply: tsortedE => /= [|t z tIl tCz]. + apply/subsetP=> i; rewrite !inE. + by case: eqP => //= [-> /(negP xNIl)//|_ /(subsetP lSa)]. +have tC'z : t -[a]-> z. + apply: connect_to_sub tCz. + by apply/subsetP => i /andP[]. +have zIl := Cl _ _ tIl tC'z. +have tBz := Bl _ _ tIl tC'z. +split => //; suff->: C[t]_(b, l) = C[t]_(a, l) by []. +congr nth; apply: eq_in_find => y /= yIl. +have [xIa|xNIa] := boolP (x \in a); last first. + apply: eq_diconnect_to => x1. + by rewrite /b /=; case: eqP=> // ->; rewrite [a _](negPf xNIa). +apply/idP/idP => /=. + apply/diconnect_to_sub/subsetP=> u. + by rewrite !inE => /andP[]. +case/andP=> tCy Cyt. +have /eq_diconnect-> : relto b g =2 relto (predC1 x) (relto a g). + by move=> x1 y1; rewrite /b /= !inE !andbA. +by apply/andP; split; apply: connect_to_C1l => //; + apply: contra xNIl=> /Cl->. +Qed. + +(* Computing topologically sorted list by adding a top element *) +Lemma tsorted_cons_r x a l (b : pred V := [predD1 a & x]) : + (forall y, y \in l -> x -[a]-> y) -> + (forall y, g x y -> a y -> y != x -> y \in l) -> + a x -> TS[b, l] -> TS[a, x :: l]. +Proof. +move=> AxC AyIl Ax [/= lSb Cl Bl]; apply: tsortedE => [|y z] /=. + apply/subsetP=> y; rewrite inE => /orP[/eqP->//|/(subsetP lSb)]. + by rewrite inE=> /andP[]. +have F t : t != x -> x -[b]-> t -> t \in l. + move=> tDx /connectP[[_ /eqP|v p]] /=; first by rewrite (negPf tDx). + rewrite -!andbA /= => /and4P[vDx vIa xRv Pbrvp tLvp]. + have/Cl->// : v \in l. + by apply: AyIl => //; rewrite inE. + by apply/connectP; exists p. +rewrite inE. +have Hr : relto b g =2 (relto (predC1 x) (relto a g)). + by move=> x1 y1; rewrite /= !inE !andbA. +have [/eqP-> /= _ xCz|yDx /= yIl yCz] := boolP (y == x). + split; last by rewrite /before /= can_to_cons diconnect0 eqxx. + have [/eqP<-|zDx] := boolP (z == x); first by rewrite !inE eqxx. + rewrite inE (F z) ?orbT // 1?eq_sym // (eq_connect Hr). + by rewrite -connect_to_C1_id. +have [yCz'|yNCz'] := boolP (y -[b]-> z). + have zIxs := Cl _ _ yIl yCz'. + have yBz := Bl _ _ yIl yCz'. + split; first by rewrite inE zIxs orbT. + have [/eqP xEz|xDz] := boolP (x == z). + rewrite can_to_cons. + suff->: y =[a]= x by rewrite /before /= eqxx. + rewrite /diconnect {1}xEz yCz /=. + by apply: AxC. + rewrite can_to_cons; case: (_ =[_]= _); first by rewrite /before /= eqxx. + rewrite /before /= (negPf xDz); case: eqP => //= _. + rewrite ltnS. + apply: leq_trans yBz => /=. + apply: before_can_toW => //; apply/subsetP=> i. + by rewrite inE => /andP[]. +have [yCx|yNCx] := boolP (y -[a]-> x); last first. + case/negP: yNCz'. + by rewrite (eq_connect Hr); apply: connect_to_C1l. +have [xCz| xNCz] := boolP (x -[a]-> z); last first. + case/negP: yNCz'. + by rewrite (eq_connect Hr); apply: connect_to_C1r. +split. + rewrite inE. + have [//|zDx/=] := boolP (z == x). + apply: F => //. + by rewrite (eq_connect Hr) -connect_to_C1_id. +rewrite /before can_to_cons. +suff->: y =[a]= x; first by rewrite /before /= eqxx. +rewrite /diconnect yCx /=. +by apply: AxC. +Qed. + +Lemma connect_to_rev l a b x y : + {subset b <= a} -> + (forall z, (z \in b) = (z \in x :: l)) -> + TS[a, x :: l] -> + ((y \in x :: l) && y -[a]-> x) = (connect (relto b [rel x y | g y x]) x y). +Proof. +move=> /subsetP HS HD HW. +have xIxl : x \in x :: l by rewrite inE eqxx. +case: (x =P y) => [<-|/eqP xDy]; first by rewrite xIxl !connect0. +have [yIxl/=|yNIxl/=] := boolP (y \in _); last first. + apply/sym_equal/idP/negP; apply: contra yNIxl => /connectP[[/= _ ->//|z p]]. + rewrite path_to /= => /and3P[_ zB /allP ApB ->]. + have := mem_last z p. + by rewrite -HD inE => /orP[/eqP->//|/ApB]. +have [yCx|yNCx] := boolP (y -[_]-> x); last first. +apply/sym_equal/idP/negP; apply: contra yNCx => xCy. +have /connectP[p Hp Hy] := connect_to_from xCy. + apply/connectP; exists p => //. + move: Hp; rewrite /= path_from path_to => /andP[->]. + case: p Hy => // z p1. + rewrite {3}lastI /= all_rcons => <- /= /andP[_ /allP Ap]. + rewrite [a x](subsetP HS) ?HD //. + by apply/allP=> i /Ap iB; rewrite [a _](subsetP HS). +apply/sym_equal/idP. +have /connect_to_from/connectP[p Hp Hy] : y -[b]-> x. + rewrite (eq_connect (_ : _ =2 (relto b (relto a g)))); last first. + move=> x1 y1 /=. + by case: (boolP (_ \in b)) => // /(subsetP HS)->. + apply: connect_to_forced => // z zDy yCz zCx. + rewrite [b _]HD. + by have [_ /(_ y z yIxl yCz)] := HW. +apply/connectP; exists p => //. +move: Hp; rewrite /= path_from path_to => /andP[->]. +case: p Hy => // z p1. +rewrite {3}lastI /= /= all_rcons => <- /= /andP[_ Ap]. +by rewrite [b _]HD yIxl. +Qed. + +End ConnectRelto. + +Section Sub. + +Variable P : pred V. + +Local Notation I := (sig_finType P). + +Variable g : rel V. + +Local Notation gsub := [rel x y : I | g (val x) (val y)]. + +Lemma gsub_path : forall p v, + path gsub v p -> + path g (val v) [seq val x | x <- p]. +Proof. +elim => //. +move => v0 p IH v. +move/andP => [Hg Hp]. +apply/andP. +split => //. +exact: IH. +Qed. + +Lemma gsub_connect : forall (v v' : I), + connect gsub v v' -> + connect g (val v) (val v'). +Proof. +move => v v'. +move/connectP => [p Hp] Hl. +apply/connectP. +exists (map val p); first by apply: gsub_path. +by rewrite Hl last_map. +Qed. + +End Sub. + +End Fin. diff --git a/core/dfs_set.v b/core/dfs_set.v new file mode 100644 index 0000000..551aa3d --- /dev/null +++ b/core/dfs_set.v @@ -0,0 +1,465 @@ +Require Import OrderedType. +Require Import MSetInterface. +Require Import MSetFacts. +Require Import MSetRBT. + +From mathcomp +Require Import all_ssreflect. + +From chip +Require Import ordtype close_dfs. + +Set Implicit Arguments. +Unset Strict Implicit. +Unset Printing Implicit Defensive. + +Module Type OrdType. +Parameter T : ordType. +End OrdType. + +Module OrdTypeUsualOrderedType (Import OT : OrdType) <: UsualOrderedType. + +Definition t : Type := T. +Definition eq := @eq T. +Definition eq_equiv := @eq_equivalence T. + +Definition lt : t -> t -> Prop := @ord T. + +Lemma lt_strorder : StrictOrder (@ord T). +Proof. +split; first by move => x Hi; rewrite irr in Hi. +by move => x y z; apply: trans. +Qed. + +Lemma lt_compat : Proper (eq ==> eq ==> iff) (@ord T). +Proof. +move => x1 y1 Hxy1 x2 y2 Hxy2. +by rewrite Hxy1 Hxy2. +Qed. + +Definition compare x y := + if x == y then Eq else if @ord T x y then Lt else Gt. + +Lemma compare_spec x y : CompSpec eq (@ord T) x y (compare x y). +Proof. +rewrite /compare. +case: ifP; first by move/eqP => Heq; apply CompEq. +move/negP/negP/eqP => Heq. +case: ifP => Hxy; first by apply CompLt. +move/negP: Hxy => Hxy. +apply CompGt. +move/orP: (total x y). +case => //. +move/orP. +case => //. +by move/eqP. +Qed. + +Definition eq_dec (x y : t) : {x = y}+{x <> y}. + refine + (match x == y as exy return (_ = exy -> _) with + | true => fun H => left _ + | false => fun H => right _ + end (refl_equal _)). +- by move/eqP: H. +- by move/negP/negP/eqP: H. +Defined. + +End OrdTypeUsualOrderedType. + +Module Type FinType. +Parameter T : finType. +End FinType. + +Module Type FinOrdType (Import FT : FinType). +Parameter ordT : rel T. +Parameter irr_ordT : irreflexive ordT. +Parameter trans_ordT : transitive ordT. +Parameter total_ordT : forall x y, [|| ordT x y, x == y | ordT y x]. +End FinOrdType. + +Module Type FinUsualOrderedType (FT : FinType) <: UsualOrderedType. +Definition t : Type := FT.T. +Definition eq := @eq t. +Definition eq_equiv := @eq_equivalence t. +Parameter Inline lt : t -> t -> Prop. +Parameter lt_strorder : StrictOrder lt. +Parameter lt_compat : Proper (eq ==> eq ==> iff) lt. +Parameter compare : t -> t -> comparison. +Parameter compare_spec : forall t1 t2, CompSpec eq lt t1 t2 (compare t1 t2). +Parameter eq_dec : forall x y : t, {x = y} + { x <> y }. +End FinUsualOrderedType. + +Module FinOrdUsualOrderedType (FT : FinType) (FOT : FinOrdType FT) <: FinUsualOrderedType FT. + +Module OT. +Definition T : ordType := OrdType FT.T (OrdMixin FOT.irr_ordT FOT.trans_ordT FOT.total_ordT). +End OT. + +Module OTUOT := OrdTypeUsualOrderedType OT. + +Definition t : Type := FT.T. +Definition eq := @eq t. +Definition eq_equiv := @eq_equivalence t. +Definition lt := OTUOT.lt. +Definition lt_strorder := OTUOT.lt_strorder. +Definition lt_compat := OTUOT.lt_compat. +Definition compare := OTUOT.compare. +Definition compare_spec := OTUOT.compare_spec. +Definition eq_dec := OTUOT.eq_dec. + +End FinOrdUsualOrderedType. + +Module DFS (Import FT : FinType) (FUOT : FinUsualOrderedType FT) (MS : MSetInterface.S with Module E := FUOT). + +Module MSF := Facts MS. + +Fixpoint sdfs g n s x := + if MS.mem x s then s else + if n is n'.+1 then foldl (sdfs g n') (MS.add x s) (g x) else s. + +Lemma subset_sdfs : forall (g : T -> seq T) n (s : seq T) x ms, + MS.mem x ms -> + MS.mem x (foldl (sdfs g n) ms s). +Proof. +move => g n s x ms Hx. +have ->: s = rev (rev s) by rewrite revK. +rewrite foldl_rev. +generalize (rev s) => s'. +move: n s' x ms Hx {s}. +elim => [|n IHn]. +- elim => //=. + move => x s IH y ms Hy. + by case: ifP => Hm; apply: IH. +- elim => //=. + move => x s IH y ms Hy. + case: ifP => Hm; first by apply: IH. + have ->: g x = rev (rev (g x)) by rewrite revK. + rewrite foldl_rev. + apply: IHn. + apply/MSF.mem_1. + apply/MSF.add_2. + apply/MSF.mem_2. + exact: IH. +Qed. + +Lemma dfs_sdfs_in : forall (g : T -> seq T) n (s : seq T) (ms : MS.t) x z, + (forall y, y \in s = MS.mem y ms) -> + x \in dfs g n s z = MS.mem x (sdfs g n ms z). +Proof. +move => g. +elim => //=; first by move => s ms x Hy; case: ifP; case: ifP. +move => n IH s ms x z Hy. +case: ifP; case: ifP => //=. +- move => Hx Hs. + case Hm: (MS.mem _ _) => //. + * move/negP: Hx. + case. + by rewrite -Hy. + * move/negP: Hx. + case. + by rewrite -Hy. +- move => Hx Hs. + case Hm: (MS.mem _ _) => //. + * move/negP: Hs. + case. + by rewrite Hy. + * move/negP: Hs. + case. + by rewrite Hy. +- move => Hz Hs. + have Hy': forall y, (y \in z :: s) = MS.mem y (MS.add z ms). + move => y. + rewrite in_cons. + apply/orP. + case: ifP => Hm. + * move/MSF.mem_2: Hm. + move/MSF.add_3 => Hzy. + case Hyz: (y == z); first by left. + right. + rewrite Hy. + apply/MSF.mem_1. + apply Hzy. + move => Hyz'. + move/negP/negP/eqP: Hyz. + by case. + * move => Hyz. + case: Hyz. + + move/eqP => Hyz. + move/negP: Hm. + case. + apply/MSF.mem_1. + by apply/MSF.add_1. + + move => Hyz. + move/negP: Hm. + case. + apply/MSF.mem_1. + apply/MSF.add_2. + apply/MSF.mem_2. + by rewrite -Hy. + move: Hy'. + set s' := z :: s. + set ms' := MS.add z ms. + set s0 := g z. + move: s0 s' ms'. + elim => //=. + move => z0 s0 IH' s' ms' Hs'. + by erewrite IH'; eauto. +Qed. + +Definition srclosure g := + foldr (fun x s => sdfs g #|T| s x) MS.empty. + +Definition srclosure' g := + foldl (sdfs g #|T|) MS.empty. + +Lemma rclosure_srclosure : forall g s x, + x \in rclosure g s = MS.mem x (srclosure g s). +Proof. +move => g. +elim => //=. +- move => x. + rewrite in_nil. + case Hx: (MS.mem x MS.empty) => //. + move/MSF.mem_2: Hx. + by move/MSF.empty_1. +- move => x s IH y. + exact: dfs_sdfs_in. +Qed. + +Lemma in_foldr_mem : forall g s0 n x, + x \in foldr (fun x s => dfs g n s x) [::] s0 = + MS.mem x (foldr (fun x s => sdfs g n s x) MS.empty s0). +Proof. +move => g. +elim => //=. +- move => n x. + rewrite in_nil. + case Hm: (MS.mem x MS.empty) => //. + move/MSF.mem_2: Hm. + by move/MSF.empty_1. +- move => x s IH n y. + by erewrite dfs_sdfs_in; eauto. +Qed. + +Lemma srclosure_in_lr : forall g s x, + MS.mem x (foldl (sdfs g #|T|) MS.empty s) -> + MS.mem x (foldr (fun x s => sdfs g #|T| s x) MS.empty s). +Proof. +move => g s x. +have {1} ->: s = rev (rev s) by rewrite revK. +rewrite foldl_rev. +rewrite -(in_foldr_mem g s) -(in_foldr_mem g (rev s)). +rewrite (@closure_eqi _ _ (rev s) s) //. +move => y. +have Hs := has_rev (pred1 y) s. +by rewrite 2!has_pred1 in Hs. +Qed. + +Lemma srclosure_in_rl : forall g s x, + MS.mem x (foldr (fun x s => sdfs g #|T| s x) MS.empty s) -> + MS.mem x (foldl (sdfs g #|T|) MS.empty s). +Proof. +move => g s x. +have {2} ->: s = rev (rev s) by rewrite revK. +rewrite foldl_rev. +rewrite -(in_foldr_mem g s) -(in_foldr_mem g (rev s)). +rewrite (@closure_eqi _ _ s (rev s)) //. +move => y. +have Hs := has_rev (pred1 y) s. +by rewrite 2!has_pred1 in Hs. +Qed. + +Lemma srclosure_srclosure' : forall g s x, + MS.mem x (srclosure g s) = MS.mem x (srclosure' g s). +Proof. +move => g s x. +case Hx: (MS.mem _ _); case Hx': (MS.mem _ _) => //. +- move/negP: Hx'. + case. + exact: srclosure_in_rl. +- move/negP: Hx. + case. + exact: srclosure_in_lr. +Qed. + +Lemma rclosure'_srclosure' : forall g s x, + x \in rclosure' g s = MS.mem x (srclosure' g s). +Proof. +move => g s x. +by rewrite -srclosure_srclosure' -rclosure_srclosure rclosure_rclosure'_i. +Qed. + +Definition elts_srclosure g s := + MS.elements (srclosure g s). + +Definition elts_srclosure' g s := + MS.elements (srclosure' g s). + +Lemma elements_in_mem : forall s x, + x \in MS.elements s = MS.mem x s. +Proof. +move => s x. +case Hi: (x \in _); case Hm: (MS.mem _ _) => //. +- move/negP: Hm. + case. + apply/MSF.mem_1. + apply/MSF.elements_2. + apply/InA_alt. + exists x. + split => //. + move: Hi. + set e := MS.elements _. + elim: e => //. + move => y e IH. + rewrite in_cons. + move/orP; case; first by move/eqP; left. + move => Hx. + by right; apply: IH. +- move/negP: Hi. + case. + move: Hm. + move/MSF.mem_2. + move/MSF.elements_1. + move/InA_alt => [y [Hx Hy]]. + rewrite Hx. + move: Hy. + set e := MS.elements _. + elim: e => //=. + move => z e IH. + case. + * move =>->. + rewrite in_cons. + apply/orP. + by left. + * rewrite in_cons => Hy. + apply/orP; right. + exact: IH. +Qed. + +Lemma elts_srclosureP g (modified : seq T) x : + reflect + (exists2 v, v \in modified & connect g v x) + (x \in elts_srclosure (rgraph g) modified). +Proof. +apply: (iffP idP). +- rewrite elements_in_mem -rclosure_srclosure. + by move/rclosureP. +- move/rclosureP. + rewrite rclosure_srclosure. + by rewrite elements_in_mem. +Qed. + +Lemma elts_srclosurePg g (modified : seq T) x : + reflect + (exists2 v, v \in modified & connect (grel g) v x) + (x \in elts_srclosure g modified). +Proof. +apply: (iffP idP). +- rewrite elements_in_mem -rclosure_srclosure. + by move/rclosurePg. +- move/rclosurePg. + rewrite rclosure_srclosure. + by rewrite elements_in_mem. +Qed. + +Lemma elts_srclosure'P g (modified : seq T) x : + reflect + (exists2 v, v \in modified & connect g v x) + (x \in elts_srclosure' (rgraph g) modified). +Proof. +apply: (iffP idP). +- rewrite elements_in_mem -rclosure'_srclosure' -rclosure_rclosure'_i. + by move/rclosureP. +- move/rclosureP. + rewrite rclosure_srclosure. + by rewrite srclosure_srclosure' elements_in_mem. +Qed. + +Lemma elts_srclosure'Pg g (modified : seq T) x : + reflect + (exists2 v, v \in modified & connect (grel g) v x) + (x \in elts_srclosure' g modified). +Proof. +apply: (iffP idP). +- rewrite elements_in_mem -rclosure'_srclosure' -rclosure_rclosure'_i. + by move/rclosurePg. +- move/rclosurePg. + rewrite rclosure_srclosure. + by rewrite srclosure_srclosure' elements_in_mem. +Qed. + +Lemma elts_srclosure_uniq : forall g s, + uniq (elts_srclosure g s). +Proof. +move => g s. +rewrite /elts_srclosure. +have Hs := MS.elements_spec2w (srclosure g s). +move: Hs. +set e := MS.elements _. +elim: e => //=. +move => x e IH Hn. +inversion Hn; subst. +apply/andP. +split; last by apply: IH. +apply/negP => Hx. +case: H1. +apply/InA_alt. +exists x; split => //. +elim: e Hx {IH Hn H2} => //=. +move => y e IH. +rewrite in_cons. +move/orP; case; first by move/eqP =>->; left. +move => Hx. +by right; apply: IH. +Qed. + +Lemma elts_srclosure'_uniq : forall g s, + uniq (elts_srclosure' g s). +Proof. +move => g s. +rewrite /elts_srclosure' /srclosure'. +have ->: s = rev (rev s) by rewrite revK. +rewrite foldl_rev. +exact: elts_srclosure_uniq. +Qed. + +Lemma rclosed_elts_srclosure : forall g s, + rclosed g (elts_srclosure (rgraph g) s). +Proof. +move => g s. +move => x y Hg. +rewrite 2!elements_in_mem -2!rclosure_srclosure. +exact: rclosed_rclosure. +Qed. + +Lemma rclosed_elts_srclosure' : forall g s, + rclosed g (elts_srclosure' (rgraph g) s). +Proof. +move => g s. +move => x y Hg. +rewrite 2!elements_in_mem -2!rclosure'_srclosure'. +exact: rclosed_rclosure'. +Qed. + +End DFS. + +Module Type OrdinalFinType <: FinType. +Parameter n : nat. +Definition T : finType := [finType of 'I_n]. +End OrdinalFinType. + +Module OrdinalFinOrdType (Import OFT : OrdinalFinType) <: FinOrdType OFT. +Definition ordT : rel T := fun x y => ltn x y. +Definition irr_ordT : irreflexive ordT := irr_ltn_nat. +Definition trans_ordT : transitive ordT := trans_ltn_nat. +Definition total_ordT : forall x y, [|| ordT x y, x == y | ordT y x] := total_ltn_nat. +End OrdinalFinOrdType. + +(* Instantiation test *) + +Module OFT5 <: OrdinalFinType. Definition n := 5. Definition T := [finType of 'I_5]. End OFT5. +Module OFOT5 <: FinOrdType OFT5 := OrdinalFinOrdType OFT5. +Module FUOT5 <: FinUsualOrderedType OFT5 := FinOrdUsualOrderedType OFT5 OFOT5. +Module RBSet5 <: MSetInterface.S := MSetRBT.Make FUOT5. +Module RBDFS5 := DFS OFT5 FUOT5 RBSet5. diff --git a/core/extra.v b/core/extra.v new file mode 100644 index 0000000..197e35a --- /dev/null +++ b/core/extra.v @@ -0,0 +1,198 @@ +From mathcomp +Require Import ssreflect ssrfun ssrbool eqtype ssrnat seq choice fintype tuple. +From mathcomp +Require Import bigop finset finfun perm fingraph path div. + +Set Implicit Arguments. +Unset Strict Implicit. +Unset Printing Implicit Defensive. + +Section extra_div. + +Lemma ltn_div2r p m n : p > 0 -> m %/ p < n %/ p -> m < n. +Proof. +move=> p_gt0 lt_div; rewrite (divn_eq m p) (divn_eq n p). +rewrite -(subnKC lt_div) mulnDl mulSn -!addnA addnCA ltn_add2l. +by rewrite (leq_trans (ltn_pmod _ _)) // leq_addr. +Qed. + +Lemma ltn_mod2r p m n : p > 0 -> m %/ p = n %/ p -> m %% p < n %% p -> m < n. +Proof. +move=> p_gt0 eq_div lt_mod; rewrite (divn_eq m p) (divn_eq n p). +by rewrite {}eq_div ltn_add2l in lt_mod *. +Qed. + +End extra_div. + +Section extra_seq. + +Lemma take_subseq (T : eqType) n (s : seq T) : subseq (take n s) s. +Proof. by rewrite -[X in subseq _ X](cat_take_drop n) prefix_subseq. Qed. + +Lemma drop_subseq (T : eqType) n (s : seq T) : subseq (drop n s) s. +Proof. by rewrite -[X in subseq _ X](cat_take_drop n) suffix_subseq. Qed. + +Lemma set_last_default (T : eqType) y0 x0 (s : seq T) : + size s > 0 -> last x0 s = last y0 s. +Proof. +by move=> s_gt0; rewrite -!nth_last; apply/set_nth_default; rewrite ?prednK. +Qed. + +Lemma last_take (T : eqType) (x : T) n s : + last x (take n s) = if n == 0 then x + else if n <= size s then nth x s n.-1 else last x s. +Proof. +elim: n s => [|n ihn] [|y s] //= in x *; rewrite {}ihn ltnS; case: n => //=. +by move=> n; case: ltnP => // n_lt; apply/set_nth_default. +Qed. + +Lemma last_drop (T : eqType) (x : T) n s : + last x (drop n s) = if n < size s then last x s else x. +Proof. +case: ltnP => sn; last by rewrite drop_oversize. +rewrite -[s in RHS](cat_take_drop n) last_cat. +by rewrite (@set_last_default _ x) ?size_drop ?subn_gt0. +Qed. + +Lemma uniq_catLR (T : eqType) (x : T) s1 s2 : uniq (s1 ++ s2) -> + x \in s1 ++ s2 -> (x \in s1) = (x \notin s2). +Proof. +rewrite mem_cat=> s_uniq /orP[] x_in; move: s_uniq. + by rewrite uniq_catC cat_uniq => /and3P[_ /hasPn /(_ _ x_in)->]. +by rewrite cat_uniq => /and3P[_ /hasPn /(_ _ x_in) /= /negPf->]; rewrite x_in. +Qed. + +Lemma uniq_catRL (T : eqType) (x : T) s1 s2 : uniq (s1 ++ s2) -> + x \in s1 ++ s2 -> uniq (s1 ++ s2) -> (x \in s2) = (x \notin s1). +Proof. +rewrite mem_cat uniq_catC => s_uniq x_s. +by rewrite (uniq_catLR s_uniq) // mem_cat orbC. +Qed. + +Lemma uniq_prod_eq : forall (T1 T2 : eqType) (s : seq (T1 * T2)) (x : T1) (y z : T2), + uniq [seq xy.1 | xy <- s] -> + (x, y) \in s -> + (x, z) \in s -> + y = z. +Proof. +move => T1 T2. +elim => //=. +case => x y s IH /= x0 y0 z. +move/andP => [Hx Hu]. +rewrite 2!in_cons. +move/orP; case => Hx0; move/orP; case => Hy0. +- move/eqP: Hx0; case. + move/eqP: Hy0; case. + by move =>->->. +- move/eqP: Hx0 Hy0; case. + move =>->-> Hx'. + move/negP: Hx. + case. + apply/mapP. + by exists (x, z). +- move/eqP: Hy0 Hx0; case. + move =>->-> Hx'. + move/negP: Hx. + case. + apply/mapP. + by exists (x, y0). +- move: Hx0 Hy0. + exact: IH. +Qed. + +End extra_seq. + +Section extra_fintype. + +Lemma subset_cover (T: finType) (sccs sccs' : {set {set T}}) : + sccs \subset sccs' -> cover sccs \subset cover sccs'. +Proof. +move=> /subsetP subsccs; apply/subsetP=> x /bigcupP [scc /subsccs]. +by move=> scc' x_in; apply/bigcupP; exists scc. +Qed. + +Lemma disjoint1s (T: finType) (A : pred T) (x : T) : + [disjoint [set x] & A] = (x \notin A). +Proof. +apply/pred0P/idP=> [/(_ x)/=|]; first by rewrite inE eqxx /= => ->. +by move=> xNA y; rewrite !inE; case: eqP => //= ->; apply/negbTE. +Qed. + +Lemma disjoints1 (T: finType) (A : pred T) (x : T) : + [disjoint A & [set x]] = (x \notin A). +Proof. by rewrite disjoint_sym disjoint1s. Qed. + +End extra_fintype. + +Section extra_path. +Variable (V : finType). + +Definition relto (a : pred V) (g : rel V) := [rel x y | (y \in a) && g x y]. +Definition relfrom (a : pred V) (g : rel V) := [rel x y | (x \in a) && g x y]. + +Lemma connect_rev (g : rel V) : + connect g =2 (fun x => connect (fun x => g^~ x) ^~ x). +Proof. +move=> x y; apply/connectP/connectP=> [] [p gp ->]. + exists (rev (belast x p)); rewrite ?rev_path //. + by case: (lastP p) => //= ??; rewrite belast_rcons rev_cons last_rcons. +exists (rev (belast y p)); rewrite ?rev_path //. +by case: (lastP p) => //= ??; rewrite belast_rcons rev_cons last_rcons. +Qed. + +Lemma path_to a g z p : path (relto a g) z p = (path g z p) && (all a p). +Proof. +apply/(pathP z)/idP => [fgi|/andP[/pathP gi] /allP ga]; last first. + by move=> i i_lt /=; rewrite gi ?andbT ?[_ \in _]ga // mem_nth. +rewrite (appP (pathP z) idP) //=; last by move=> i /fgi /= /andP[_ ->]. +by apply/(all_nthP z) => i /fgi /andP []. +Qed. + +Lemma path_from a g z p : + path (relfrom a g) z p = (path g z p) && (all a (belast z p)). +Proof. by rewrite -rev_path path_to all_rev rev_path. Qed. + + +Lemma connect_to (a : pred V) (g : rel V) x z : connect g x z -> + exists y , [/\ (y \in a) ==> (x == y) && (x \in a), + connect g x y & connect (relto a g) y z]. +Proof. +move=> /connectP [p gxp ->]. +pose P := [pred i | let y := nth x (x :: p) i in + [&& connect g x y & connect (relto a g) y (last x p)]]. +have [] := @ex_minnP P. + by exists (size p); rewrite /= nth_last (path_connect gxp) //= mem_last. +move=> i /= /andP[g1 g2] i_min; exists (nth x (x :: p) i); split=> //. +case: i => [|i] //= in g1 g2 i_min *; first by rewrite eqxx /= implybb. +have i_lt : i < size p. + by rewrite i_min // !nth_last /= (path_connect gxp) //= mem_last. +have [<-/=|neq_xpi /=] := altP eqP; first by rewrite implybb. +have := i_min i; rewrite ltnn => /contraNF /(_ isT) <-; apply/implyP=> axpi. +rewrite (connect_trans _ g2) ?andbT //; last first. + by rewrite connect1 //= [_ \in _]axpi /= (pathP x _). +by rewrite (path_connect gxp) //= mem_nth //= ltnW. +Qed. + +Lemma connect_from (a : pred V) (g : rel V) x z : connect g x z -> + exists y, [/\ (y \in a) ==> (z == y) && (z \in a), + connect (relfrom a g) x y & connect g y z]. +Proof. +rewrite connect_rev => cgxz; have [y [ayaz]]//= := connect_to a cgxz. +by exists y; split; rewrite // connect_rev. +Qed. + +Lemma connect1l (g : rel V) x z : + connect g x z -> z != x -> exists2 y, g x y & connect g y z. +Proof. +move=> /connectP [[|y p] //= xyp ->]; first by rewrite eqxx. +by move: xyp=> /andP[]; exists y => //; apply/connectP; exists p. +Qed. + +Lemma connect1r (g : rel V) x z : + connect g x z -> z != x -> exists2 y, connect g x y & g y z. +Proof. +move=> xz zNx; move: xz; rewrite connect_rev => /connect1l. +by rewrite eq_sym => /(_ zNx) [y]; exists y; rewrite // connect_rev. +Qed. + +End extra_path. diff --git a/core/finn.v b/core/finn.v new file mode 100644 index 0000000..3bfaf1f --- /dev/null +++ b/core/finn.v @@ -0,0 +1,130 @@ +Require Import String. + +From mathcomp +Require Import all_ssreflect. + +From chip +Require Import connect acyclic string kosaraju topos close_dfs run change run_seq. + +Section Finn. + +Local Notation A := [eqType of string]. + +Variable n : nat. +Variable m' : nat. + +Local Notation m := m'.+1. + +Hypothesis H_mn : m <= n. + +Local Notation V' := 'I_n. + +Definition lt_m_pred : pred V' := fun v => val v < m. + +Local Notation V := (sig_finType lt_m_pred). + +Variable successors : V -> seq V. + +Variable f' : V' -> A. +Variable f : V -> A. +Variable runnable' : pred V'. + +Definition succs_closure := @rclosure' V. +Definition succs_closureP := rclosure'Pg. +Definition succs_closure_uniq := rclosure'_uniq. + +Definition succs_runnable_impacted := + seq_runnable_impacted f' f successors runnable' succs_closure. +Definition succs_impacted_fresh := + seq_impacted_fresh f' f successors succs_closure. +Definition succs_runnable_impacted_fresh := + seq_runnable_impacted_fresh f' f successors runnable' succs_closure. + +Variable successors' : V' -> seq V'. + +Definition succs_ts := + ts_g'rev_imf_runnable_val f' f successors runnable' succs_closure tseq successors'. + +Variable (g : rel V). + +Hypothesis g_grev : [rel x y | g y x] =2 grel successors. + +Variable (g' : rel V'). + +Hypothesis g'_g'rev : [rel x y | g' y x] =2 grel successors'. + +Lemma succs_impacted_fresh_eq : + impactedV' f' f g =i succs_impacted_fresh. +Proof. +apply: seq_impacted_fresh_eq; eauto. +exact: succs_closureP. +Qed. + +Lemma succs_runnable_impacted_fresh_eq : + runnable_impactedV' f' f g runnable' =i succs_runnable_impacted_fresh. +Proof. +apply: seq_runnable_impacted_fresh_eq; eauto. +exact: succs_closureP. +Qed. + +Lemma succs_impacted_fresh_uniq : uniq succs_impacted_fresh. +Proof. +apply: seq_impacted_fresh_uniq => //. +- exact: succs_closureP. +- move => s Hs. + exact: succs_closure_uniq. +Qed. + +Lemma succs_runnable_impacted_fresh_uniq : + uniq succs_runnable_impacted_fresh. +Proof. +apply: seq_runnable_impacted_fresh_uniq => //. +- exact: succs_closureP. +- move => s Hs. + exact: succs_closure_uniq. +Qed. + +Lemma succs_ts_uniq : + uniq succs_ts. +Proof. +apply: ts_g'rev_imf_runnable_val_uniq. +exact: tseq_uniq. +Qed. + +Lemma in_succs_ts : + forall x, x \in succs_ts -> + runnable' x /\ x \in impactedV' f' f g. +Proof. +apply: in_ts_g'rev_imf_runnable_val; eauto. +exact: succs_closureP. +Qed. + +Lemma succs_ts_in : + forall x, runnable' x -> x \in impactedV' f' f g -> + x \in succs_ts. +Proof. +apply: ts_g'rev_imf_runnable_val_in; eauto. +- exact: succs_closureP. +- exact: tseq_all. +Qed. + +Hypothesis g'_acyclic : acyclic g'. + +Local Notation gV' := [rel x y : V' | insub_g g x y]. + +Hypothesis f_equal_g : + forall v, f v = f' (val v) -> forall v', gV' (val v) v' = g' (val v) v'. + +Lemma succs_tseq_before : forall x y, + x \in impactedV' f' f g -> runnable' x -> + y \in impactedV' f' f g -> runnable' y -> + connect g' x y -> + before succs_ts y x. +Proof. +apply: ts_g'rev_imf_runnable_val_before; eauto. +- exact: succs_closureP. +- exact: tseq_sorted. +- exact: tseq_all. +Qed. + +End Finn. diff --git a/core/finn_set.v b/core/finn_set.v new file mode 100644 index 0000000..61f693f --- /dev/null +++ b/core/finn_set.v @@ -0,0 +1,159 @@ +Require Import OrderedType. +Require Import MSetInterface. +Require Import MSetFacts. +Require Import MSetRBT. +Require Import String. + +From mathcomp +Require Import all_ssreflect. + +From chip +Require Import ordtype connect dfs_set string acyclic kosaraju topos run change run_seq. + +Set Implicit Arguments. +Unset Strict Implicit. +Unset Printing Implicit Defensive. + +Definition subltn (n : nat) (P : pred 'I_n) (v v' : sig_finType P) := + ltn (val v) (val v'). + +Module Type OrdinalsType. +Parameter n : nat. +Parameter m' : nat. +Notation m := m'.+1. +Parameter H_mn : m <= n. +End OrdinalsType. + +Module OrdinalsRunnableImpacted (Import OT : OrdinalsType). +Local Notation A := [eqType of string]. +Local Notation V' := 'I_n. +Definition lt_m_pred : pred V' := fun v => val v < m. +Local Notation V := (sig_finType lt_m_pred). + +Module VFinType <: FinType. +Definition T : finType := V. +End VFinType. + +Module VFinOrdType <: FinOrdType VFinType. +Definition ordT : rel V := fun x y => subltn x y. +Definition irr_ordT : irreflexive ordT := fun x => irr_ltn_nat (val x). +Definition trans_ordT : transitive ordT := + fun x y z => @trans_ltn_nat (val x) (val y) (val z). +Definition total_ordT : forall x y, [|| ordT x y, x == y | ordT y x] := + fun x y => total_ltn_nat (val x) (val y). +End VFinOrdType. + +Module VFinOrdUsualOrderedType <: FinUsualOrderedType VFinType := + FinOrdUsualOrderedType VFinType VFinOrdType. +Module VRBSet <: MSetInterface.S := + MSetRBT.Make VFinOrdUsualOrderedType. +Module VDFS := DFS VFinType VFinOrdUsualOrderedType VRBSet. + +Section Finn. + +Variable successors : V -> seq V. +Variable f' : V' -> A. +Variable f : V -> A. +Variable runnable' : pred V'. + +Definition succs_closure := VDFS.elts_srclosure'. +Definition succs_closureP := VDFS.elts_srclosure'Pg. +Definition succs_closure_uniq := VDFS.elts_srclosure'_uniq. + +Definition succs_runnable_impacted := + seq_runnable_impacted f' f successors runnable' succs_closure. +Definition succs_impacted_fresh := + seq_impacted_fresh f' f successors succs_closure. +Definition succs_runnable_impacted_fresh := + seq_runnable_impacted_fresh f' f successors runnable' succs_closure. + +Variable successors' : V' -> seq V'. + +Definition succs_ts := + ts_g'rev_imf_runnable_val f' f successors runnable' succs_closure tseq successors'. + +Variable g : rel V. + +Hypothesis g_grev : [rel x y | g y x] =2 grel successors. + +Variable (g' : rel V'). + +Hypothesis g'_g'rev : [rel x y | g' y x] =2 grel successors'. + +Lemma succs_impacted_fresh_eq : + impactedV' f' f g =i succs_impacted_fresh. +Proof. +apply: seq_impacted_fresh_eq; eauto. +exact: succs_closureP. +Qed. + +Lemma succs_runnable_impacted_fresh_eq : + runnable_impactedV' f' f g runnable' =i succs_runnable_impacted_fresh. +Proof. +apply: seq_runnable_impacted_fresh_eq; eauto. +exact: succs_closureP. +Qed. + +Lemma succs_impacted_fresh_uniq : uniq succs_impacted_fresh. +Proof. +apply: seq_impacted_fresh_uniq => //. +- exact: succs_closureP. +- move => gs s Hs. + exact: succs_closure_uniq. +Qed. + +Lemma succs_runnable_impacted_fresh_uniq : + uniq succs_runnable_impacted_fresh. +Proof. +apply: seq_runnable_impacted_fresh_uniq => //. +- exact: succs_closureP. +- move => gs s Hs. + exact: succs_closure_uniq. +Qed. + +Lemma succs_ts_uniq : + uniq succs_ts. +Proof. +apply: ts_g'rev_imf_runnable_val_uniq. +exact: tseq_uniq. +Qed. + +Lemma in_succs_ts : + forall x, x \in succs_ts -> + runnable' x /\ x \in impactedV' f' f g. +Proof. +apply: in_ts_g'rev_imf_runnable_val; eauto. +exact: succs_closureP. +Qed. + +Lemma succs_ts_in : + forall x, runnable' x -> x \in impactedV' f' f g -> + x \in succs_ts. +Proof. +apply: ts_g'rev_imf_runnable_val_in; eauto. +- exact: succs_closureP. +- exact: tseq_all. +Qed. + +Hypothesis g'_acyclic : acyclic g'. + +Local Notation gV' := [rel x y : V' | insub_g g x y]. + +Hypothesis f_equal_g : + forall v, f v = f' (val v) -> forall v', gV' (val v) v' = g' (val v) v'. + +Lemma succs_tseq_before : forall x y, + x \in impactedV' f' f g -> runnable' x -> + y \in impactedV' f' f g -> runnable' y -> + connect g' x y -> + before succs_ts y x. +Proof. +apply: ts_g'rev_imf_runnable_val_before; eauto. +- exact: succs_closureP. +- exact: tseq_sorted. +- exact: tseq_all. +Qed. + +End Finn. + +End OrdinalsRunnableImpacted. diff --git a/core/hierarchical.v b/core/hierarchical.v new file mode 100644 index 0000000..3e51c95 --- /dev/null +++ b/core/hierarchical.v @@ -0,0 +1,491 @@ +From mathcomp +Require Import all_ssreflect. + +From chip +Require Import extra connect acyclic closure run change. + +Set Implicit Arguments. +Unset Strict Implicit. +Unset Printing Implicit Defensive. + +Section Hierarchy. + +Variable (A_top : eqType) (A_bot : eqType). + +Variable (U' : finType) (V' : finType). + +Variable (f'_top : U' -> A_top) (f'_bot : V' -> A_bot). + +Variable (P_top : pred U') (P_bot : pred V'). + +Local Notation U := (sig_finType P_top). + +Local Notation V := (sig_finType P_bot). + +Variable (g_top : rel U) (g_bot : rel V). + +Local Notation g_top_rev := [rel x y | g_top y x]. + +Local Notation g_bot_rev := [rel x y | g_bot y x]. + +Variable (f_top : U -> A_top) (f_bot : V -> A_bot). + +Variable (runnable : pred V'). + +Variable (R : eqType). + +Variable (run : V' -> R). + +Variables (p : U -> {set V}) (p' : U' -> {set V'}). + +Hypothesis p_neq : forall (u u' : U), u <> u' -> p u <> p u'. + +Hypothesis p'_neq : forall (u u' : U'), u <> u' -> p' u <> p' u'. + +Hypothesis p_partition : partition (\bigcup_( u | u \in U ) [set p u]) [set: V]. + +Hypothesis p'_partition : partition (\bigcup_( u | u \in U' ) [set p' u]) [set: V']. + +Hypothesis g_bot_top : forall (v v' : V) (u u' : U), + u <> u' -> g_bot v v' -> v \in p u -> v' \in p u' -> g_top u u'. + +Hypothesis f_top_partition : forall (u : U), + f_top u = f'_top (val u) -> [set val v | v in p u] = p' (val u). + +Hypothesis f_top_bot : forall (u : U), + f_top u = f'_top (val u) -> forall (v : V), v \in p u -> f_bot v = f'_bot (val v). + +Lemma exist_pu_for_v : forall v, exists u, v \in p u. +Proof. +move => v. +have Hp := p_partition. +move/andP: Hp => [Hp Hp']. +rewrite /cover in Hp. +rewrite /cover in Hp. +have Hvi: v \in [set: V] by []. +move/eqP: Hp => Hp. +rewrite -Hp in Hvi. +move/bigcupP: Hvi => [vs Hc] Hvvs. +move/bigcupP: Hc => [u Hu] Huvs. +move/set1P: Huvs => Huvs. +exists u. +by rewrite -Huvs. +Qed. + +Lemma exist_list_pu_for_seq_v : forall (vs : seq V), + exists vus, unzip1 vus = vs /\ forall v u, (v,u) \in vus -> v \in p u. +elim; first by exists [::]; split. +move => v l [vus [Hvu Hp]]. +have [u Hu] := exist_pu_for_v v. +exists ((v,u) :: vus). +split; first by rewrite /= Hvu. +move => v0 u0. +rewrite in_cons. +move/orP. +case; first by move/eqP; case =>->->. +by move/Hp. +Qed. + +Fixpoint adjundup (u : U) (s : seq U) := + if s is x :: s' then + if u == x then adjundup u s' + else x :: adjundup x s' + else [::]. + +Lemma exist_p'u_for_v : forall v, exists u, v \in p' u. +Proof. +move => v. +have Hp := p'_partition. +move/andP: Hp => [Hp Hp']. +rewrite /cover in Hp. +rewrite /cover in Hp. +have Hvi: v \in [set: V'] by []. +move/eqP: Hp => Hp. +rewrite -Hp in Hvi. +move/bigcupP: Hvi => [vs Hc] Hvvs. +move/bigcupP: Hc => [u Hu] Huvs. +move/set1P: Huvs => Huvs. +exists u. +by rewrite -Huvs. +Qed. + +Definition impacted_U : {set U} := impacted g_top^-1 (modifiedV f'_top f_top). + +Definition pimpacted_V : {set V} := \bigcup_( u | u \in impacted_U ) (p u). + +Lemma connect_rev_v_u : forall x v u u', + x \in p u -> + v \in p u' -> + connect g_bot_rev v x -> + connect g_top_rev u' u. +Proof. +move => x v u u' Hx Hv. +move/connect_rev. +rewrite /=. +have ->: connect [rel x0 y | g_bot x0 y] x v = connect g_bot x v by []. +move => Hc. +have ->: g_top_rev = [rel x y | g_top y x] by []. +apply/connect_rev. +move/connectP: Hc => [vs Hvs] Hl. +have [uvs [Huz Hin]] := exist_list_pu_for_seq_v vs. +move: Hvs Hl. +rewrite -Huz {Huz vs} => Hp Hl. +apply/connectP. +exists (adjundup u (unzip2 uvs)). +- clear Hl Hv u' v. + elim: uvs u x Hx Hin Hp => //. + case => v1 u1 uvs IH u x Hx. + rewrite [unzip1 _]/=. + rewrite [unzip2 _]/=. + move => Hin. + rewrite /=. + move/andP => [Hg Hp]. + case: ifP. + * move/eqP => Hu. + move: Hu Hin =><- {u1}. + move => Hin. + move: Hp. + apply: IH. + + apply: Hin. + by apply/orP; left. + + move => v u0 Hin'. + apply: Hin. + apply/orP. + by right. + * rewrite /=. + move/negP/negP/eqP => Hu. + apply/andP. + have Hv1: v1 \in p u1. + apply: Hin. + apply/orP. + by left. + split; first by eapply g_bot_top; eauto. + have Hin': forall (v0 : V) (u0 : U), (v0, u0) \in uvs -> v0 \in p u0. + move => v0 u0 Hin'. + apply: Hin. + rewrite inE. + apply/orP. + by right. + exact: IH _ _ Hv1 Hin' Hp. +- elim: uvs u u' x v Hx Hv Hin Hp Hl => //. + * move => u u' x v Hx Hv. + rewrite [unzip1 _]/=. + rewrite [unzip2 _]/=. + rewrite [adjundup _ _]/=. + rewrite 2![last _ _]/=. + move => Hin Ht Hvx. + move: Hvx Hv =>-> {v Ht Hin}. + move => Hp. + case Hu: (u' == u); first by move/eqP: Hu. + move/negP/negP/eqP: Hu => Hu. + have Hneq := p_neq Hu. + have Hpp := p_partition. + move/andP: Hpp => [Hc Hpp]. + move/andP: Hpp => [Htr H0]. + move/trivIsetP: Htr => Htr. + have Hpu: p u \in \bigcup_(u1 in U) [set p u1]. + apply/bigcupP. + exists u; first by []. + by rewrite in_set1. + have Hpu': p u' \in \bigcup_(u1 in U) [set p u1]. + apply/bigcupP. + exists u'; first by []. + by rewrite in_set1. + have Hneq': p u != p u'. + apply/negP/negP/eqP => Hpp. + by case: Hneq. + have Hpp := Htr _ _ Hpu Hpu' Hneq'. + move/setDidPl: Hpp => Hpp. + move: Hx. + rewrite -Hpp. + move/setDP => [Hx Hx']. + move/negP: Hx'. + by case. + * case => v1 u1 uvs IH u u' x v Hx Hv. + rewrite [unzip1 _]/=. + rewrite [unzip2 _]/=. + rewrite [adjundup _ _]/=. + move => Hin. + move/andP => [Hg Hp]. + move: Hp. + rewrite -/(path _ _) => Hp. + rewrite [last _ _]/=. + move => Hl. + case: ifP => Hu. + + move/eqP: Hu => Hu. + move: Hx. + rewrite Hu {Hu u} => Hu. + have Hv1: v1 \in p u1. + apply: Hin. + rewrite inE. + apply/orP. + by left. + have Hin': forall (v0 : V) (u0 : U), (v0, u0) \in uvs -> v0 \in p u0. + move => v0 u0 Hin'. + apply: Hin. + rewrite inE. + apply/orP. + by right. + exact: IH u1 u' v1 v Hv1 Hv Hin' Hp Hl. + + rewrite /=. + move/negP/negP/eqP: Hu => Hu. + have Hv1: v1 \in p u1. + apply: Hin. + rewrite inE. + apply/orP. + by left. + have Hin': forall (v0 : V) (u0 : U), (v0, u0) \in uvs -> v0 \in p u0. + move => v0 u0 Hin'. + apply: Hin. + rewrite inE. + apply/orP. + by right. + exact: IH u1 u' v1 v Hv1 Hv Hin' Hp Hl. +Qed. + +Lemma neq_connect_in_pimpacted_V : forall x v, + f_bot v <> f'_bot (val v) -> connect g_bot_rev v x -> x \in pimpacted_V. +Proof. +move => x v Hv Hc. +apply/bigcupP. +have [u Hu] := exist_pu_for_v x. +exists u; last by []. +have Hp := p_partition. +move/andP: Hp => [Hcv Hp']. +move/eqP: Hcv => Hcv. +apply/impactedVP. +have Hvi: v \in [set: V] by []. +rewrite -Hcv in Hvi. +move/bigcupP: Hvi => [xs Hc'] Hvvs. +move/bigcupP: Hc' => [u' Hu'] Huvs. +move/set1P: Huvs => Huvs. +move: Huvs Hvvs =>->. +move => Hvx. +exists u'. +- rewrite inE. + apply/negP. + move => Hf. + move/eqP: Hf. + move/f_top_bot => Hf. + case: Hv. + exact: Hf. +- move: Hc. + exact: connect_rev_v_u. +Qed. + +Lemma impactedV_in_pimpacted_V : + forall x, x \in impacted g_bot^-1 (modifiedV f'_bot f_bot) -> + x \in pimpacted_V. +Proof. +move => x. +move/impactedVP. +case => v Hm Hc. +move/not_modifiedP: Hm. +move => Hf. +move/negP/eqP: Hf => Hf. +move: Hf Hc. +exact: neq_connect_in_pimpacted_V. +Qed. + +Definition impacted_U' : {set U'} := impactedV' f'_top f_top g_top. + +Definition pimpacted_V' : {set V'} := \bigcup_( u | u \in impacted_U' ) (p' u). + +Lemma pimpacted_V'_fresh : + forall v, v \in freshV' P_bot -> v \in pimpacted_V'. +Proof. +move => v'. +move/freshV'P => Hv. +apply/bigcupP. +have [u' Hu] := exist_p'u_for_v v'. +exists u'; last by []. +case Hfr: (u' \in freshV' P_top). +- move/negP/negP: Hfr => Hfr. + apply/impactedV'P. + right. + split => //. + apply/negP. + move => Hu'. + move/imsetP: Hu' => [u Hi] Hu'. + move/freshV'P: Hfr. + move => Hvu. + have Hvu' := Hvu u. + case/negP: Hvu'. + by apply/eqP. +- move/negP/negP: Hfr => Hfr. + apply/impactedV'P. + left. + split => //. + move/negP: Hfr. + rewrite -sub_freshV'. + move/negP/negPn. + have H_sp := (insubP [subType of U] u'). + destruct H_sp; last by case. + move => Hs. + apply/imsetP. + exists u; last by []. + apply/impactedVP. + exists u; last by []. + apply/not_modifiedP. + move/eqP. + move/f_top_partition => Hvs. + rewrite e in Hvs. + move: Hu. + rewrite -Hvs. + move/imsetP => [v Hi] Hv'. + have Hvv' := Hv v. + move/negP: Hvv'. + case. + by apply/eqP. +Qed. + +Lemma pimpacted_V'_impactedVV' : + forall v, v \in impactedVV' g_bot (modifiedV f'_bot f_bot) -> + v \in pimpacted_V'. +Proof. +move => v'. +move/imsetP => [v Hi] Hv. +have Hi' := impactedV_in_pimpacted_V Hi. +move/bigcupP: Hi' => [u Hu] Huv. +apply/bigcupP. +have [u' Hu'] := exist_p'u_for_v v'. +exists u'; last by []. +case Hfr: (u' \in freshV' P_top). +- move/negP/negP: Hfr => Hfr. + apply/impactedV'P. + right; split => //. + apply/negP => Hui. + move/freshV'P: Hfr => Hfr. + move/imsetP: Hui => [u'' Hu''] Hvu. + have Hfr' := Hfr u''. + move/negP: Hfr'. + case. + by apply/eqP. +- move/negP/negP: Hfr. + move/negP. + rewrite -sub_freshV'. + move/negP/negPn. + have H_sp := (insubP [subType of U] u'). + destruct H_sp; last by case. + move => Hs. + case Hu0: (u0 == u). + * move: e. + move/eqP: Hu0 =>->. + move => Hvu. + rewrite /impacted_U' /impactedV'. + apply/setUP. + left. + apply/imsetP. + by exists u. + * move/negP/negP/eqP: Hu0 => Hu0. + case Hf: (f_top u0 == f'_top (val u0)). + + move/eqP: Hf. + move/f_top_partition => Hst. + move: Hst. + rewrite e. + have H_neq: val u <> u'. + rewrite -e => Huu. + apply val_inj in Huu. + by rewrite Huu in Hu0. + move => Hp. + rewrite -Hp in Hu'. + move/imsetP: Hu' => [x Hvp] Hvx. + rewrite Hvx in Hv. + apply val_inj in Hv. + rewrite Hv in Hvp. + have Hpp := p_partition. + move/andP: Hpp => [Hpp Hpp']. + move/andP: Hpp' => [Hpp' Hpp'']. + move/trivIsetP: Hpp'. + have Hpu: p u \in \bigcup_(u1 in U) [set p u1]. + apply/bigcupP. + exists u; first by []. + by rewrite in_set1. + have Hpu0: p u0 \in \bigcup_(u1 in U) [set p u1]. + apply/bigcupP. + exists u0; first by []. + by rewrite in_set1. + move => Hpp'. + have H_p := Hpp' _ _ Hpu Hpu0. + case Hpe: (p u == p u0). + move/eqP: Hpe => Hpe. + apply sym_eq in Hpe. + contradict Hpe. + exact: p_neq. + move/negP/negP: Hpe. + move/H_p. + move/setDidPl => H_pp. + rewrite -H_pp /= in Huv. + move/setDP: Huv => [Hvpp Hvvp]. + move/negP: Hvvp. + by case. + + move/negP/negP/eqP: Hf => Hf. + rewrite /impacted_U'. + apply/setUP. + left. + apply/imsetP. + exists u0; last by []. + apply/impactedVP. + exists u0; last by []. + apply/not_modifiedP. + by apply/negP/eqP. +Qed. + +Lemma pimpacted_V'_impactedV' : + forall v, v \in impactedV' f'_bot f_bot g_bot -> v \in pimpacted_V'. +Proof. +move => v. +move/impactedV'P. +case; move => [Ha Hb]. +- exact: pimpacted_V'_impactedVV'. +- exact: pimpacted_V'_fresh. +Qed. + +Definition runnable_pimpacted_V' := + [set v in pimpacted_V' | runnable v]. + +Definition runnable_pimpacted_fresh : seq V' := + enum runnable_pimpacted_V'. + +Definition run_pimpacted_V'_cert := + [seq (v, run v) | v <- runnable_pimpacted_fresh]. + +Lemma run_pimpacted_V'_certP v r : + reflect + (runnable v /\ run v == r /\ v \in pimpacted_V') + ((v,r) \in run_pimpacted_V'_cert). +Proof. +apply: (iffP idP). +- move/mapP => [v' Hv']. + move: Hv'. + rewrite mem_enum in_set. + move/andP => [Hp Hc]. + by case =>->->. +- move => [Hc [Hcr Hv]]. + move/eqP: Hcr =><-. + apply/mapP. + exists v; last by []. + rewrite mem_enum in_set. + by apply/andP; split. +Qed. + +Lemma run_pimpacted_V'_cert_uniq : + uniq [seq vr.1 | vr <- run_pimpacted_V'_cert]. +Proof. +rewrite map_inj_in_uniq. +- rewrite map_inj_uniq; first by rewrite enum_uniq. + by move => x y; case. +- case => v1 r1. + case => v2 r2. + move => H1 H2 /= Heq. + move: Heq H1 H2 =>-<-. + move/mapP => [v1' Hv1' Hc1]. + rewrite mem_enum in Hv1'. + case: Hc1 =><- Hr1. + move/mapP => [v2' Hv2' Hc2]. + rewrite mem_enum in Hv2'. + case: Hc2 =><- Hr2. + by rewrite Hr1 Hr2. +Qed. + +End Hierarchy. diff --git a/core/hierarchical_correct.v b/core/hierarchical_correct.v new file mode 100644 index 0000000..d3e1157 --- /dev/null +++ b/core/hierarchical_correct.v @@ -0,0 +1,318 @@ +From mathcomp +Require Import all_ssreflect. + +From chip +Require Import extra connect acyclic closure run change hierarchical. + +Set Implicit Arguments. +Unset Strict Implicit. +Unset Printing Implicit Defensive. + +Section ChangedHierarchical. + +Variables (A_top : eqType) (A_bot : eqType). + +Variables (U' : finType) (V' : finType). + +Variables (f'_top : U' -> A_top) (f'_bot : V' -> A_bot). + +Variables (P_top : pred U') (P_bot : pred V'). + +Local Notation U := (sig_finType P_top). + +Local Notation V := (sig_finType P_bot). + +Variables (g'_top : rel U') (g'_bot : rel V'). + +Local Notation g'_top_rev := [rel x y | g'_top y x]. + +Local Notation g'_bot_rev := [rel x y | g'_bot y x]. + +Variables (f_top : U -> A_top) (f_bot : V -> A_bot). + +Variables (g_top : rel U) (g_bot : rel V). + +Local Notation g_top_rev := [rel x y | g_top y x]. + +Local Notation g_bot_rev := [rel x y | g_bot y x]. + +Variables (runnable' : pred V') (runnable : pred V). + +Variable R : eqType. + +Variables (run : V -> R) (run' : V' -> R). + +Variables (p : U -> {set V}) (p' : U' -> {set V'}). + +Hypothesis p_neq : forall (u u' : U), u <> u' -> p u <> p u'. + +Hypothesis p'_neq : forall (u u' : U'), u <> u' -> p' u <> p' u'. + +Hypothesis p_partition : partition (\bigcup_( u | u \in U ) [set p u]) [set: V]. + +Hypothesis p'_partition : partition (\bigcup_( u | u \in U' ) [set p' u]) [set: V']. + +Hypothesis g_bot_top : forall (v v' : V) (u u' : U), + u <> u' -> g_bot v v' -> v \in p u -> v' \in p u' -> g_top u u'. + +Hypothesis f_top_partition : forall (u : U), + f_top u = f'_top (val u) -> [set val v | v in p u] = p' (val u). + +Hypothesis f_top_bot : forall (u : U), + f_top u = f'_top (val u) -> forall (v : V), v \in p u -> f_bot v = f'_bot (val v). + +Local Notation insub_g_top x y := (insub_g g_top x y). + +Local Notation g_top_U' := [rel x y : U' | insub_g_top x y]. + +Local Notation g_top_U'_rev := [rel x y | g_top_U' y x]. + +Local Notation insub_g_bot x y := (insub_g g_bot x y). + +Local Notation g_bot_V' := [rel x y : V' | insub_g_bot x y]. + +Local Notation g_bot_V'_rev := [rel x y | g_bot_V' y x]. + +Hypothesis f_top_equal_g_top : + forall u, f_top u = f'_top (val u) -> forall u', g_top_U' (val u) u' = g'_top (val u) u'. + +Hypothesis f_bot_equal_g_bot : + forall v, f_bot v = f'_bot (val v) -> forall v', g_bot_V' (val v) v' = g'_bot (val v) v'. + +Hypothesis runnable_bot : + forall v, f_bot v = f'_bot (val v) -> runnable v = runnable' (val v). + +Hypothesis run_bot : + forall v, runnable v -> runnable' (val v) -> + (forall v', connect g_bot_V' (val v) v' = connect g'_bot (val v) v') -> + (forall v', connect g_bot_V' (val v) (val v') -> f_bot v' = f'_bot (val v')) -> + run v = run' (val v). + +Variable V_result_cert : seq (V * R). + +Hypothesis V_result_certP : + forall v r, reflect (runnable v /\ run v = r) ((v,r) \in V_result_cert). + +Hypothesis V_result_cert_uniq : uniq [seq vr.1 | vr <- V_result_cert]. + +Definition V'_result_filter_cert_p := + [seq (val vr.1, vr.2) | vr <- V_result_cert & val vr.1 \notin pimpacted_V' f'_top g_top f_top p']. + +Definition run_all_cert_p := + run_pimpacted_V'_cert f'_top g_top f_top runnable' run' p' ++ V'_result_filter_cert_p. + +Definition run_all_cert_V'_p := + [seq vr.1 | vr <- run_all_cert_p]. + +Lemma run_all_cert_complete_p : + forall (v : V'), runnable' v -> v \in run_all_cert_V'_p. +Proof. +move => v Hc. +have H_sp := (insubP [subType of V] v). +destruct H_sp. +- have Hv: v \notin freshV' P_bot. + apply/negP. + move => Hv. + move/freshV'P: Hv => Hv. + move/negP: (Hv u) => Hv'. + case: Hv'. + by apply/eqP. + apply/mapP. + case Hv': (v \in pimpacted_V' f'_top g_top f_top p'). + * move/idP: Hv'. + exists (v, run' v); last by []. + rewrite mem_cat. + apply/orP. + left. + by apply/run_pimpacted_V'_certP. + * move/negP/negP: Hv'. + exists (v, run u); last by []. + rewrite mem_cat. + apply/orP. + right. + apply/mapP. + exists (u, run u); last by rewrite /= e. + rewrite mem_filter. + apply/andP; split; first by rewrite e. + apply/V_result_certP. + split => //. + suff H_suff: f_bot u = f'_bot (val u) by rewrite runnable_bot //= e. + apply/eqP. + apply/not_modifiedP. + apply/negP. + move => Hu. + move/negPn: Hv'. + case. + apply: pimpacted_V'_impactedV'; eauto. + apply/impactedV'P. + left. + split => //. + apply/imsetP. + exists u; last by []. + apply/impactedVP. + by exists u. +- have Hv: v \in freshV' P_bot. + rewrite -sub_freshV'. + move/negP: i => Hp. + apply/negP => Hs. + case: Hp. + have H_sp := (insubP [subType of V] v). + move: Hs. + by destruct H_sp. + apply/mapP. + exists (v, run' v) => //. + rewrite mem_cat. + apply/orP. + left. + apply/run_pimpacted_V'_certP. + split => //; split => //. + move: Hv. + by apply: pimpacted_V'_fresh; eauto. +Qed. + +Lemma run_all_cert_sound_p : + forall (v : V') (r : R), (v,r) \in run_all_cert_p -> + runnable' v /\ run' v = r. +Proof. +move => v r. +rewrite mem_cat. +move/orP; case. +- move/mapP => [v' Hc]. + case =>->->. + split => //. + move: Hc. + rewrite mem_enum in_set. + by move/andP => [Hp Hc]. +- move/mapP. + case; case => v' r' Hvr Hvr'. + move: Hvr' Hvr. + case =>->->. + rewrite mem_filter. + move/andP => /= [Hp Hv]. + have Hv': val v' \notin impactedV' f'_bot f_bot g_bot. + apply/negP => Hv'. + move/negP: Hp. + case. + by apply: pimpacted_V'_impactedV'; eauto. + have Hf: val v' \notin freshV' P_bot. + apply/negP => Hf. + move/negP: Hp. + case. + by apply: pimpacted_V'_fresh; eauto. + apply: run_all_cert_sound; eauto. + rewrite mem_cat. + apply/orP. + right. + apply/mapP. + exists (v', r'); last by []. + rewrite mem_filter. + apply/andP; split => //. + rewrite /=. + apply/negP => Hi. + move/impactedV'P: Hv'. + case. + by left. +Qed. + +Lemma run_all_cert_V'_uniq_p : uniq run_all_cert_V'_p. +Proof. +rewrite map_inj_in_uniq. +- rewrite cat_uniq. + apply/andP. + split; last (apply/andP; split). + * have Hu := run_pimpacted_V'_cert_uniq f'_top g_top f_top runnable' run' p'. + move: Hu. + exact: map_uniq. + * apply/negP. + case. + move/hasP => [vr Hvr]. + move/mapP: Hvr => [vr' Hvr']. + case: vr' Hvr' => v' r'. + rewrite mem_filter. + case: vr => /= v r. + move/andP => [Hv Hvr]. + case => Hv'; move =>-> {r}. + move/mapP => [v0 Hv0]. + case => Hvv0 Hr'. + rewrite mem_enum -Hvv0 in Hv0. + move/negP: Hv. + case. + rewrite -Hv'. + move: Hv0. + rewrite in_set. + by move/andP => [Hp Hv0]. + * have Hm := map_uniq V_result_cert_uniq. + rewrite map_inj_in_uniq; first by rewrite filter_uniq. + case => v1 r1. + case => v2 r2. + rewrite /= => Hv1 Hv2. + case. + by move/val_inj =><-<-. +- case => v1 r1. + case => v2 r2. + rewrite /= 2!mem_cat. + move/orP. + case => Hv1; move/orP. + * case => Hv2 Hv. + + move: Hv Hv1 Hv2 =><-. + move/mapP => [v1' Hv1' Hc1]. + rewrite mem_enum in Hv1'. + case: Hc1 =><- Hr1. + move/mapP => [v2' Hv2' Hc2]. + rewrite mem_enum in Hv2'. + case: Hc2 =><- Hr2. + by rewrite Hr1 Hr2. + + move: Hv Hv1 Hv2 =><-. + move/mapP => [v1' Hv1' Hc1]. + case: Hc1 Hv1' =><-. + rewrite mem_enum => Hc. + rewrite in_set. + move/andP => [Hi H'c]. + move/mapP => [v' Hv' Heq]. + case: v' Hv' Heq => v2' r2'. + rewrite mem_filter. + move/andP => [Hv2' HV]. + case => Hv1 Hr2. + rewrite /= in Hv2'. + move/negP: Hv2'. + case. + by rewrite -Hv1. + * case => Hv2 Hv. + + move: Hv Hv1 Hv2. + move =><-. + move/mapP => [v1' Hv1' Hc1]. + case: v1' Hc1 Hv1' => v1' r1'. + case =>->->. + rewrite mem_filter. + move/andP => [Hi H'c]. + move/mapP => [v' Hv' Heq]. + case: Heq Hv'. + rewrite mem_enum. + move =><-->. + move => Hc. + move/negP: Hi. + case. + rewrite in_set in Hc. + by move/andP: Hc => [Hi Hc]. + + move: Hv1 Hv2. + move/mapP. + case; case => v1' r1'. + rewrite mem_filter. + move/andP => [Hi Hv']. + case. + move => H_eq_v H_eq_r. + move/mapP. + case; case => v2' r2'. + rewrite mem_filter. + move/andP => [Hi' Hv'']. + case => H_eq_v' H_eq_r'. + rewrite Hv in H_eq_v, H_eq_v'. + rewrite H_eq_v in H_eq_v'. + apply val_inj in H_eq_v'. + rewrite -H_eq_v' in Hv''. + rewrite Hv H_eq_r H_eq_r'. + have Hu := uniq_prod_eq V_result_cert_uniq Hv' Hv''. + by rewrite -Hu. +Qed. + +End ChangedHierarchical. diff --git a/core/hierarchical_sub.v b/core/hierarchical_sub.v new file mode 100644 index 0000000..ee630d4 --- /dev/null +++ b/core/hierarchical_sub.v @@ -0,0 +1,233 @@ +From mathcomp +Require Import all_ssreflect. + +From chip +Require Import extra connect acyclic closure run change hierarchical. + +Set Implicit Arguments. +Unset Strict Implicit. +Unset Printing Implicit Defensive. + +Section HierarchicalSub. + +Variable (A_top : eqType) (A_bot : eqType). + +Variable (U' : finType) (V' : finType). + +Variable (f'_top : U' -> A_top) (f'_bot : V' -> A_bot). + +Variable (P_top : pred U') (P_bot : pred V'). + +Local Notation U := (sig_finType P_top). + +Local Notation V := (sig_finType P_bot). + +Variable (g_top : rel U) (g_bot : rel V). + +Local Notation g_top_rev := [rel x y | g_top y x]. + +Local Notation g_bot_rev := [rel x y | g_bot y x]. + +Variable (f_top : U -> A_top) (f_bot : V -> A_bot). + +Variable (runnable : pred V'). + +Variable (R : eqType). + +Variable (run : V' -> R). + +Variables (p : U -> {set V}) (p' : U' -> {set V'}). + +Hypothesis p_neq : forall (u u' : U), u <> u' -> p u <> p u'. + +Hypothesis p'_neq : forall (u u' : U'), u <> u' -> p' u <> p' u'. + +Hypothesis p_partition : partition (\bigcup_( u | u \in U ) [set p u]) [set: V]. + +Hypothesis p'_partition : partition (\bigcup_( u | u \in U' ) [set p' u]) [set: V']. + +Hypothesis g_bot_top : forall (v v' : V) (u u' : U), + u <> u' -> g_bot v v' -> v \in p u -> v' \in p u' -> g_top u u'. + +Hypothesis f_top_partition : forall (u : U), + f_top u = f'_top (val u) -> [set val v | v in p u] = p' (val u). + +Hypothesis f_top_bot : forall (u : U), + f_top u = f'_top (val u) -> forall (v : V), v \in p u -> f_bot v = f'_bot (val v). + +Definition pimpacted_sub_V := pimpacted_V f'_top g_top f_top p. + +Definition P_V_sub v := v \in pimpacted_sub_V. + +Local Notation V_sub := (sig_finType P_V_sub). + +Local Notation g_bot_sub := [rel x y : V_sub | g_bot (val x) (val y)]. + +Definition modifiedV_sub := [set v : V_sub | val v \in modifiedV f'_bot f_bot]. + +Definition impactedV_sub := impacted g_bot_sub^-1 modifiedV_sub. + +Definition impactedVV'_sub := [set val (val v) | v in impactedV_sub]. + +Definition impactedV'_sub := impactedVV'_sub :|: freshV' P_bot. + +Definition impacted_fresh_sub : seq V' := enum impactedV'_sub. + +Lemma impactedV_sub_impactedV_eq : forall v, + v \in impactedV_sub -> + val v \in impacted g_bot^-1 (modifiedV f'_bot f_bot). +Proof. +move => v. +rewrite /impactedV_sub. +move/impactedP. +move => [v0 [Hm Hc]]. +move: Hc. +move/connect_rev. +rewrite /= => Hc. +apply/impactedP. +exists (val v0); first by move: Hm; rewrite in_set. +apply connect_rev. +rewrite in_set in Hm. +exact: gsub_connect. +Qed. + +Lemma impactedV_impactedV_sub_eq : forall (v : V_sub), + val v \in impacted g_bot^-1 (modifiedV f'_bot f_bot) -> + v \in impactedV_sub. +Proof. +move => v. +move/impactedVP => [v0 Hv0] Hc. +have H_neq := Hv0. +move: H_neq. +rewrite in_set. +move/negP/negP/eqP => Hneq. +have H_sp := (insubP [subType of V_sub] v0). +destruct H_sp; last by move/negP: i; case; apply/(neq_connect_in_pimpacted_V p_neq p_partition g_bot_top f_top_bot Hneq). +move: Hc. +move/connect_rev. +rewrite /= => Hc. +apply/impactedVP. +exists u; first by rewrite in_set; rewrite e. +apply/connect_rev. +rewrite /=. +move: Hc. +have ->: rel_of_simpl_rel [rel x y | g_bot x y] = g_bot by []. +rewrite -e. +rewrite -e in Hneq. +move/connectP => [vs Hp] Hl. +have Hcp: forall v', v' \in vs -> connect g_bot_rev (val u) v'. + elim: vs v Hp Hl => //. + move => v' vs IH v Hp Hl. + move/andP: Hp => [Hg Hp]. + rewrite -/(path _ _) in Hp. + rewrite /= in Hl. + have Hcp : connect g_bot_rev (val u) v'. + apply/connect_rev. + apply/connectP. + by exists vs. + have Hpi := neq_connect_in_pimpacted_V p_neq p_partition g_bot_top f_top_bot Hneq Hcp. + have H_sp := (insubP [subType of V_sub] v'). + destruct H_sp; last by move/negP: i0; case. + rewrite -e0 in Hp,Hl. + have IH' := IH _ Hp Hl. + move => v1. + rewrite in_cons. + move/orP; case; last by apply: IH'. + by move/eqP=>->. +have H_p: forall v', v' \in vs -> v' \in pimpacted_V f'_top g_top f_top p. + move => v' Hv'. + apply/(neq_connect_in_pimpacted_V p_neq p_partition g_bot_top f_top_bot Hneq). + exact: Hcp. +apply/connectP. +exists (pmap insub vs). +- clear Hneq Hv0 i e Hcp Hl u v0. + move: v Hp H_p. + elim: vs => //. + move => v vs IH v0. + move/andP => [Hg Hp]. + rewrite -/(path _ _) in Hp. + move => Hp'. + rewrite /= /oapp. + have Hpp': forall v' : V, v' \in vs -> v' \in pimpacted_V f'_top g_top f_top p. + move => v' Hv'. + apply: Hp'. + rewrite in_cons. + apply/orP. + by right. + have Hpi : v \in pimpacted_V f'_top g_top f_top p. + apply: Hp'. + rewrite in_cons. + by apply/orP; left. + have H_sp := (insubP [subType of V_sub] v). + move: H_sp. + case; last by move/negP; case. + move => u HPu Hu. + rewrite /=. + apply/andP. + rewrite Hu. + split => //. + apply: IH => //. + by rewrite Hu. +- clear Hp Hcp Hneq. + move: v Hl H_p. + elim: vs; first by move => /= v; move/val_inj. + move => v vs IH v1 Hl Hp. + rewrite /= in Hl. + have Hpv : v \in pimpacted_V f'_top g_top f_top p. + apply: Hp. + rewrite in_cons. + apply/orP. + by left. + rewrite /= /oapp. + have Hp': forall v' : V, v' \in vs -> v' \in pimpacted_V f'_top g_top f_top p. + move => v' Hv'. + apply: Hp. + rewrite in_cons. + apply/orP. + by right. + have H_sp := (insubP [subType of V_sub] v). + move: H_sp. + case; last by move/negP; case. + move => u0 HPu0 Hu0. + rewrite last_cons. + apply: IH => //. + by rewrite Hu0. +Qed. + +Lemma impactedVV'_sub_eq : + impactedVV'_sub = impactedVV' g_bot (modifiedV f'_bot f_bot). +Proof. +apply/eqP; rewrite eqEsubset; apply/andP; split. +- apply/subsetP => x. + move/imsetP => [x1 Hx] Hx1. + apply/imsetP. + exists (val x1); last by []. + exact: impactedV_sub_impactedV_eq. +- apply/subsetP => x. + move/imsetP => [x1 Hx] Hx1. + rewrite Hx1. + have Hi := Hx. + move: Hx. + move/(impactedV_in_pimpacted_V p_neq p_partition g_bot_top f_top_bot) => Hp. + have H_sp := (insubP [subType of V_sub] x1). + destruct H_sp; last by move/negP: i. + apply/imsetP. + exists u; last by rewrite e. + rewrite -e in Hi. + exact: impactedV_impactedV_sub_eq. +Qed. + +Lemma impactedV'_sub_eq : + impactedV'_sub = impactedV' f'_bot f_bot g_bot. +Proof. by rewrite /impactedV'_sub impactedVV'_sub_eq. Qed. + +Definition runnable_impactedV'_sub := + [set v in impactedV'_sub | runnable v]. + +Definition runnable_impacted_fresh_sub : seq V' := + enum runnable_impactedV'_sub. + +Definition run_impactedV'_sub_cert := + [seq (v, run v) | v <- runnable_impacted_fresh_sub]. + +End HierarchicalSub. diff --git a/core/hierarchical_sub_correct.v b/core/hierarchical_sub_correct.v new file mode 100644 index 0000000..d955bf3 --- /dev/null +++ b/core/hierarchical_sub_correct.v @@ -0,0 +1,156 @@ +From mathcomp +Require Import all_ssreflect. + +From chip +Require Import extra connect acyclic closure run change hierarchical_sub. + +Set Implicit Arguments. +Unset Strict Implicit. +Unset Printing Implicit Defensive. + +Section ChangedHierarchicalSub. + +Variables (A_top : eqType) (A_bot : eqType). + +Variables (U' : finType) (V' : finType). + +Variables (f'_top : U' -> A_top) (f'_bot : V' -> A_bot). + +Variables (P_top : pred U') (P_bot : pred V'). + +Local Notation U := (sig_finType P_top). + +Local Notation V := (sig_finType P_bot). + +Variable (g'_top : rel U') (g'_bot : rel V'). + +Local Notation g'_top_rev := [rel x y | g'_top y x]. + +Local Notation g'_bot_rev := [rel x y | g'_bot y x]. + +Variables (f_top : U -> A_top) (f_bot : V -> A_bot). + +Variables (g_top : rel U) (g_bot : rel V). + +Local Notation g_top_rev := [rel x y | g_top y x]. + +Local Notation g_bot_rev := [rel x y | g_bot y x]. + +Variables (runnable' : pred V') (runnable : pred V). + +Variable R : eqType. + +Variables (run : V -> R) (run' : V' -> R). + +Variables (p : U -> {set V}) (p' : U' -> {set V'}). + +Hypothesis p_neq : forall (u u' : U), u <> u' -> p u <> p u'. + +Hypothesis p'_neq : forall (u u' : U'), u <> u' -> p' u <> p' u'. + +Hypothesis p_partition : partition (\bigcup_( u | u \in U ) [set p u]) [set: V]. + +Hypothesis p'_partition : partition (\bigcup_( u | u \in U' ) [set p' u]) [set: V']. + +Hypothesis g_bot_top : forall (v v' : V) (u u' : U), + u <> u' -> g_bot v v' -> v \in p u -> v' \in p u' -> g_top u u'. + +Hypothesis f_top_bot : forall (u : U), + f_top u = f'_top (val u) -> forall (v : V), v \in p u -> f_bot v = f'_bot (val v). + +Local Notation insub_g_top x y := (insub_g g_top x y). + +Local Notation g_top_U' := [rel x y : U' | insub_g_top x y]. + +Local Notation g_top_U'_rev := [rel x y | g_top_U' y x]. + +Local Notation insub_g_bot x y := (insub_g g_bot x y). + +Local Notation g_bot_V' := [rel x y : V' | insub_g_bot x y]. + +Local Notation g_bot_V'_rev := [rel x y | g_bot_V' y x]. + +Hypothesis f_top_equal_g_top : + forall u, f_top u = f'_top (val u) -> forall u', g_top_U' (val u) u' = g'_top (val u) u'. + +Hypothesis f_bot_equal_g_bot : + forall v, f_bot v = f'_bot (val v) -> forall v', g_bot_V' (val v) v' = g'_bot (val v) v'. + +Hypothesis runnable_bot : + forall v, f_bot v = f'_bot (val v) -> runnable v = runnable' (val v). + +Hypothesis run_bot : + forall v, runnable v -> runnable' (val v) -> + (forall v', connect g_bot_V' (val v) v' = connect g'_bot (val v) v') -> + (forall v', connect g_bot_V' (val v) (val v') -> f_bot v' = f'_bot (val v')) -> + run v = run' (val v). + +Variable V_result_cert : seq (V * R). + +Hypothesis V_result_certP : + forall v r, reflect (runnable v /\ run v = r) ((v,r) \in V_result_cert). + +Hypothesis V_result_cert_uniq : uniq [seq vr.1 | vr <- V_result_cert]. + +Local Notation V_sub := (sig_finType (P_V_sub f'_top g_top f_top p)). + +Local Notation g_bot_sub := [rel x y : V_sub | g_bot (val x) (val y)]. + +Definition V'_result_filter_cert_sub := + [seq (val vr.1, vr.2) | vr <- V_result_cert & val vr.1 \notin impactedVV' g_bot (modifiedV f'_bot f_bot)]. + +Definition run_all_cert_sub := + run_impactedV'_sub_cert f'_top f'_bot g_top g_bot f_top f_bot runnable' run' p ++ V'_result_filter_cert_sub. + +Definition run_all_cert_V'_sub := + [seq vr.1 | vr <- run_all_cert_sub]. + +Lemma run_all_cert_complete_sub : + forall (v : V'), runnable' v -> v \in run_all_cert_V'_sub. +Proof. +move => v Hc. +rewrite /run_all_cert_V'_sub /run_all_cert_sub. +rewrite /run_impactedV'_sub_cert. +rewrite /runnable_impacted_fresh_sub. +rewrite /runnable_impactedV'_sub. +rewrite impactedV'_sub_eq. +apply: run_all_cert_complete; eauto. +- exact: p_neq. +- exact: p_partition. +- exact: g_bot_top. +- exact: f_top_bot. +Qed. + +Lemma run_all_cert_sound_sub : + forall (v : V') (r : R), (v,r) \in run_all_cert_sub -> + runnable' v /\ run' v = r. +Proof. +move => v r. +rewrite /run_all_cert_sub. +rewrite /run_impactedV'_sub_cert. +rewrite /runnable_impacted_fresh_sub. +rewrite /runnable_impactedV'_sub. +rewrite impactedV'_sub_eq. +apply: run_all_cert_sound; eauto. +- exact: p_neq. +- exact: p_partition. +- exact: g_bot_top. +- exact: f_top_bot. +Qed. + +Lemma run_all_cert_V'_sub_uniq : uniq run_all_cert_V'_sub. +Proof. +rewrite /run_all_cert_V'_sub. +rewrite /run_all_cert_sub. +rewrite /run_impactedV'_sub_cert. +rewrite /runnable_impacted_fresh_sub. +rewrite /runnable_impactedV'_sub. +rewrite impactedV'_sub_eq. +apply: run_all_cert_V'_uniq; eauto. +- exact: p_neq. +- exact: p_partition. +- exact: g_bot_top. +- exact: f_top_bot. +Qed. + +End ChangedHierarchicalSub. diff --git a/core/kosaraju.v b/core/kosaraju.v new file mode 100644 index 0000000..3f712f3 --- /dev/null +++ b/core/kosaraju.v @@ -0,0 +1,466 @@ +From mathcomp Require Import all_ssreflect. +From chip +Require Import extra connect. + +Set Implicit Arguments. +Unset Strict Implicit. +Unset Printing Implicit Defensive. + +Section Kosaraju. + +Variable T : finType. + +Implicit Types s : {set T}. + +Section Pdfs. + +Variable successors : T -> seq T. + +Fixpoint rpdfs m (p : {set T} * seq T) x := + if x \notin p.1 then p else + if m is m1.+1 then + let p1 := foldl (rpdfs m1) (p.1 :\ x, p.2) (successors x) in (p1.1, x :: p1.2) + else p. + +Definition pdfs := rpdfs #|T|. + +Definition tseq := (foldl pdfs (setT, [::]) (enum T)).2. + +Local Notation "x -[ l ]-> y" := + (connect (rel_of_simpl_rel (relto l (grel successors))) x y) + (at level 10, format "x -[ l ]-> y"). +Local Notation "x -[]-> y" := (connect (grel successors) x y) + (at level 10, format "x -[]-> y"). +Local Notation "x =[ l ]= y" := (diconnect (relto l (grel successors)) x y) + (at level 10, format "x =[ l ]= y"). +Local Notation "x =[]= y" := (diconnect (grel successors) x y) + (at level 10, format "x =[]= y"). +Local Notation "TS[ a , l ]" := (tsorted (grel successors) a l) + (at level 10, format "TS[ a , l ]"). +Local Notation "TS[ l ]" := (tsorted (grel successors) (pred_of_simpl predT) l) + (at level 10, format "TS[ l ]"). + +Lemma pdfs_correct' (p : {set T} * seq T) x : + let (s, l) := p in + uniq l /\ {subset l <= ~: s} -> + let p1 := pdfs p x in + let (s1, l1) := p1 in + if x \notin s then p1 = p else + [/\ #|s1| <= #|s| & uniq l1] + /\ + exists l2 : seq T, + [/\ x \in l2, s1 = s :\: [set y in l2], l1 = l2 ++ l, + TS[[pred x in s], l2] & + forall y, y \in l2 -> x -[[pred x in s]]-> y]. +Proof. +rewrite /pdfs. +have: #|p.1| <= #|T| by apply/subset_leq_card/subsetP=> i. +elim: #|T| x p => /= [x [s l]|n IH x [s l]]/=. + rewrite leqn0 => /eqP/cards0_eq-> [HUl HS]. + by rewrite inE. +have [xIs Hl [HUl HS]/=|xNIs Hl [HUl HS]//] := boolP (x \in s). +set p := (_, l); set F := rpdfs _; set L := successors _. +have: + [/\ #|p.1| < #|s| & uniq p.2] + /\ + exists l2, + [/\ + x \notin p.1, + p.1 = (s :\ x) :\: [set z in l2], + p.2 = l2 ++ l, TS[[predD1 s & x], l2] & + forall y, y \in l2 -> x -[[predD1 s & x]]-> y + ]. + split; [split => // | exists [::]; split => //=]. + - by rewrite /p /= [#|s|](cardsD1 x) xIs. + - by rewrite !inE eqxx. + - by rewrite setD0. + by exact: tsorted_nil. +have: forall y, (grel successors) x y -> (y \notin p.1) || (y \in L). + by move => y; rewrite /= orbC => ->. +have: forall y, (y \in L) -> (grel successors) x y by move=> y. +rewrite {}/p. +elim: L (_, _) => /= + [[s1 l1] /= _ yIp [[sSs1 Ul1] [l2 [xIs1 s1E l1E Rwl2 xCy]]]| + y l' IH1 [s1 l1] /= Rx yIp [[sSs1 Ul1] [l2 [xIs1 s1E l1E Rwl2 xCy]]]]. + split; [split=> // |exists (x :: l2); split] => // [||||||y]. + - rewrite subset_leqif_cards // s1E. + by apply: subset_trans (subsetDl _ _) (subD1set _ _). + - rewrite Ul1 andbT l1E mem_cat negb_or. + have [/= Dl2 _] := Rwl2. + have /subsetP/(_ x)/implyP/= := Dl2. + rewrite !inE /= eqxx implybF => ->. + have /implyP := HS x. + by rewrite !inE xIs implybF. + - by rewrite inE eqxx. + - by apply/setP => z; rewrite s1E !inE negb_or andbC andbAC. + - by rewrite l1E. + - apply: tsorted_cons_r => // [y yInl2|y /yIp]. + rewrite connect_to_C1_id + (eq_connect (_ : _ =2 (relto [predD1 s & x] (grel successors)))) ?xCy //. + by move=> x1 y1; rewrite /= !inE andbA. + rewrite orbF s1E 3!inE negb_and => /orP[]; first by rewrite negbK. + by rewrite !inE negb_and => /orP[] /negPf->. + rewrite inE => /orP[/eqP->|yIl2]. + by apply: connect0. + apply: connect_to_sub (xCy _ yIl2); apply/subsetP => i /=. + by rewrite !inE => /andP[]. +have F1 : #|s1| <= n. + by rewrite -ltnS (leq_trans _ Hl). +have F2 : {subset l1 <= ~: s1}. + move=> i; rewrite l1E s1E !inE mem_cat => /orP[->//|/HS]. + by rewrite inE => /negPf->; rewrite !andbF. +have := IH y (s1, l1) F1 (conj Ul1 F2). +rewrite /F /=; case: rpdfs => s3 l3 /= Hv. +apply: IH1 => [z zIl|z Rxz /=|]; first by apply: Rx; rewrite inE zIl orbT. + case: (boolP (y \in s1)) Hv => + [yIs1/= [[Ss1s3 Ul3] [l4 [yIl4 s3E l3E Rwl4 Cyz]]] + |yNIs1/= [-> _]]; last first. + case/orP: (yIp _ Rxz) => [->//|]. + by rewrite inE => /orP[/eqP->|->]; [rewrite yNIs1|rewrite orbT]. + rewrite s3E !inE !negb_and. + case/orP: (yIp _ Rxz) => [->//|]; first by rewrite orbT. + rewrite inE => /orP[/eqP->|->]; last by rewrite orbT. + by rewrite yIl4. +case: (boolP (y \in s1)) Hv => + [yIs1 [[Ss1s3 Ul3] [l4 [yIl4 s3E l3E Rwl4 Cyz]]] + |yNIs1 [-> ->]]; last first. + by split=> //; exists l2; split. +split; [split=> //= | exists (l4 ++ l2); split => //= [||||z]]. +- by apply: leq_ltn_trans Ss1s3 _. +- by rewrite s3E s1E !inE eqxx !andbF. +- by apply/setP => i; rewrite s3E s1E !inE mem_cat negb_or -!andbA. +- by rewrite l3E l1E catA. +- apply: tsorted_cat => //. + apply: eq_tsorted Rwl4 => i. + by rewrite /= s1E !inE. +rewrite mem_cat => /orP[] zIl4; last by apply: xCy. +apply: connect_trans (_: y -[_]-> z); last first. + apply: connect_to_sub (Cyz _ zIl4); apply/subsetP => i. + by rewrite /= s1E !inE => /andP[]. +apply: connect_to1 (Rx _ _); rewrite !inE ?eqxx //. +by move: yIs1; rewrite s1E !inE=> /and3P[_ ->]. +Qed. + +Lemma pdfs_connect' s x : + x \in s -> + let (s1, l1) := pdfs (s, [::]) x in + [/\ uniq l1, s1 = s :\: [set z in l1], l1 \subset s & + forall y, y \in l1 = x -[[pred u in s]]-> y]. +Proof. +move=> xIs. +set p := (_, _). +have UN : [/\ uniq p.2 & {subset p.2 <= ~: p.1}] by []. +case: pdfs (pdfs_correct' (_, _) x UN) => s1 l1. +rewrite xIs => /=[[[_ Ul1] [l2 [xIl2 s1E l1E WH Cy]]]]. +split => // [||y]. +- by apply/setP=> i; rewrite s1E l1E !inE cats0. +- apply/subsetP=> z. + rewrite l1E cats0. + by have [/subsetP/(_ z)/=] := WH. +apply/idP/idP => [|H]. + by rewrite l1E cats0; exact: Cy. +rewrite l1E cats0. +by have [_ /(_ x y xIl2 H)] := WH. +Qed. + +(* The sequence is topologically sorted and contains all the nodes *) +Lemma tseq_correct' : TS[tseq] /\ forall x, x \in tseq. +Proof. +suff: [/\ + {subset (setT : {set T}, [::]).2 <= tseq}, + TS[tseq] & + forall x : T, x \in (enum T) -> x \in tseq]. + case=> H1 H2 H3; split => // x. + by rewrite H3 // mem_enum. +rewrite /tseq; set F := foldl _; set p := (_, _). +have : TS[p.2] by apply: tsorted_nil. +have: p.1 = ~: [set x in p.2]. + by apply/setP=> i; rewrite /= !inE. +have: uniq p.2 by []. +elim: (enum T) p => /= [|y l IH [s1 l1] HUl1 /= Hi Rw]. + by split. +have HS : {subset l1 <= ~: s1}. + by move=> i; rewrite Hi !inE negbK. +have := pdfs_correct' (_, _) y (conj HUl1 HS). +have [yIs1|yNIs1] := boolP (y \in s1); last first. + case: pdfs => s2 l2 [-> ->]. + have /= [Sl2 HR xI] := IH (s1,l1) HUl1 Hi Rw. + split => // x. + rewrite inE => /orP[/eqP->|xIl]; last by apply: xI. + apply: Sl2. + by move: yNIs1; rewrite Hi !inE negbK. +case: pdfs => s2 l2 /= [[Ss1s2 Ul2] [l3 [yIl3 s2E l2E RWl3 Cyz]]]. +case: (IH (s2, l2)) => //= [|| Sl2F RwF FI]. +- by apply/setP=> i; rewrite s2E Hi l2E !inE mem_cat negb_or. +- rewrite l2E; apply: (tsorted_cat Rw). + apply: eq_tsorted RWl3 => i. + by rewrite /= Hi !inE andbT. +split=> // [i iIl1|x]; first by rewrite Sl2F // l2E mem_cat iIl1 orbT. +rewrite inE => /orP[/eqP->|//]; last exact: FI. +by apply: Sl2F; rewrite l2E mem_cat yIl3. +Qed. + +End Pdfs. + +Section Stack. + +Variable r : rel T. + +Local Notation "x -[ l ]-> y" := + (connect (rel_of_simpl_rel (relto l r)) x y) + (at level 10, format "x -[ l ]-> y"). +Local Notation "x -[]-> y" := (connect r x y) + (at level 10, format "x -[]-> y"). +Local Notation "x =[ l ]= y" := (diconnect (relto l r) x y) + (at level 10, format "x =[ l ]= y"). +Local Notation "x =[]= y" := (diconnect r x y) + (at level 10, format "x =[]= y"). +Local Notation "TS[ a , l ]" := (tsorted r a l) + (at level 10, format "TS[ a , l ]"). +Local Notation "TS[ l ]" := (tsorted r (pred_of_simpl predT) l) + (at level 10, format "TS[ l ]"). + +Lemma pdfs_correct (p : {set T} * seq T) x : + let (s, l) := p in + uniq l /\ {subset l <= ~: s} -> + let p1 := pdfs (rgraph r) p x in + let (s1, l1) := p1 in + if x \notin s then p1 = p else + [/\ #|s1| <= #|s| & uniq l1] + /\ + exists l2 : seq T, + [/\ x \in l2, s1 = s :\: [set y in l2], l1 = l2 ++ l, + TS[[pred x in s], l2] & + forall y, y \in l2 -> x -[[pred x in s]]-> y]. +Proof. +rewrite /pdfs. +have: #|p.1| <= #|T| by apply/subset_leq_card/subsetP=> i. +elim: #|T| x p => /= [x [s l]|n IH x [s l]]/=. + rewrite leqn0 => /eqP/cards0_eq-> [HUl HS]. + by rewrite inE. +have [xIs Hl [HUl HS]/=|xNIs Hl [HUl HS]//] := boolP (x \in s). +set p := (_, l); set F := rpdfs _ _; set L := rgraph _ _. +have: + [/\ #|p.1| < #|s| & uniq p.2] + /\ + exists l2, + [/\ + x \notin p.1, + p.1 = (s :\ x) :\: [set z in l2], + p.2 = l2 ++ l, TS[[predD1 s & x], l2] & + forall y, y \in l2 -> x -[[predD1 s & x]]-> y + ]. + split; [split => // | exists [::]; split => //=]. + - by rewrite /p /= [#|s|](cardsD1 x) xIs. + - by rewrite !inE eqxx. + - by rewrite setD0. + by exact: tsorted_nil. +have: forall y, r x y -> (y \notin p.1) || (y \in L). + by move=> y; rewrite [_ \in rgraph _ _]rgraphK orbC => ->. +have: forall y, (y \in L) -> r x y. + by move=> y; rewrite [_ \in rgraph _ _]rgraphK. +rewrite {}/p. +elim: L (_, _) => /= + [[s1 l1] /= _ yIp [[sSs1 Ul1] [l2 [xIs1 s1E l1E Rwl2 xCy]]]| + y l' IH1 [s1 l1] /= Rx yIp [[sSs1 Ul1] [l2 [xIs1 s1E l1E Rwl2 xCy]]]]. + split; [split=> // |exists (x :: l2); split] => // [||||||y]. + - rewrite subset_leqif_cards // s1E. + by apply: subset_trans (subsetDl _ _) (subD1set _ _). + - rewrite Ul1 andbT l1E mem_cat negb_or. + have [/= Dl2 _] := Rwl2. + have /subsetP/(_ x)/implyP/= := Dl2. + rewrite !inE /= eqxx implybF => ->. + have /implyP := HS x. + by rewrite !inE xIs implybF. + - by rewrite inE eqxx. + - by apply/setP => z; rewrite s1E !inE negb_or andbC andbAC. + - by rewrite l1E. + - apply: tsorted_cons_r => // [y yInl2|y /yIp]. + rewrite connect_to_C1_id + (eq_connect (_ : _ =2 (relto [predD1 s & x] r))) ?xCy //. + by move=> x1 y1; rewrite /= !inE andbA. + rewrite orbF s1E 3!inE negb_and => /orP[]; first by rewrite negbK. + by rewrite !inE negb_and => /orP[] /negPf->. + rewrite inE => /orP[/eqP->|yIl2]. + by apply: connect0. + apply: connect_to_sub (xCy _ yIl2); apply/subsetP => i /=. + by rewrite !inE => /andP[]. +have F1 : #|s1| <= n. + by rewrite -ltnS (leq_trans _ Hl). +have F2 : {subset l1 <= ~: s1}. + move=> i; rewrite l1E s1E !inE mem_cat => /orP[->//|/HS]. + by rewrite inE => /negPf->; rewrite !andbF. +have := IH y (s1, l1) F1 (conj Ul1 F2). +rewrite /F /=; case: rpdfs => s3 l3 /= Hv. +apply: IH1 => [z zIl|z Rxz /=|]; first by apply: Rx; rewrite inE zIl orbT. + case: (boolP (y \in s1)) Hv => + [yIs1/= [[Ss1s3 Ul3] [l4 [yIl4 s3E l3E Rwl4 Cyz]]] + |yNIs1/= [-> _]]; last first. + case/orP: (yIp _ Rxz) => [->//|]. + by rewrite inE => /orP[/eqP->|->]; [rewrite yNIs1|rewrite orbT]. + rewrite s3E !inE !negb_and. + case/orP: (yIp _ Rxz) => [->//|]; first by rewrite orbT. + rewrite inE => /orP[/eqP->|->]; last by rewrite orbT. + by rewrite yIl4. +case: (boolP (y \in s1)) Hv => + [yIs1 [[Ss1s3 Ul3] [l4 [yIl4 s3E l3E Rwl4 Cyz]]] + |yNIs1 [-> ->]]; last first. + by split=> //; exists l2; split. +split; [split=> //= | exists (l4 ++ l2); split => //= [||||z]]. +- by apply: leq_ltn_trans Ss1s3 _. +- by rewrite s3E s1E !inE eqxx !andbF. +- by apply/setP => i; rewrite s3E s1E !inE mem_cat negb_or -!andbA. +- by rewrite l3E l1E catA. +- apply: tsorted_cat => //. + apply: eq_tsorted Rwl4 => i. + by rewrite /= s1E !inE. +rewrite mem_cat => /orP[] zIl4; last by apply: xCy. +apply: connect_trans (_: y -[_]-> z); last first. + apply: connect_to_sub (Cyz _ zIl4); apply/subsetP => i. + by rewrite /= s1E !inE => /andP[]. +apply: connect_to1 (Rx _ _); rewrite !inE ?eqxx //. +by move: yIs1; rewrite s1E !inE=> /and3P[_ ->]. +Qed. + +Lemma pdfs_connect s x : + x \in s -> + let (s1, l1) := pdfs (rgraph r) (s, [::]) x in + [/\ uniq l1, s1 = s :\: [set z in l1], l1 \subset s & + forall y, y \in l1 = x -[[pred u in s]]-> y]. +Proof. +move=> xIs. +set p := (_, _). +have UN : [/\ uniq p.2 & {subset p.2 <= ~: p.1}] by []. +case: pdfs (pdfs_correct (_, _) x UN) => s1 l1. +rewrite xIs => /=[[[_ Ul1] [l2 [xIl2 s1E l1E WH Cy]]]]. +split => // [||y]. +- by apply/setP=> i; rewrite s1E l1E !inE cats0. +- apply/subsetP=> z. + rewrite l1E cats0. + by have [/subsetP/(_ z)/=] := WH. +apply/idP/idP => [|H]. + by rewrite l1E cats0; exact: Cy. +rewrite l1E cats0. +by have [_ /(_ x y xIl2 H)] := WH. +Qed. + +(* The sequence is topologically sorted and contains all the nodes *) +Lemma tseq_correct : TS[tseq (rgraph r)] /\ forall x, x \in tseq (rgraph r). +Proof. +suff: [/\ + {subset (setT : {set T}, [::]).2 <= tseq (rgraph r)}, + TS[tseq (rgraph r)] & + forall x : T, x \in (enum T) -> x \in tseq (rgraph r)]. + case=> H1 H2 H3; split => // x. + by rewrite H3 // mem_enum. +rewrite /tseq; set F := foldl _; set p := (_, _). +have : TS[p.2] by apply: tsorted_nil. +have: p.1 = ~: [set x in p.2]. + by apply/setP=> i; rewrite /= !inE. +have: uniq p.2 by []. +elim: (enum T) p => /= [|y l IH [s1 l1] HUl1 /= Hi Rw]. + by split. +have HS : {subset l1 <= ~: s1}. + by move=> i; rewrite Hi !inE negbK. +have := pdfs_correct (_, _) y (conj HUl1 HS). +have [yIs1|yNIs1] := boolP (y \in s1); last first. + case: pdfs => s2 l2 [-> ->]. + have /= [Sl2 HR xI] := IH (s1,l1) HUl1 Hi Rw. + split => // x. + rewrite inE => /orP[/eqP->|xIl]; last by apply: xI. + apply: Sl2. + by move: yNIs1; rewrite Hi !inE negbK. +case: pdfs => s2 l2 /= [[Ss1s2 Ul2] [l3 [yIl3 s2E l2E RWl3 Cyz]]]. +case: (IH (s2, l2)) => //= [|| Sl2F RwF FI]. +- by apply/setP=> i; rewrite s2E Hi l2E !inE mem_cat negb_or. +- rewrite l2E; apply: (tsorted_cat Rw). + apply: eq_tsorted RWl3 => i. + by rewrite /= Hi !inE andbT. +split=> // [i iIl1|x]; first by rewrite Sl2F // l2E mem_cat iIl1 orbT. +rewrite inE => /orP[/eqP->|//]; last exact: FI. +by apply: Sl2F; rewrite l2E mem_cat yIl3. +Qed. + +End Stack. + +Section Program. + +Variable r : rel T. + +Definition kosaraju := + let f := pdfs (rgraph [rel x y | r y x]) in + (foldl (fun (p : {set T} * seq (seq T)) x => if x \notin p.1 then p else + let p1 := f (p.1, [::]) x in (p1.1, p1.2 :: p.2)) + (setT, [::]) (tseq (rgraph r))).2. + +Lemma kosaraju_correct : + let l := flatten kosaraju in + [/\ uniq l, forall i, i \in l & + forall c : seq T, c \in kosaraju -> + exists x, forall y, (y \in c) = (connect r x y && connect r y x)]. +Proof. +rewrite /kosaraju. +set f := pdfs (rgraph [rel x y | r y x]). +set g := fun p x => if _ then _ else _. +set p := (_, _). +have: uniq (flatten p.2) by []. +have: forall c, c \in (flatten p.2) ++ (tseq (rgraph r)). + by move=>c; case: (tseq_correct r) => _ /(_ c). +have: forall c, c \in p.2 -> + exists x, c =i (diconnect (relto predT r) x) by []. +have: ~: p.1 =i flatten p.2. + by move=> i; rewrite !inE in_nil. +have: tsorted r (predT : pred T) [seq i <- tseq (rgraph r) | i \in p.1]. + have->: [seq i <- tseq (rgraph r) | i \in p.1] = tseq (rgraph r). + by apply/all_filterP/allP=> y; rewrite inE. + by case: (tseq_correct r). +elim: tseq p => [[s l]/= HR HI HE HFI HUF|]. + split=> // i. + by have := HFI i; rewrite cats0. +move=> x l IH [s1 l1] HR HI HE HFI HUF. +rewrite /g /f /=. +have [xIs1|xNIs1] := boolP (x \in s1); last first. + apply: IH => //= [|i]; first by move: HR; rewrite /= (negPf xNIs1). + have:= HFI i; rewrite !mem_cat inE /=. + by case: eqP => //->; rewrite -HI !inE xNIs1. +have := (@pdfs_connect ([rel x y | r y x]) s1 x xIs1). +case: pdfs => s2 l2 /= [Ul2 s2E Dl2 xCy]. +move: HR; rewrite /= xIs1; set L := [seq _ <- _ | _] => HR. +have l2R : l2 =i (diconnect r x). + move=> y. + rewrite xCy -(@connect_to_rev _ r L setT) //. + - rewrite -tsorted_diconnect //. + rewrite -topredE /=. + by apply: eq_diconnect => i j; rewrite /= !inE. + by apply: eq_tsorted HR => i; rewrite !inE //= topredE inE. + - by apply/subsetP. + - move=> i; rewrite /= !inE mem_filter. + have := HFI i; rewrite /= mem_cat -HI /= !inE. + case: (_ =P _) => [->|] /=; first by rewrite xIs1. + by case: (_ \in _). + by apply: eq_tsorted HR => i; rewrite // inE topredE inE. +apply: IH => [|i|i|i|] //=. +- suff->: [seq i <- l | i \in s2] = + [seq i <- x :: L | ~~ diconnect r x i]. + by apply: tsorted_inv. + rewrite /= diconnect0 /=. + rewrite -filter_predI. + apply: eq_filter => y /=. + by rewrite s2E !inE l2R. +- by rewrite s2E !mem_cat !inE -HI negb_and negbK inE. +- by rewrite inE => /orP[/eqP->|//]; [exists x | apply: HE]. +- have:= HFI i. + rewrite /= !mem_cat !inE => /or3P[->|/eqP->|->]. + - by rewrite orbT. + - by rewrite xCy connect0. + by rewrite !orbT. +rewrite cat_uniq Ul2 HUF /= andbT. +apply/hasPn => i /=. +have/subsetP/(_ i)/= := Dl2. +by rewrite -HI /= !inE; do 2 case: (_ \in _). +Qed. + +End Program. + +End Kosaraju. + diff --git a/core/kosaraju_acyclic.v b/core/kosaraju_acyclic.v new file mode 100644 index 0000000..acba268 --- /dev/null +++ b/core/kosaraju_acyclic.v @@ -0,0 +1,55 @@ +From mathcomp +Require Import all_ssreflect. + +From chip +Require Import connect acyclic kosaraju. + +Set Implicit Arguments. +Unset Strict Implicit. +Unset Printing Implicit Defensive. + +Section KosarajuAcyclicity. + +Variable V : finType. +Variable successors : V -> seq V. + +Notation g := (grel successors). + +Lemma uniq_flatten_kosaraju : uniq (flatten (kosaraju g)). +Proof. +have H := kosaraju_correct g. +move: H. +rewrite /=. +by case. +Qed. + +Lemma all_in_flatten_kosaraju : forall v : V, v \in (flatten (kosaraju g)). +Proof. +have H := kosaraju_correct g. +move: H. +rewrite /=. +by case. +Qed. + +Lemma class_diconnected_kosaraju : + forall c, c \in kosaraju g -> + exists x, forall y, (y \in c) = diconnect g x y. +Proof. +have H := kosaraju_correct g. +move: H. +rewrite /=. +by case. +Qed. + +Definition kosaraju_acyclic := sccs_acyclic (@kosaraju V) g. + +Lemma kosaraju_acyclicP : + reflect (acyclic g) kosaraju_acyclic. +Proof. +apply sccs_acyclicP. +- exact: uniq_flatten_kosaraju. +- exact: all_in_flatten_kosaraju. +- exact: class_diconnected_kosaraju. +Qed. + +End KosarajuAcyclicity. diff --git a/core/ordtype.v b/core/ordtype.v new file mode 100644 index 0000000..f2f1327 --- /dev/null +++ b/core/ordtype.v @@ -0,0 +1,331 @@ +(* +Copyright 2010 IMDEA Software Institute +Licensed under the Apache License, Version 2.0 (the "License"); +you may not use this file except in compliance with the License. +You may obtain a copy of the License at + http://www.apache.org/licenses/LICENSE-2.0 +Unless required by applicable law or agreed to in writing, software +distributed under the License is distributed on an "AS IS" BASIS, +WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +See the License for the specific language governing permissions and +limitations under the License. +*) + +(******************************************************************************) +(* This file defines ordType - the structure for types with a decidable *) +(* (strict) order relation. *) +(* ordType is a subclass of mathcomp's eqType *) +(* This file also defines some important instances of ordType *) +(******************************************************************************) + +From Coq Require Import ssreflect ssrbool ssrfun. +From mathcomp Require Import ssrnat eqtype seq path fintype. +Set Implicit Arguments. +Unset Strict Implicit. +Unset Printing Implicit Defensive. + +Module Ordered. + +Section RawMixin. + +Structure mixin_of (T : eqType) := + Mixin {ordering : rel T; + _ : irreflexive ordering; + _ : transitive ordering; + _ : forall x y, [|| ordering x y, x == y | ordering y x]}. + +End RawMixin. + +(* the class takes a naked type T and returns all the *) +(* relatex mixins; the inherited ones and the added ones *) +Section ClassDef. + +Record class_of (T : Type) := Class { + base : Equality.class_of T; + mixin : mixin_of (Equality.Pack base T)}. + +Local Coercion base : class_of >-> Equality.class_of. + +Structure type : Type := Pack {sort : Type; _ : class_of sort; _ : Type}. +Local Coercion sort : type >-> Sortclass. + +Variables (T : Type) (cT : type). +Definition class := let: Pack _ c _ as cT' := cT return class_of cT' in c. +Definition clone c of phant_id class c := @Pack T c T. + +(* produce an ordered type out of the inherited mixins *) +(* equalize m0 and m by means of a phantom; will be exploited *) +(* further down in the definition of OrdType *) +Definition pack b (m0 : mixin_of (EqType T b)) := + fun m & phant_id m0 m => Pack (@Class T b m) T. + +Definition eqType := Equality.Pack class cT. + +End ClassDef. + +Module Exports. +Coercion sort : type >-> Sortclass. +Coercion eqType : type >-> Equality.type. +Canonical Structure eqType. +Notation ordType := Ordered.type. +Notation OrdMixin := Mixin. +Notation OrdType T m := (@pack T _ m _ id). +Definition ord T : rel (sort T) := (ordering (mixin (class T))). +Notation "[ 'ordType' 'of' T 'for' cT ]" := (@clone T cT _ id) + (at level 0, format "[ 'ordType' 'of' T 'for' cT ]") : form_scope. +Notation "[ 'ordType' 'of' T ]" := (@clone T _ _ id) + (at level 0, format "[ 'ordType' 'of' T ]") : form_scope. +End Exports. +End Ordered. +Export Ordered.Exports. + +Definition oleq (T : ordType) (t1 t2 : T) := ord t1 t2 || (t1 == t2). + +Prenex Implicits ord oleq. + +Section Lemmas. +Variable T : ordType. + +Lemma irr : irreflexive (@ord T). +Proof. by case: T=>s [b [m]]. Qed. + +Lemma trans : transitive (@ord T). +Proof. by case: T=>s [b [m]]. Qed. + +Lemma total (x y : T) : [|| ord x y, x == y | ord y x]. +Proof. by case: T x y=>s [b [m]]. Qed. + +Lemma nsym (x y : T) : ord x y -> ord y x -> False. +Proof. by move=>E1 E2; move: (trans E1 E2); rewrite irr. Qed. + +Lemma otrans : transitive (@oleq T). +Proof. +move=>x y z /=; case/orP; last by move/eqP=>->. +rewrite /oleq; move=>T1; case/orP; first by move/(trans T1)=>->. +by move/eqP=><-; rewrite T1. +Qed. + +Lemma sorted_oleq s : sorted (@ord T) s -> sorted (@oleq T) s. +Proof. by elim: s=>[|x s IH] //=; apply: sub_path=>z y; rewrite /oleq=>->. Qed. + +End Lemmas. + +Section Totality. +Variable K : ordType. + +CoInductive total_spec (x y : K) : bool -> bool -> bool -> Type := +| total_spec_lt of ord x y : total_spec x y true false false +| total_spec_eq of x == y : total_spec x y false true false +| total_spec_gt of ord y x : total_spec x y false false true. + +Lemma totalP x y : total_spec x y (ord x y) (x == y) (ord y x). +Proof. +case H1: (x == y). +- by rewrite (eqP H1) irr; apply: total_spec_eq. +case H2: (ord x y); case H3: (ord y x). +- by case: (nsym H2 H3). +- by apply: total_spec_lt H2. +- by apply: total_spec_gt H3. +by move: (total x y); rewrite H1 H2 H3. +Qed. +End Totality. + + +(* Monotone (i.e. strictly increasing) functions for Ord Types *) +Section Mono. +Variables (A B :ordType). + +Definition strictly_increasing f x y := @ord A x y -> @ord B (f x) (f y). + +Structure mono : Type := Mono + {fun_of: A -> B; _: forall x y, strictly_increasing fun_of x y}. + +End Mono. +Arguments strictly_increasing {A B} f x y. +Arguments Mono {A B _} _. + +Section NatOrd. +Lemma irr_ltn_nat : irreflexive ltn. Proof. by move=>x; rewrite /= ltnn. Qed. +Lemma trans_ltn_nat : transitive ltn. Proof. by apply: ltn_trans. Qed. +Lemma total_ltn_nat x y : [|| x < y, x == y | y < x]. +Proof. by case: ltngtP. Qed. + +Definition nat_ordMixin := OrdMixin irr_ltn_nat trans_ltn_nat total_ltn_nat. +Canonical Structure nat_ordType := OrdType nat nat_ordMixin. +End NatOrd. + +Section ProdOrd. +Variables K T : ordType. + +(* lexicographic ordering *) +Definition lex : rel (K * T) := + fun x y => if x.1 == y.1 then ord x.2 y.2 else ord x.1 y.1. + +Lemma irr_lex : irreflexive lex. +Proof. by move=>x; rewrite /lex eq_refl irr. Qed. + +Lemma trans_lex : transitive lex. +Proof. +move=>[x1 x2][y1 y2][z1 z2]; rewrite /lex /=. +case: ifP=>H1; first by rewrite (eqP H1); case: eqP=>// _; apply: trans. +case: ifP=>H2; first by rewrite (eqP H2) in H1 *; rewrite H1. +case: ifP=>H3; last by apply: trans. +by rewrite (eqP H3)=>R1; move/(nsym R1). +Qed. + +Lemma total_lex : forall x y, [|| lex x y, x == y | lex y x]. +Proof. +move=>[x1 x2][y1 y2]; rewrite /lex /=. +case: ifP=>H1. +- rewrite (eqP H1) eq_refl -pair_eqE /= eq_refl /=; exact: total. +rewrite (eq_sym y1) -pair_eqE /= H1 /=. +by move: (total x1 y1); rewrite H1. +Qed. + +Definition prod_ordMixin := OrdMixin irr_lex trans_lex total_lex. +Canonical Structure prod_ordType := Eval hnf in OrdType (K * T) prod_ordMixin. +End ProdOrd. + +Section FinTypeOrd. +Variable T : finType. + +Definition ordf : rel T := + fun x y => index x (enum T) < index y (enum T). + +Lemma irr_ordf : irreflexive ordf. +Proof. by move=>x; rewrite /ordf ltnn. Qed. + +Lemma trans_ordf : transitive ordf. +Proof. by move=>x y z; rewrite /ordf; apply: ltn_trans. Qed. + +Lemma total_ordf x y : [|| ordf x y, x == y | ordf y x]. +Proof. +rewrite /ordf; case: ltngtP=>//= H; rewrite ?orbT ?orbF //. +have [H1 H2]: x \in enum T /\ y \in enum T by rewrite !mem_enum. +by rewrite -(nth_index x H1) -(nth_index x H2) H eq_refl. +Qed. + +Definition fin_ordMixin := OrdMixin irr_ordf trans_ordf total_ordf. +End FinTypeOrd. + +(* notation to let us write I_n instead of (ordinal_finType n) *) +Notation "[ 'fin_ordMixin' 'of' T ]" := + (fin_ordMixin _ : Ordered.mixin_of [eqType of T]) (at level 0). + +Definition ordinal_ordMixin n := [fin_ordMixin of 'I_n]. +Canonical Structure ordinal_ordType n := OrdType 'I_n (ordinal_ordMixin n). + +Section SeqOrd. +Variable (T : ordType). + +Fixpoint ords x : pred (seq T) := + fun y => match x , y with + | [::] , [::] => false + | [::] , t :: ts => true + | x :: xs , y :: ys => if x == y then ords xs ys + else ord x y + | _ :: _ , [::] => false + end. + +Lemma irr_ords : irreflexive ords. +Proof. by elim=>//= a l ->; rewrite irr; case:eqP=> //=. Qed. + +Lemma trans_ords : transitive ords. +Proof. +elim=>[|y ys IHy][|x xs][|z zs]//=. +case:eqP=>//[->|H0];case:eqP=>//H; first by move/IHy; apply. +- by case:eqP=>//; rewrite -H; first (by move/H0). +case:eqP=>//[->|H1] H2; first by move/(nsym H2). +by move/(trans H2). +Qed. + +Lemma total_ords : forall x y, [|| ords x y, x == y | ords y x]. +Proof. +elim=>[|x xs IH][|y ys]//=; case:eqP=>//[->|H1]; + (case:eqP=>//= H; first (by rewrite orbT //=)). +- by case:eqP=>//H3 ; case: (or3P (IH ys))=> [-> | /eqP H0 | ->]; + [ rewrite orTb // | apply: False_ind; apply: H; rewrite H0 | rewrite orbT //]. +case:eqP; first by move/(esym)/H1. +by move=>_ ;case: (or3P (total x y))=>[-> //| /eqP /H1 //| -> //]; rewrite orbT. +Qed. + +Definition seq_ordMixin := OrdMixin irr_ords trans_ords total_ords. +Canonical Structure seq_ordType := Eval hnf in OrdType (seq T) seq_ordMixin. +End SeqOrd. + +(* A trivial total ordering for Unit *) +Section unitOrd. +Let ordtt (x y : unit ) := false. + +Lemma irr_tt : irreflexive ordtt. +Proof. by []. Qed. + +Lemma trans_tt : transitive ordtt. +Proof. by []. Qed. + +Lemma total_tt x y : [|| ordtt x y, x == y | ordtt y x ]. +Proof. by []. Qed. + +Let unit_ordMixin := OrdMixin irr_tt trans_tt total_tt. +Canonical Structure unit_ordType := Eval hnf in OrdType unit unit_ordMixin. +End unitOrd. + + +(* ordering with path, seq and last *) + +Lemma seq_last_in (A : eqType) (s : seq A) x : + last x s \notin s -> s = [::]. +Proof. +case: (lastP s)=>// {s} s y; case: negP=>//; elim; rewrite last_rcons. +by elim: s=>[|y' s IH]; rewrite /= inE // IH orbT. +Qed. + +Lemma path_last (A : ordType) (s : seq A) x : + path oleq x s -> oleq x (last x s). +Proof. +elim: s x=>[|y s IH] /= x; first by rewrite /oleq eq_refl orbT. +case/andP=>H1 /IH; case/orP=>H2; rewrite /oleq. +- case/orP: H1=>H1; first by rewrite (trans H1 H2). + by rewrite (eqP H1) H2. +by rewrite -(eqP H2); case/orP: H1=>-> //=; rewrite orbT. +Qed. + +(* in a sorted list, the last element is maximal *) +(* and the maximal element is last *) + +Lemma sorted_last_key_max (A : ordType) (s : seq A) x y : + sorted oleq s -> x \in s -> oleq x (last y s). +Proof. +elim: s x y=>[|z s IH] //= x y H; rewrite inE /=. +case: eqP=>[->|] /= _; first by apply: path_last. +by apply: IH (path_sorted H). +Qed. + +Lemma sorted_max_key_last (A : ordType) (s : seq A) x y : + sorted oleq s -> x \in s -> + (forall z, z \in s -> oleq z x) -> last y s = x. +Proof. +elim: s x y => [|w s IH] //= x y; rewrite inE /=. +case: eqP=>[<- /= H1 _ H2 | _ H /= H1 H2]; last first. +- apply: IH (path_sorted H) H1 _ => z H3; apply: H2. + by rewrite inE /= H3 orbT. +apply/eqP; move: (H2 (last x s)) (path_last H1); rewrite inE /= /oleq eq_sym. +case: totalP=>//=; case E: (last x s \in s)=>//. +by move/negbT/seq_last_in: E=>->; rewrite irr. +Qed. + +Lemma seq_last_mono (A : ordType) (s1 s2 : seq A) x : + path oleq x s1 -> path oleq x s2 -> + {subset s1 <= s2} -> + oleq (last x s1) (last x s2). +Proof. +case: s1=>/= [_ H1 _|a s]; first by apply: path_last H1. +case/andP=>H1 H2 H3 H; apply: sorted_last_key_max (path_sorted H3) _. +apply: {x s2 H1 H3} H; rewrite inE orbC -implyNb. +by case E: (_ \notin _) (@seq_last_in _ s a)=>//= ->. +Qed. + + + + + diff --git a/core/run.v b/core/run.v new file mode 100644 index 0000000..4880285 --- /dev/null +++ b/core/run.v @@ -0,0 +1,363 @@ +From mathcomp +Require Import all_ssreflect. + +From chip +Require Import extra connect close_dfs closure. + +Set Implicit Arguments. +Unset Strict Implicit. +Unset Printing Implicit Defensive. + +Section InvRel. + +Variable T : finType. + +Definition rinv (r : rel T) := [rel x y | r y x]. + +End InvRel. + +Notation "r ^-1" := (rinv r). + +Section Checked. + +(* artifact *) +Variable A : eqType. + +(* paths *) +Variable V' : finType. + +Variable f' : V' -> A. + +(* old graph *) +Variable P : pred V'. + +Local Notation V := (sig_finType P). + +Variable f : V -> A. + +Variable g : rel V. + +Variable runnable : pred V'. + +Variable R : eqType. + +Variable run : V' -> R. + +Definition freshV' : {set V'} := [set v | ~~ P v]. + +Lemma sub_freshV' v' : + (~~ @insub _ _ [subType of V] v') = (v' \in freshV'). +Proof. +case Hs: (~~ _); case Hf: (_ \in _) => //. +- move/negP: Hf; case. + have H_sp := (insubP [subType of V] v'). + destruct H_sp => //. + by rewrite in_set. +- move/negP/negP: Hs => Hs. + move: Hf. + rewrite in_set. + move/negP. + case. + have H_sp := (insubP [subType of V] v'). + by destruct H_sp. +Qed. + +Lemma freshV'P v' : + reflect (forall v : V, val v != v') (v' \in freshV'). +Proof. +apply: (iffP idP). +- rewrite in_set. + move/negP => HP v. + apply/negP. + move/eqP => Hv. + case: HP. + rewrite -Hv. + exact: valP. +- move => Hv. + rewrite in_set. + apply/negP => HP. + have H_sp := (insubP [subType of V] v'). + destruct H_sp; last by move/negP: i; case. + have Hvu := Hv u. + move/negP/negP: Hvu. + rewrite e. + by move/eqP. +Qed. + +Definition modifiedV := [set v | f v != f' (val v)]. + +Lemma not_modifiedP v : + reflect (f v == f' (val v)) (v \notin modifiedV). +Proof. +apply: (iffP idP). +- move/negPf. + rewrite in_set. + by move/negP/negP. +- move => Hf. + apply/negPf. + rewrite in_set. + by apply/negP/negP. +Qed. + +Definition runnable_impactedV modified := + [set v in impacted g^-1 modified | runnable (val v)]. + +Definition runnable_impacted := + [seq (val v) | v <- enum (runnable_impactedV modifiedV)]. + +Lemma impactedVP (modified : {set V}) x : + reflect + (exists2 v, v \in modified & connect g^-1 v x) + (x \in impacted g^-1 modified). +Proof. exact: impactedP. Qed. + +Lemma impacted_closure : forall (modified : {set V}), + [set x in closure g modified] = impacted g^-1 modified. +Proof. +move => modified. +apply/eqP. +rewrite eqEsubset. +apply/andP. +split. +- apply/subsetP. + move => x. + rewrite inE /=. + move/closureP => [v Hv] Hc. + apply/impactedVP. + exists v => //. + by apply/connect_rev. +apply/subsetP. +move => x. +move/impactedVP => [v Hv] Hc. +rewrite inE /=. +apply/closureP. +exists v => //. +by move/connect_rev: Hc. +Qed. + +Lemma not_impactedP (modified : {set V}) x : + reflect + (forall v, connect g x v -> v \notin modified) + (x \notin impacted g^-1 modified). +Proof. +apply: (iffP idP). +- move/impactedVP => Hex. + move => v Hc. + apply/negP => Hv. + apply connect_rev in Hc. + case: Hex. + by exists v. +- move => Hc. + apply/negP. + move => Hx. + move/impactedVP: Hx. + move => [v Hv]. + move/connect_rev => /=. + have ->: rel_of_simpl_rel [rel x' y' | g^-1 y' x'] = g by []. + by move/Hc/negP. +Qed. + +Definition impactedVV' modified := [set (val v) | v in impacted g^-1 modified]. + +Lemma impactedVV'_freshV' modified x : + x \in impactedVV' modified -> x \notin freshV'. +Proof. +move => Hx. +rewrite in_set. +apply/negP. +move => HP. +move/negP: HP. +case. +move: Hx. +move/imsetP => [v [Hv Hx]]. +rewrite Hx. +exact: valP. +Qed. + +Definition impactedV' : {set V'} := impactedVV' modifiedV :|: freshV'. + +Definition impacted_fresh : seq V' := enum impactedV'. + +Lemma impactedV'P x : + reflect ((x \in impactedVV' modifiedV /\ x \notin freshV') \/ (x \in freshV' /\ x \notin impactedVV' modifiedV)) + (x \in impactedV'). +Proof. +apply: (iffP idP). +- rewrite in_set. + move/orP. + case => Hx. + * left; split => //. + move: Hx. + exact: impactedVV'_freshV'. + * right; split => //. + apply/negP. + by move/impactedVV'_freshV'/negP. +- case. + * move => [Hx Hf]. + rewrite in_set. + apply/orP. + by left. + * move => [Hx Hf]. + rewrite in_set. + apply/orP. + by right. +Qed. + +Definition runnable_impactedV' := + [set v in impactedV' | runnable v]. + +Definition runnable_impacted_fresh : seq V' := + enum runnable_impactedV'. + +Definition run_impactedV'_cert := + [seq (v, run v) | v <- runnable_impacted_fresh]. + +Lemma run_impactedV'_cert_run v r : + (v,r) \in run_impactedV'_cert -> + runnable v /\ run v == r /\ v \in impactedV'. +Proof. +move/mapP => [v' Hv] Hc. +move: Hc Hv. +case =>->->. +rewrite mem_enum in_set. +move/andP => [Hc Hv]. +by split. +Qed. + +Lemma cert_run_impactedV'_run v r : + runnable v -> + run v == r -> + v \in impactedV' -> + (v,r) \in run_impactedV'_cert. +Proof. +move => Hc Hv Hi. +apply/mapP. +exists v; last by move/eqP: Hv=><-. +rewrite mem_enum in_set. +apply/andP. +by split. +Qed. + +Lemma run_impactedV'_certP v r : + reflect + (runnable v /\ run v == r /\ v \in impactedV') + ((v,r) \in run_impactedV'_cert). +Proof. +apply: (iffP idP). +- exact: run_impactedV'_cert_run. +- move => [Hc [Hv Hi]]. + exact: cert_run_impactedV'_run. +Qed. + +Lemma run_impactedV'_cert_uniq : + uniq [seq vr.1 | vr <- run_impactedV'_cert]. +Proof. +rewrite map_inj_in_uniq. +- rewrite map_inj_uniq; first by rewrite enum_uniq. + by move => x y; case. +- case => v1 r1. + case => v2 r2. + move => H1 H2 /= Heq. + move: Heq H1 H2 =>-<-. + move/mapP => [v1' Hv1' Hc1]. + rewrite mem_enum in Hv1'. + case: Hc1 =><- Hr1. + move/mapP => [v2' Hv2' Hc2]. + rewrite mem_enum in Hv2'. + case: Hc2 =><- Hr2. + by rewrite Hr1 Hr2. +Qed. + +End Checked. + +Section Other. + +Variable A : eqType. +Variable V' : finType. +Variable f' : V' -> A. +Variable P : pred V'. +Local Notation V := (sig_finType P). +Variable f : V -> A. +Variables (g1 : rel V) (g2 : rel V). +Variable runnable : pred V'. +Variable R : eqType. +Variable run : V' -> R. + +Hypothesis g1_g2_connect : connect g1 =2 connect g2. + +Lemma connect_impactedV_eq modified : + impacted g1^-1 modified = impacted g2^-1 modified. +Proof. +apply/eqP. +rewrite eqEsubset. +apply/andP. +split. +- apply/subsetP. + move => x Hx. + apply: rclosed_impacted; eauto. + apply/impactedP. + move/impactedP: Hx => [v Hv] Hc. + exists v => //. + apply connect_rev. + rewrite -g1_g2_connect. + by apply connect_rev. +- apply/subsetP. + move => x Hx. + apply: rclosed_impacted; eauto. + apply/impactedP. + move/impactedP: Hx => [v Hv] Hc. + exists v => //. + apply connect_rev. + rewrite g1_g2_connect. + by apply connect_rev. +Qed. + +Lemma connect_impactedV'_eq : + impactedV' f' f g1 = impactedV' f' f g2. +Proof. +apply/eqP. +rewrite eqEsubset. +apply/andP. +split. +- apply setSU. + apply/subsetP. + move => x. + move/imsetP => [v Hi] Hv. + apply/imsetP. + exists v; last by []. + by rewrite -connect_impactedV_eq. +- apply setSU. + apply/subsetP. + move => x. + move/imsetP => [v Hi] Hv. + apply/imsetP. + exists v; last by []. + by rewrite connect_impactedV_eq. +Qed. + +Lemma connect_runnable_impactedV' : + runnable_impactedV' f' f g1 runnable = runnable_impactedV' f' f g2 runnable. +Proof. +apply/eqP. +rewrite eqEsubset. +apply/andP. +split. +- apply/subsetP. + move => x. + rewrite in_set. + move/andP => [Hi Hc]. + rewrite in_set. + apply/andP. + split => //. + by rewrite -connect_impactedV'_eq. +- apply/subsetP. + move => x. + rewrite in_set. + move/andP => [Hi Hc]. + rewrite in_set. + apply/andP. + split => //. + by rewrite connect_impactedV'_eq. +Qed. + +End Other. diff --git a/core/run_seq.v b/core/run_seq.v new file mode 100644 index 0000000..1f2c023 --- /dev/null +++ b/core/run_seq.v @@ -0,0 +1,729 @@ +From mathcomp +Require Import all_ssreflect. + +From chip +Require Import extra connect run change acyclic kosaraju topos. + +Set Implicit Arguments. +Unset Strict Implicit. +Unset Printing Implicit Defensive. + +Section CheckedSeq. + +Variable A : eqType. + +Variable V' : finType. + +Variable (f' : V' -> A). + +Variable P : pred V'. + +Local Notation V := (sig_finType P). + +Variable (f : V -> A). + +Variable grev : V -> seq V. + +Variable runnable' : pred V'. + +Variable clos : (V -> seq V) -> seq V -> seq V. + +Hypothesis closP : forall successors (s : seq V) (x : V), + reflect + (exists2 v, v \in s & connect (grel successors) v x) + (x \in clos successors s). + +Hypothesis clos_uniq : forall successors (s : seq V), + uniq s -> uniq (clos successors s). + +Variable ts : forall T : finType, (T -> seq T) -> seq T. + +Hypothesis ts_tsorted : forall (T : finType) (successors : T -> seq T), + tsorted (grel successors) (pred_of_simpl predT) (ts successors). + +Hypothesis ts_all : forall (T : finType) successors (x : T), x \in (ts successors). + +Hypothesis ts_uniq : forall (T : finType) (successors : T -> seq T), uniq (ts successors). + +Definition seq_modifiedV := [seq v <- enum V | f v != f' (val v)]. +Definition seq_impactedV := clos grev seq_modifiedV. + +Definition seq_impactedV' := [seq (val v) | v <- seq_impactedV]. +Definition seq_freshV' := [seq v <- enum V' | ~~ P v]. + +Definition seq_runnable_impacted := [seq v <- seq_impactedV' | runnable' v]. +Definition seq_impacted_fresh := seq_impactedV' ++ seq_freshV'. +Definition seq_runnable_impacted_fresh := [seq v <- seq_impacted_fresh | runnable' v]. + +Variable g : rel V. + +Hypothesis g_grev : [rel x y | g y x] =2 grel grev. + +Lemma seq_modifiedV_eq : + modifiedV f' f =i seq_modifiedV. +Proof. +by move => x; rewrite inE mem_filter mem_enum andb_idr. +Qed. + +Lemma seq_freshV'_eq : + freshV' P =i seq_freshV'. +Proof. +move => x. +rewrite -sub_freshV'. +rewrite mem_filter. +rewrite mem_enum /=. +rewrite andb_idr //. +have H_sp := (insubP [subType of V] x). +destruct H_sp; last by rewrite insubN. +by rewrite i insubT. +Qed. + +Lemma seq_impactedV'_eq : + impactedVV' g (modifiedV f' f) =i seq_impactedV'. +Proof. +move => x. +apply/imsetP. +case: ifP. +- move/mapP => [y Hy] Hx. + move: Hy. + move/(closP grev) => [v Hv] Hc. + move: Hv. + rewrite -seq_modifiedV_eq => Hv. + exists y => //. + apply/impactedVP. + exists v => //. + move/connectP: Hc => [p Hp] Hl. + apply/connectP. + exists p => //. + elim: p v Hp {Hv Hl} => //. + move => v p IH v0. + rewrite /=. + move/andP => [Hv Hp]. + apply/andP. + split; last by apply: IH. + move: Hv. + move: (g_grev v0 v). + by rewrite /= =>->. +- move/negP => Hs. + move => [y Hy] Hxy. + case: Hs. + apply/mapP. + exists y => //. + move/impactedVP: Hy => [v Hv] Hc. + move: Hv; rewrite seq_modifiedV_eq => Hv. + apply/(closP grev). + exists v => //. + move/connectP: Hc => [p Hp] Hl. + apply/connectP. + exists p => //. + elim: p v Hp {Hv Hl} => //. + move => v p IH v0. + rewrite /=. + move/andP => [Hv Hp]. + apply/andP. + split; last by apply: IH. + move: Hv. + move: (g_grev v0 v). + by rewrite /= =>->. +Qed. + +Lemma seq_impacted_fresh_eq : + impactedV' f' f g =i seq_impacted_fresh. +Proof. +move => x. +apply/impactedV'P. +case: ifP. +- rewrite mem_cat. + move/orP. + case. + * rewrite seq_impactedV'_eq => Hv. + left; split => //. + move/mapP: Hv => [v Hv] Hvx. + apply/freshV'P. + move => Hf. + move/negP: (Hf v); case. + by apply/eqP. + * rewrite mem_filter. + move/andP. + move => [Hp Hx]. + right. + split. + + rewrite -sub_freshV'. + have H_sp := (insubP [subType of V] x). + destruct H_sp => //. + by move/negP: Hp. + + apply/imsetP. + case => v Hv Hvx. + move/negP: Hp. + case. + rewrite Hvx. + by apply/valP. +- move => Hx. + case. + * rewrite seq_impactedV'_eq. + move => [Hi Hf]. + move/negP: Hx. + case. + rewrite mem_cat. + apply/orP. + by left. + * move => [Hf Hi]. + move/negP: Hx. + case. + rewrite mem_cat. + apply/orP. + right. + by rewrite -seq_freshV'_eq. +Qed. + +Lemma seq_runnable_impacted_fresh_eq : + runnable_impactedV' f' f g runnable' =i seq_runnable_impacted_fresh. +Proof. +move => x. +rewrite inE. +rewrite mem_filter. +rewrite andbC. +apply andb_id2l => Hc. +by rewrite seq_impacted_fresh_eq. +Qed. + +Lemma seq_modifiedV_uniq : uniq seq_modifiedV. +Proof. by rewrite filter_uniq // enum_uniq. Qed. + +Lemma seq_impacted_fresh_uniq : uniq seq_impacted_fresh. +Proof. +rewrite cat_uniq. +apply/andP; split. +- rewrite map_inj_uniq; last by apply val_inj. + apply clos_uniq. + by apply seq_modifiedV_uniq. +- apply/andP; split; last by rewrite filter_uniq // enum_uniq. + apply/negP. + case. + move/hasP. + move => /= [x Hx] Hm. + move: Hx Hm. + rewrite -seq_freshV'_eq -seq_impactedV'_eq => Hx Hm. + move/negP: Hx; case; apply/negP. + move: Hm. + by apply impactedVV'_freshV'. +Qed. + +Lemma seq_runnable_impacted_fresh_uniq : uniq seq_runnable_impacted_fresh. +Proof. +rewrite filter_uniq //. +exact: seq_impacted_fresh_uniq. +Qed. + +(* topological sort of whole graph *) + +Variable g'rev : V' -> seq V'. + +Variable g' : rel V'. + +Hypothesis g'_acyclic : acyclic g'. + +Hypothesis g'_g'rev : [rel x y | g' y x] =2 grel g'rev. + +Definition ts_g'rev := ts g'rev. + +Lemma ts_rev_before : forall (x y : V'), + connect g' x y -> + before ts_g'rev y x. +Proof. +move => x y Hc. +apply: ts_connect_before; eauto. +- exact: ts_all. +- apply: acyclic_rev. + move => z p Hp. + apply/negP. + case => Hcp. + have Hpp: path g' z p. + move: p z Hp {Hcp}. + elim => //=. + move => v p IH z. + move/andP => [Hz Hp]. + have Hz': grel g'rev v z by []. + move: Hz'. + rewrite -g'_g'rev /= => Hz'. + apply/andP. + split => //. + exact: IH. + move/negP: (g'_acyclic Hpp). + case. + move: Hcp. + rewrite /= 2!rcons_path. + move/andP => [Hcp Hl]. + apply/andP. + have Hz': grel g'rev z (last z p) by []. + move: Hz'. + rewrite -g'_g'rev /= => Hg. + by split. +- apply/connect_rev. + rewrite -(@eq_connect _ g') //. + move => z0 z1. + have ->: (z0 \in g'rev z1) = grel g'rev z1 z0 by []. + by rewrite -g'_g'rev. +Qed. + +Definition ts_g'rev_runnable_imf := + [seq x <- ts_g'rev | x \in seq_runnable_impacted_fresh]. + +Lemma ts_g'rev_runnable_imf_uniq : uniq ts_g'rev_runnable_imf. +Proof. +apply: filter_uniq. +exact: ts_uniq. +Qed. + +Lemma in_ts_g'rev_runnable_imf : + forall x, x \in ts_g'rev_runnable_imf -> + runnable' x /\ x \in impactedV' f' f g. +Proof. +move => x. +rewrite mem_filter. +move/andP => [Hs Hx]. +move: Hs. +rewrite -seq_runnable_impacted_fresh_eq inE. +by move/andP => [Hss Hxx]. +Qed. + +Lemma ts_g'rev_runnable_imf_in : + forall x, runnable' x -> x \in impactedV' f' f g -> + x \in ts_g'rev_runnable_imf. +Proof. +move => x Hc Hx. +rewrite mem_filter. +apply/andP. +split; last by apply ts_all. +rewrite -seq_runnable_impacted_fresh_eq inE. +by apply/andP; split. +Qed. + +Lemma ts_g'rev_runnable_imf_before : forall x y, + y \in impactedV' f' f g -> + runnable' y -> + connect g' x y -> + before ts_g'rev_runnable_imf y x. +Proof. +move => x y Hc Hy Hc'. +apply: before_filter; last by apply: ts_rev_before. +rewrite mem_filter. +apply/andP; split => //. +rewrite -seq_runnable_impacted_fresh_eq inE; first by apply/andP; split. +exact: ts_all. +Qed. + +(* topological sort in subgraph of impacted+fresh vertices *) + +Definition pimf : pred V' := fun v => v \in seq_impacted_fresh. + +Local Notation V'_imf := (sig_finType pimf). + +Local Notation g'_imf := [rel x y : V'_imf | g' (val x) (val y)]. + +Definition g'rev_imf (v : V'_imf) : seq V'_imf := + pmap insub (g'rev (val v)). + +Definition ts_g'rev_imf := ts g'rev_imf. + +Lemma ts_g'rev_imf_all : + forall (x : V'_imf), x \in ts_g'rev_imf. +Proof. move => x. exact: ts_all. Qed. + +Lemma ts_g'rev_imf_uniq : uniq ts_g'rev_imf. +Proof. exact: ts_uniq. Qed. + +Lemma ts_g'rev_imf_before : forall (x y : V'_imf), + connect g'_imf x y -> + before ts_g'rev_imf y x. +Proof. +move => x y Hc. +apply: ts_connect_before; eauto. +- exact: ts_all. +- apply: acyclic_rev. + move => z p Hp. + apply/negP => Hc'. + have Hp': path g' (val z) [seq (val v) | v <- p]. + elim: p z Hp {Hc'} => //=. + move => v p IH z. + move/andP => [Hz Hp]. + move: Hz. + rewrite /g'rev_imf => Hz. + apply/andP. + split; last by apply: IH. + suff Hsuff: grel g'rev (val v) (val z) by rewrite -g'_g'rev in Hsuff. + move: Hz. + rewrite /=. + elim: (g'rev _) => //=. + move => v' l. + rewrite /oapp /= => IH'. + have H_sp := (insubP [subType of V'_imf] v'). + destruct H_sp => //=. + * rewrite insubT. + move/orP. + case. + + move/eqP =>->. + rewrite SubK in_cons. + by apply/orP; left. + + move => Hz. + rewrite in_cons. + apply/orP. + by right; apply: IH'. + * rewrite insubN //. + move/IH' => Hz. + by apply/orP; right. + move/negP: (g'_acyclic Hp'). + case. + move: Hc'. + rewrite /= 2!rcons_path. + move/andP => [Hc' Hl]. + apply/andP. + split => //. + move: Hl. + rewrite /g'rev_imf /= => Hl. + suff Hsuff: grel g'rev (val z) (last (sval z) [seq sval v | v <- p]). + move: Hsuff. + by rewrite -g'_g'rev. + rewrite /=. + move: Hl. + set l := g'rev _. + move: l. + elim: p z {Hp Hp' Hc'} => //=. + * move => z l. + elim: l z => //=. + move => v l IH z. + rewrite /oapp /=. + have H_sp := (insubP [subType of V'_imf] v). + destruct H_sp => //=. + * rewrite insubT. + move/orP. + case. + + move/eqP =>->. + rewrite SubK in_cons. + by apply/orP; left. + + move => Hz. + rewrite in_cons. + apply/orP. + by right; apply: IH. + * rewrite insubN //. + move/IH => Hz. + by apply/orP; right. + * move => v l IH v0 l' Hl. + exact: IH. +- apply: connect_rev. + rewrite -(@eq_connect _ [rel x y | g' (val x) (val y)]) //. + move => x' y' /=. + move: (g'_g'rev (val y') (val x')). + rewrite /= =>->. + rewrite /g'rev_imf /=. + elim: (g'rev _) => //=. + move => v' l0 IH'. + rewrite /oapp /=. + rewrite in_cons IH'. + have H_sp := (insubP [subType of V'_imf] v'). + destruct H_sp; first by rewrite insubT. + rewrite insubN //. + apply/orP. + case: ifP; first by move => Hx; right. + move/negP => Hx. + move => Hs. + case: Hs => //. + move/eqP => Hs. + rewrite -Hs in i. + case/negP: i. + by case: x' {IH' Hx Hs}. +Qed. + +Definition ts_g'rev_imf_runnable := + [seq x <- ts_g'rev_imf | runnable' (val x)]. + +Lemma ts_g'rev_imf_runnable_before : forall x y, + runnable' (val y) -> + connect g'_imf x y -> + before ts_g'rev_imf_runnable y x. +Proof. +move => x y Hy Hc. +apply: before_filter; last by apply: ts_g'rev_imf_before. +rewrite mem_filter. +apply/andP. +by split; last by apply: ts_g'rev_imf_all. +Qed. + +Definition ts_g'rev_imf_runnable_val := + [seq (val x) | x <- ts_g'rev_imf_runnable]. + +Lemma ts_g'rev_imf_runnable_val_uniq : + uniq ts_g'rev_imf_runnable_val. +Proof. +rewrite map_inj_uniq; last by apply val_inj. +apply: filter_uniq. +exact: ts_g'rev_imf_uniq. +Qed. + +Lemma in_ts_g'rev_imf_runnable_val : + forall x, x \in ts_g'rev_imf_runnable_val -> + runnable' x /\ x \in impactedV' f' f g. +Proof. +move => x. +move/mapP => [x' Hx'] Hx. +move: Hx'. +rewrite mem_filter => /andP; move => [Hxc Hxt]. +rewrite Hx; split => //. +rewrite seq_impacted_fresh_eq. +move: Hxt. +by case: x' Hx Hxc. +Qed. + +Lemma ts_g'rev_imf_runnable_val_in : + forall x, runnable' x -> x \in impactedV' f' f g -> + x \in ts_g'rev_imf_runnable_val. +Proof. +move => x Hc. +rewrite seq_impacted_fresh_eq => Hx. +have H_sp := (insubP [subType of V'_imf] x). +destruct H_sp; last by case/negP: i. +apply/mapP. +exists u => //. +rewrite mem_filter. +apply/andP; split; first by rewrite e. +exact: ts_g'rev_imf_all. +Qed. + +(* goal: generate sequence as though we did the topological sort for the whole graph *) + +Local Notation gV' := [rel x y : V' | insub_g g x y]. + +Hypothesis f_equal_g : + forall v, f v = f' (val v) -> forall v', gV' (val v) v' = g' (val v) v'. + +(* Outline: if the path from x to y has any non-impacted, non-fresh vertices, + then those vertices have a path to a modified vertex, and are thus impacted as well *) + +Lemma non_impacted_rel : forall (x : V) y, + val x \notin impactedV' f' f g -> + g' (val x) y -> + y \notin impactedV' f' f g. +Proof. +move => x y. +move/impactedV'P => Hx Hg. +apply/impactedV'P. +move => Hy. +case: Hx. +case: Hy. +- move => [Hy Hy']. + left. + split; last first. + apply/freshV'P => Hv. + move/negP: (Hv x). + by case. + move/imsetP: Hy => [u Hu] Hy. + case Hf: (f x == f' (val x)); last first. + move/negP/negP: Hf => Hf. + apply/imsetP. + exists x => //. + apply/impactedVP. + exists x => //. + by rewrite inE. + move/eqP: Hf => Hf. + move: Hg. + rewrite Hy. + rewrite -(f_equal_g Hf) /=. + have Hg := ginsub_eq g x u. + move: Hg. + rewrite /= =><- Hg. + apply/imsetP. + exists x => //. + move/impactedVP: Hu => [v Hv] Hc. + apply/impactedVP. + exists v => //. + apply/connect_rev. + move/connect_rev: Hc. + rewrite /=. + move/connectP => [p Hp] Hl. + apply/connectP. + exists (u :: p) => //. + rewrite /=. + apply/andP. + by split. +- move => [Hy Hy']. + case Hf: (f x == f' (val x)). + * move/eqP: Hf => Hf. + have Hfg := f_equal_g Hf y. + rewrite /= in Hfg. + move/freshV'P: Hy => Hy. + rewrite Hg in Hfg. + move/negP: Hfg. + case. + rewrite /insub_g /= insubT; first by apply/valP. + move => Hxp. + have H_sp := (insubP [subType of V] y). + destruct H_sp; last by rewrite insubN. + move/negP: (Hy u); case. + by apply/eqP. + * move/negP/negP: Hf => Hf. + left. + split. + + apply/imsetP. + exists x => //. + apply/impactedVP. + exists x => //. + by rewrite inE. + + apply/freshV'P => Hv. + move/negP: (Hv x). + by case. +Qed. + +Lemma connect_imp : forall x y, + y \in impactedV' f' f g -> + connect g' x y -> + x \in impactedV' f' f g. +Proof. +move => x y Hy. +move/connectP => [p Hp] Hl. +elim: p x Hp Hl => //=; first by move => x Hp <-. +move => v' p IH x. +move/andP => [Hg Hp] Hl. +have IH' := IH _ Hp Hl. +apply/impactedV'P. +rewrite -sub_freshV'. +have H_sp := (insubP [subType of V] x). +destruct H_sp; last first. + right. + split => //. + apply/imsetP. + case => x0 Hx0 Hvx. + case/negP: i. + rewrite Hvx. + apply/valP. +left. +split => //. +move: Hg. +rewrite -e => Hg. +case Hc: (_ \in _) => //. +move/negP/negP: Hc => Hc'. +move/negP: IH'. +case. +apply/negP. +move: Hg. +apply/non_impacted_rel. +apply/impactedV'P. +case. +- move => [Hu Hf]. + move/negP: Hc'. + by case. +- move => [Hu Hf]. + move/freshV'P: Hu => Hu. + move/negP: (Hu u). + by case. +Qed. + +Lemma connect_g'_imf : forall (x y : V'_imf), + connect g' (val x) (val y) -> + connect g'_imf x y. +Proof. +move => x y. +move/connectP => [p Hp] Hl. +have Hx: val x \in impactedV' f' f g. + rewrite seq_impacted_fresh_eq. + by apply/valP. +have Hy: val y \in impactedV' f' f g. + rewrite seq_impacted_fresh_eq. + by apply/valP. +have Hpi: forall z : V', z \in p -> connect g' z (val y). + move: Hp Hl {Hx}. + set vx := val x. + move: p vx => {x}. + elim => //=. + move => v p IH x. + move/andP => [Hg Hp] Hl z. + rewrite in_cons. + move/orP. + case. + - move/eqP =>->. + apply/connectP. + by exists p. + - move => Hz. + by eapply IH; eauto. +have Hpf: forall z : V', z \in p -> z \in seq_impacted_fresh. + move => z Hz. + rewrite -seq_impacted_fresh_eq. + move: (Hpi _ Hz). + exact: connect_imp. +apply/connectP. +exists (pmap insub p); last first. +- move {Hp Hx Hy Hpi}. + elim: p x Hl Hpf => //=; first by move => x; move/val_inj =>->. + move => x p IH x0 Hl Hpf. + rewrite /oapp. + have Hx: x \in seq_impacted_fresh. + apply: Hpf. + rewrite in_cons. + by apply/orP; left. + have H_sp := (insubP [subType of V'_imf] x). + destruct H_sp; last by case/negP: i. + rewrite -e in Hl. + rewrite -e. + rewrite insubT; first by rewrite e. + move => Hp. + rewrite /=. + apply: IH; first by rewrite -Hl. + move => z Hz. + apply: Hpf. + rewrite in_cons. + apply/orP. + by right. +- move {Hl Hy Hpi Hx}. + elim: p x Hp Hpf => //=. + move => v p IH x. + move/andP => [Hg Hp] Hpf. + rewrite /oapp /=. + have Hv: v \in seq_impacted_fresh. + apply: Hpf. + rewrite in_cons. + by apply/orP; left. + have H_sp := (insubP [subType of V'_imf] v). + destruct H_sp; last by case/negP: i. + rewrite -e insubT /=; first by rewrite e. + move => Hu. + apply/andP. + split => //=; first by rewrite e. + apply: IH. + rewrite /sval /=. + case: u e Hu => u Hu Hvu Hpv. + move: Hvu. + by rewrite /= =>->. + move => z Hz. + apply: Hpf. + rewrite in_cons. + by apply/orP; right. +Qed. + +Lemma ts_g'rev_imf_runnable_val_before : forall x y, + x \in impactedV' f' f g -> runnable' x -> + y \in impactedV' f' f g -> runnable' y -> + connect g' x y -> + before ts_g'rev_imf_runnable_val y x. +Proof. +move => x y Hx Hxc Hy Hyc Hc. +have H_sp := (insubP [subType of V'_imf] x). +have H_sp' := (insubP [subType of V'_imf] y). +destruct H_sp; last first. + case/negP: i. + rewrite /pimf. + by rewrite -seq_impacted_fresh_eq. +destruct H_sp'; last first. + case/negP: i0. + rewrite /pimf. + by rewrite -seq_impacted_fresh_eq. +have Hc': connect g' (val u) (val u0). + by rewrite e e0. +apply connect_g'_imf in Hc'. +have Hyc': runnable' (val u0) by rewrite e0. +have Ht := ts_g'rev_imf_runnable_before Hyc' Hc'. +rewrite /before /index. +rewrite 2!find_map /=. +rewrite /preim /=. +by rewrite -e -e0. +Qed. + +End CheckedSeq. diff --git a/core/string.v b/core/string.v new file mode 100644 index 0000000..6e91e96 --- /dev/null +++ b/core/string.v @@ -0,0 +1,36 @@ +From mathcomp +Require Import all_ssreflect. +Require Import Ascii String. + +Definition eq_ascii (a a' : ascii) := nat_of_ascii a == nat_of_ascii a'. + +Lemma eq_asciiP : Equality.axiom eq_ascii. +Proof. +move => x y; apply: (iffP idP); last by move =>->; apply/eqP. +move/eqP; rewrite -{2}(ascii_nat_embedding x); move =>->. +by rewrite ascii_nat_embedding. +Qed. + +Definition ascii_eqMixin := EqMixin eq_asciiP. +Canonical ascii_eqType := Eval hnf in EqType ascii ascii_eqMixin. + +Fixpoint seq_of_string s := +if s is String c s' then c :: seq_of_string s' else [::]. + +Fixpoint string_of_seq s := +if s is c :: s' then String c (string_of_seq s') else EmptyString. + +Lemma seq_of_stringK : cancel seq_of_string string_of_seq. +Proof. by elim=> [|c s /= ->]. Qed. + +Definition eq_string (s s' : string) := seq_of_string s == seq_of_string s'. + +Lemma eq_stringP : Equality.axiom eq_string. +Proof. +move => x y; apply: (iffP idP); last by move =>->; apply/eqP. +move/eqP; rewrite -{2}(seq_of_stringK x); move =>->. +by rewrite seq_of_stringK. +Qed. + +Definition string_eqMixin := EqMixin eq_stringP. +Canonical string_eqType := Eval hnf in EqType string string_eqMixin. diff --git a/core/tarjan.v b/core/tarjan.v new file mode 100644 index 0000000..a794847 --- /dev/null +++ b/core/tarjan.v @@ -0,0 +1,922 @@ +From mathcomp +Require Import ssreflect ssrfun ssrbool eqtype ssrnat seq choice fintype tuple. +From mathcomp +Require Import bigop finset finfun perm fingraph path div. + +Set Implicit Arguments. +Unset Strict Implicit. +Unset Printing Implicit Defensive. + +Section extra_div. + +Lemma ltn_div2r p m n : p > 0 -> m %/ p < n %/ p -> m < n. +Proof. +move=> p_gt0 lt_div; rewrite (divn_eq m p) (divn_eq n p). +rewrite -(subnKC lt_div) mulnDl mulSn -!addnA addnCA ltn_add2l. +by rewrite (leq_trans (ltn_pmod _ _)) // leq_addr. +Qed. + +Lemma ltn_mod2r p m n : p > 0 -> m %/ p = n %/ p -> m %% p < n %% p -> m < n. +Proof. +move=> p_gt0 eq_div lt_mod; rewrite (divn_eq m p) (divn_eq n p). +by rewrite {}eq_div ltn_add2l in lt_mod *. +Qed. + +End extra_div. + +Section extra_seq. + +Lemma drop_subseq (T : eqType) n (s : seq T) : subseq (drop n s) s. +Proof. by rewrite -[X in subseq _ X](cat_take_drop n) suffix_subseq. Qed. + +Lemma uniq_catLR (T : eqType) (x : T) s1 s2 : uniq (s1 ++ s2) -> + x \in s1 ++ s2 -> (x \in s1) = (x \notin s2). +Proof. +rewrite mem_cat=> s_uniq /orP[] x_in; move: s_uniq. + by rewrite uniq_catC cat_uniq => /and3P[_ /hasPn /(_ _ x_in)->]. +by rewrite cat_uniq => /and3P[_ /hasPn /(_ _ x_in) /= /negPf->]; rewrite x_in. +Qed. + +Lemma uniq_catRL (T : eqType) (x : T) s1 s2 : uniq (s1 ++ s2) -> + x \in s1 ++ s2 -> uniq (s1 ++ s2) -> (x \in s2) = (x \notin s1). +Proof. +rewrite mem_cat uniq_catC => s_uniq x_s. +by rewrite (uniq_catLR s_uniq) // mem_cat orbC. +Qed. + +End extra_seq. + +Section extra_finset. + +Lemma subset_bigcup (T: finType) (sccs sccs' : {set {set T}}) : + sccs \subset sccs' -> cover sccs \subset cover sccs'. +Proof. +move=> /subsetP subsccs; apply/subsetP=> x /bigcupP [scc /subsccs]. +by move=> scc' x_in; apply/bigcupP; exists scc. +Qed. + +End extra_finset. + +Section tarjan. + +Variable (V : finType) (successors : V -> seq V). +Notation edge := (grel successors). +Notation gconnect := (connect edge). +Notation infty := #|V|. + +(*************************************************) +(* Connected components of the graph, abstractly *) +(*************************************************) + +Notation gbiconnect := [rel x y | gconnect x y && gconnect y x]. + +Lemma gbiconnect_equiv : equivalence_rel gbiconnect. +Proof. +split; first by rewrite /gbiconnect /= connect0. +move=> /andP [xy yx]; rewrite /gbiconnect /=. +by apply/idP/idP => /andP [/(connect_trans _)-> // /connect_trans->]. +Qed. + +Definition gsccs := equivalence_partition gbiconnect setT. + +Lemma gsccs_partition : partition gsccs setT. +Proof. by apply: equivalence_partitionP => ?*; apply: gbiconnect_equiv. Qed. + +Definition cover_gsccs := cover_partition gsccs_partition. + +Lemma trivIset_gsccs : trivIset gsccs. +Proof. by case/and3P: gsccs_partition. Qed. +Hint Resolve trivIset_gsccs. + +Notation scc_of := (pblock gsccs). + +Lemma mem_scc x y : x \in scc_of y = gbiconnect y x. +Proof. +by rewrite pblock_equivalence_partition // => ?*; apply: gbiconnect_equiv. +Qed. + +Definition def_scc scc x := @def_pblock _ _ scc x trivIset_gsccs. + +Definition is_subscc (A : {set V}) := A != set0 /\ {in A &, forall x y, gconnect x y}. + +Lemma is_subscc_in_scc (A : {set V}) : + is_subscc A -> exists2 scc, scc \in gsccs & A \subset scc. +Proof. +move=> []; have [->|[x xA]] := set_0Vmem A; first by rewrite eqxx. +move=> AN0 A_sub; exists (scc_of x); first by rewrite pblock_mem ?cover_gsccs. +by apply/subsetP => y yA; rewrite mem_scc /= !A_sub //. +Qed. + +Lemma is_subscc1 x (A : {set V}) : x \in A -> + (forall y, y \in A -> gconnect x y /\ gconnect y x) -> is_subscc A. +Proof. +move=> xA AP; split; first by apply: contraTneq xA => ->; rewrite inE. +by move=> y z /AP [xy yx] /AP [xz zx]; rewrite (connect_trans yx). +Qed. + +(**********************************************************) +(* Tarjan 72 algorithm, *) +(* rewritten in a functional style by JJ Levy & Ran Chen *) +(**********************************************************) + +Definition split_after (T :eqType) (x : T) (s : seq T) := + let i := index x s in (rcons (take i s) x, drop i.+1 s). + +Fixpoint rank (x : V) stack : nat := + if stack isn't y :: s then infty + else if (x == y) && (x \notin s) then size s else rank x s. + +Record env := Env {blacks : {set V}; stack : seq V; sccs : {set {set V}}}. +Definition grays (e : env) := [set x in stack e] :\: blacks e. +Definition whites (e : env) := ~: (grays e :|: blacks e). + +Definition add_stack x e := Env (blacks e) (x :: stack e) (sccs e). +Definition add_blacks x e := Env (x |: blacks e) (stack e) (sccs e). +Definition add_sccs x e := let (s2, s3) := split_after x (stack e) in + Env (x |: blacks e) s3 ([set y in s2] |: sccs e). + +Definition dfs1 (dfs' : {set V} -> env -> nat * env) (x : V) e := + let m := rank x (x :: stack e) in + let: (m1, e1) := dfs' [set y in successors x] (add_stack x e) in + if m1 >= m then (infty, add_sccs x e1) else (m1, add_blacks x e1). + +Definition dfs' dfs1 dfs' (roots : {set V}) e := + if [pick x in roots] isn't Some x then (infty, e) + else let roots' := roots :\ x in + let: (m1, e1) := + if x \in stack e then (rank x (stack e), e) + else if x \in blacks e then (infty, e) + else dfs1 x e in + let: (m2, e2) := dfs' roots' e1 in (minn m1 m2, e2). + +Fixpoint tarjan_rec n : {set V} -> env -> nat * env := + if n is n.+1 then dfs' (dfs1 (tarjan_rec n)) (tarjan_rec n) + else fun r e => (infty, e). + +Let N := #|V| * #|V|.+1 + #|V|. +Definition e0 := (Env set0 [::] set0). +Definition tarjan := sccs (tarjan_rec N setT e0).2. + +(**************************************************************) +(* Well formed environements and operations on environements. *) +(**************************************************************) + +Inductive wf_env e := WfEnv { + wf_stack : [set x in stack e] = + grays e :|: (blacks e :\: cover (sccs e)); + wf_sccs : cover (sccs e) \subset blacks e; + wf_stack_uniq : uniq (stack e) +}. + +Inductive color_spec x e : bool -> bool -> bool -> bool -> bool -> Type := +| ColorGray of x \in grays e : color_spec x e false true false true false +| ColorSccs of x \in cover (sccs e) : + color_spec x e true false true false false +| ColorWhite of x \in whites e : color_spec x e false false false false true +| ColorBlackStack of x \in blacks e & x \in stack e : + color_spec x e true true false false false. + +Lemma colorP x e : wf_env e -> + color_spec x e (x \in blacks e) (x \in stack e) + (x \in cover (sccs e)) + (x \in grays e) (x \in whites e). +Proof. +move=> [/setP /(_ x) s_def] /subsetP /(_ x) /implyP. +move: s_def; rewrite /grays /whites !inE. +case x_black: (_ \in blacks _) => /=; +case x_stack : (_ \in stack _) => /=; +case x_sccs : (_ \in cover _) => //=; do ?by constructor. + by constructor=> //; rewrite /grays !inE x_black. +by constructor; rewrite /whites !inE x_black x_stack. +Qed. + +Lemma grays0 : grays e0 = set0. +Proof. by apply/setP=> x; rewrite !inE /=. Qed. + +Lemma cover0 : cover set0 = set0 :> {set V}. +Proof. +by apply/setP=> x; rewrite !inE; apply/negP=> /bigcupP[?]; rewrite inE. +Qed. + +Lemma whites_blacksF x e : x \in whites e -> x \in blacks e = false. +Proof. by rewrite !inE; case: (x \in blacks _). Qed. + +Lemma whites_stackF x e : x \in whites e -> x \in stack e = false. +Proof. by rewrite !inE andbC; case: (x \in stack _); rewrite //= orNb. Qed. + +Lemma whites_graysF x e : x \in whites e -> x \in grays e = false. +Proof. by rewrite !inE andbC; case: (x \in stack _); rewrite //= orNb. Qed. + +Lemma grays_stack x e : x \in grays e -> x \in stack e. +Proof. by rewrite !inE andbC; case: (x \in stack _). Qed. + +Lemma grays_sccsF x e : wf_env e -> x \in grays e -> + x \in cover (sccs e) = false. +Proof. by case/colorP. Qed. + +Lemma sccs_stackF x e : wf_env e -> + x \in cover (sccs e) -> x \in stack e = false. +Proof. by case/colorP. Qed. + +Lemma whites_add_stack x e : whites (add_stack x e) = whites e :\ x. +Proof. +apply/setP=> y; rewrite !inE /=. +by case: (_ \in _) (_ \in _) (_ == _) => [] [] []. +Qed. + +Lemma grays_add_stack x e : x \in whites e -> + grays (add_stack x e) = x |: grays e. +Proof. +move=> x_whites; apply/setP=> y; move: x_whites; rewrite !inE. +by case: eqP => [->|]; case: (_ \in _) (_ \in _)=> [] []. +Qed. + +Lemma stack_add_stack x e : stack (add_stack x e) = x :: stack e. +Proof. by []. Qed. + +Lemma add_stack_ewf x e : x \in whites e -> wf_env e -> wf_env (add_stack x e). +Proof. +move=> x_white [s_def sccs_blacks s_uniq]; split => //=; + last by rewrite whites_stackF. +apply/setP=> y; rewrite !inE. +by have [->|] := altP (y =P x); case: colorP=> //=; case: colorP x_white. +Qed. + +Lemma add_blacks_ewf x e : x \in grays e -> wf_env e -> wf_env (add_blacks x e). +Proof. +move=> x_gray [s_def sccs_blacks s_uniq]; split => //=; last first. + by rewrite subsetU // sccs_blacks orbT. +apply/setP=> y; rewrite !inE. +by have [->|] := altP (y =P x); case: colorP=> //=; case: colorP x_gray. +Qed. + +Hint Resolve wf_stack_uniq. + +Lemma add_sccs_wf x e : + take (index x (stack e)) (stack e) \subset blacks e -> + x \in grays e -> wf_env e -> wf_env (add_sccs x e). +Proof. +move=> /subsetP new_blacks x_gray e_wf. +have [s_def /subsetP sccs_blacks s_uniq] := e_wf. +split => //=; last first. +- by rewrite (subseq_uniq (drop_subseq _ _)). +- apply/subsetP=> y; rewrite !inE. + rewrite /cover bigcup_setU inE big_set1 !inE /= => /orP[|/sccs_blacks->]; + last by rewrite !orbT. + by rewrite mem_rcons !inE; case: eqP => //= _ /new_blacks. +apply/setP=> y; rewrite !inE /cover bigcup_setU inE big_set1 !inE !negb_or. +have [->|neq_xy] //= := altP (y =P x); rewrite ?(andbT, andbF). + case: splitP new_blacks s_uniq => //=; first by rewrite grays_stack. + move=> s1 s2 s1x_blacks s_uniq; rewrite grays_sccsF // andbT. + by rewrite (uniq_catRL s_uniq) // mem_cat mem_rcons mem_head. +case: colorP; rewrite ?(andbT, andbF, orbT, orbF) //=. + by move=> y_sccs; apply: contraTF y_sccs => /mem_drop; case: colorP. +move=> y_blacks; case: splitP s_uniq; first by rewrite grays_stack. +by move=> s1 s2 s_uniq y_in; apply: uniq_catRL. +Qed. + +Lemma grays_add_blacks e x : grays (add_blacks x e) = grays e :\ x. +Proof. by apply/setP=> y; rewrite !inE /= negb_or andbA. Qed. + +Lemma whites_add_blacks e x : whites (add_blacks x e) = whites e :\ x. +Proof. +by apply/setP=> y; rewrite !inE; case: (_ == _) (_ \in _) (_ \in _) => [] []. +Qed. + +Lemma grays_add_sccs e x : + let s := take (index x (stack e)) (stack e) in + uniq (stack e) -> s \subset blacks e -> x \in grays e -> + grays (add_sccs x e) = grays e :\ x. +Proof. +move=> /= se_uniq sb x_gray; rewrite /add_sccs /grays /=. +case: splitP sb se_uniq; first by rewrite grays_stack. +move=> s s' sb sxs'_uniq. +apply/setP=> y; rewrite !inE mem_cat mem_rcons in_cons. +have [->|] //= := altP eqP; rewrite orbC ![(y \notin _) && _]andbC. +have [|yNs' neq_yx] //= := boolP (y \in s'). +by have [y_s|] //= := boolP (y \in s); rewrite (subsetP sb). +Qed. + +Lemma whites_add_sccs e x : + let s := take (index x (stack e)) (stack e) in + x \in grays e -> uniq (stack e) -> s \subset blacks e -> + whites (add_sccs x e) = whites e. +Proof. +move=> /= x_gray se_uniq sb; rewrite /whites grays_add_sccs //=. +by rewrite setUCA setUA setD1K. +Qed. + +Lemma blacks_add_sccs e x : blacks (add_sccs x e) = x |: blacks e. +Proof. by []. Qed. + +Lemma sccs_add_sccs e x : + let s := take (index x (stack e)) (stack e) in + sccs (add_sccs x e) = [set y in rcons s x] |: sccs e. +Proof. by []. Qed. + +Lemma stack_add_sccs e x : + let s := drop (index x (stack e)).+1 (stack e) in + stack (add_sccs x e) = s. +Proof. by []. Qed. + +(***************) +(* Rank Theory *) +(***************) + +Lemma rankE x stack : + rank x stack = if x \in stack then index x (rev stack) else infty. +Proof. +elim: stack => [|a s /= ->] //. +have [->|neq_xa] /= := altP eqP; rewrite rev_cons -cats1. + by rewrite mem_head index_cat mem_rev /= eqxx addn0 size_rev; case: in_mem. +by rewrite in_cons (negPf neq_xa) /= index_cat /= mem_rev; case: in_mem. +Qed. + +Lemma rank_cons x y s : rank x (y :: s) = + if (x == y) && (x \notin s) then size s else rank x s. +Proof. by []. Qed. + +Lemma rank_catl x s s' : x \in s' -> rank x (s ++ s') = rank x s'. +Proof. +by move=> x_s; rewrite !rankE rev_cat mem_cat x_s orbT index_cat mem_rev x_s. +Qed. + +Lemma rank_catr x s s' : + x \in s -> x \notin s' -> rank x (s ++ s') = size s' + rank x s. +Proof. +move=> x_s xNs'; rewrite !rankE rev_cat mem_cat x_s /=. +by rewrite index_cat mem_rev (negPf xNs') size_rev. +Qed. + +Lemma rank_small x s : uniq s -> (rank x s < size s) = (x \in s). +Proof. +move=> s_uniq; rewrite rankE; case: (boolP (x \in s)) => [xNs|_]. + by rewrite -size_rev index_mem mem_rev. +apply: negbTE; rewrite -ltnNge ltnS cardE uniq_leq_size //. +by move=> y; rewrite mem_enum. +Qed. + +Arguments rank : simpl never. + +Lemma rank_le x (s : seq V) : uniq s -> rank x s <= infty. +Proof. +move=> s_uniq; rewrite rankE; case: ifP => // x_s. +by rewrite (leq_trans (index_size _ _)) ?size_rev -?(card_uniqP _) // max_card. +Qed. + +Lemma rank_lt x (s : seq V) : uniq s -> (rank x s < infty) = (x \in s). +Proof. +rewrite rankE; case: ifPn; rewrite ?ltnn // => x_s s_uniq. +rewrite (@leq_trans (size (rev s))) ?index_mem ?mem_rev ?size_rev //. +by rewrite -?(card_uniqP _) // max_card. +Qed. + +Lemma rank_infty x (s : seq V) : x \notin s -> rank x s = infty. +Proof. by rewrite rankE => /negPf->. Qed. + +Lemma rank_mem x s : x \in s -> rank x s < size s. +Proof. by move=> x_s; rewrite rankE x_s -size_rev index_mem mem_rev. Qed. + +Lemma rank_le_head s z x : x \notin s -> z \in s -> + rank z (x :: s) < rank x (x :: s). +Proof. +by move=> xNs z_s; rewrite !rank_cons z_s andbF eqxx xNs /= rank_mem. +Qed. + +(********************) +(* Main Proof ! *) +(********************) + +Definition noblack_to_white e := + forall x, x \in blacks e -> [disjoint successors x & whites e]. + +Inductive wf_graph e := WfGraph { + wf_grays_to_stack : {in grays e & stack e, forall x y, + (rank x (stack e) <= rank y (stack e)) -> gconnect x y}; + wf_stack_to_grays : forall y, y \in stack e -> + exists x, [/\ x \in grays e, + (rank x (stack e) <= rank y (stack e)) & gconnect y x] + }. + +Definition access_to e (roots : {set V}) := + (forall x, x \in grays e -> + forall y, y \in roots -> gconnect x y). + +Definition black_gsccs e := [set scc in gsccs | scc \subset blacks e]. + +Inductive pre_dfs (roots : {set V}) (e : env) := PreDfs { + pre_access_to : access_to e roots; + pre_wf_env : wf_env e; + pre_wf_graph : wf_graph e; + wf_noblack_towhite : noblack_to_white e; + pre_sccs : sccs e = black_gsccs e; +}. + +Lemma add_stack_gwf e w : + access_to e [set w] -> wf_env e -> w \in whites e -> wf_graph e -> + wf_graph (add_stack w e). +Proof. +move=> grays_to e_wf w_white [gs sg]; split. +- rewrite grays_add_stack //= => x y; rewrite rank_cons !inE. + move=> /orP[/eqP->|/andP[xNb xs]] /orP[/eqP->|/=ys]; + rewrite ?rank_cons ?eqxx ?(@whites_stackF w) ?xs ?ys ?(andbF, andbT) //=. + + by rewrite leqNgt rank_small ?wf_stack_uniq // ys. + + by move=> _; rewrite grays_to ?inE //= xNb. + + by apply: gs; rewrite ?inE ?xNb. +- move=> y; rewrite inE => /predU1P [->|]. + exists w; rewrite ?grays_add_stack ?inE ?eqxx //. + by rewrite whites_blacksF ?whites_stackF. + move=> y_stack; have /sg [x [x_gray le_xy y_to_x]] := y_stack. + exists x; split=> //. + by rewrite grays_add_stack // inE x_gray orbT. + rewrite stack_add_stack !rank_cons [x == w]negbTE /= 1?[y == w]negbTE //=. + by apply: contraTneq y_stack => ->; rewrite whites_stackF. + by apply: contraTneq x_gray => ->; rewrite whites_graysF. +Qed. + +Lemma add_stack_pre e w : + access_to e [set w] -> wf_env e -> w \in whites e -> wf_graph e -> + access_to (add_stack w e) [set x in successors w]. +Proof. +move=> grays_to e_wf w_white e_gwf. +move=> x; rewrite grays_add_stack // 2?inE => /predU1P [->|]. + by move=> y; rewrite inE => y_succ_w; rewrite connect1. +move=> /grays_to x_to_y y; rewrite inE => y_succ_w. +by rewrite (connect_trans _ (connect1 y_succ_w)) // x_to_y ?inE. +Qed. + +Definition xedges (new old : seq V) := + [set y in old | [exists x in new, (x \notin old) && edge x y]]. + +Definition rank_of_reachable m x s := + exists2 y, y \in gconnect x & m = rank y s. + +Definition post_dfs (roots : {set V}) (e e' : env) (m : nat) := +[/\ [/\ wf_env e', wf_graph e', noblack_to_white e', + grays e' = grays e & sccs e' = black_gsccs e'], + + [/\ + exists2 s, stack e' = s ++ stack e & s \subset (blacks e'), + blacks e \subset blacks e' & sccs e \subset sccs e' ]& + + [/\ + forall x, x \in roots -> m <= rank x (stack e'), + m = infty \/ exists2 x, x \in roots & rank_of_reachable m x (stack e') & + forall y, y \in xedges (stack e') (stack e) -> m <= rank y (stack e') + ] + ]. + +Definition dfs1_correct (dfs1 : V -> env -> nat * env) x e := + (x \in whites e) -> pre_dfs [set x] e -> + let (m, e') := dfs1 x e in + (x \in blacks e') /\ post_dfs [set x] e e' m. + +Definition dfs'_correct (dfs' : {set V} -> env -> nat * env) roots e := + pre_dfs roots e -> + let (m, e') := dfs' roots e in + roots \subset blacks e' :|: grays e' /\ post_dfs roots e e' m. + +Lemma pre_dfs_subroots (roots roots' : {set V}) e : roots' \subset roots -> + pre_dfs roots e -> pre_dfs roots' e. +Proof. +move=> sub_roots [to_roots e_wf e_gwf black_sccs Nbw]; split=> //. +by move=> x x_gray y y_roots'; rewrite to_roots //; apply: subsetP y_roots'. +Qed. + +Lemma dfs'_is_correct dfs1 dfsrec' (roots : {set V}) e : + (forall x, x \in roots -> dfs1_correct dfs1 x e) -> + (forall x, x \in roots -> forall e1, whites e1 \subset whites e -> + dfs'_correct dfsrec' (roots :\ x) e1) -> + dfs'_correct (dfs' dfs1 dfsrec') roots e. +Proof. +move=> dfs1_is_correct dfs'_is_correct; rewrite /dfs'_correct /dfs'. +case: pickP => [x|no_roots]; last first. + move=> [gto_roots e_wf e_gwf black_sccs]; split=> //. + by apply/subsetP=> x; rewrite !inE no_roots. + split=> //; first by split=> //; first by exists [::] => //; apply/subsetP. + split=> //; first by move=> x; rewrite no_roots. + by left. + by move=> y; rewrite inE => /andP[_ /existsP [x /and3P[->]]]. +move=> x_root; have := dfs'_is_correct _ x_root; rewrite /dfs'_correct. +case: ifPn=> [x_stack|xNstack]. + move=> /(_ _ (subxx _)); case: (dfsrec' _ _) => [m2 e']. + move=> e'_correct [to_roots e_wf e_gwf Nbw black_sccs]. + have e_uniq := wf_stack_uniq e_wf. + case: e'_correct; first exact: (pre_dfs_subroots (subD1set _ _)). + move=> change_color [invariants monotony [pc1 pc2 pc3]]. + split=> //. + - rewrite -(setD1K x_root) subUset change_color sub1set !inE. + have [//|xNblack /=] := boolP (x \in blacks _). + by have [[s ->]] := monotony; rewrite mem_cat x_stack orbT. + split=> //; split=> //. + - move=> y y_root; have [->|neq_yx]:= eqVneq y x; last first. + by rewrite geq_min pc1 ?orbT // !inE neq_yx. + by have [[s -> _ _ _]] := monotony; rewrite rank_catl // geq_min leqnn. + - right; case: (leqP (rank x (stack e)) m2) => [rx_small|/ltnW rx_big]. + rewrite (minn_idPl _) //. + exists x => //; exists x; rewrite ?inE ?connect0 //. + by have [[s ->]] := monotony; rewrite rank_catl. + rewrite (minn_idPr _) //. + case: pc2 rx_big=> [->|[y]]; first by rewrite leqNgt rank_lt ?x_stack. + rewrite !inE => /andP[neq_yx y_roots [z y_to_z m_def]]. + by move=> m_small; exists y => //; exists z. + - by move=> y y_xedge; rewrite (@leq_trans m2) ?pc3 // geq_min leqnn orbT. +case: ifPn=> [x_black|xNblack] //=. + move=> /(_ _ (subxx _)); case: (dfsrec' _ _) => [m2 e']. + move=> e'_correct [to_roots e_wf e_gwf Nbw black_sccs]. + case: e'_correct; first exact: (pre_dfs_subroots (subD1set _ _)). + move=> change_color [[e'_wf e'_gwf keep_gray Nbw' sccs'_black] + [mon1 mon2 mon3] [pc1 pc2 pc3]]. + have e'_uniq := wf_stack_uniq e'_wf. + split=> //. + by rewrite -(setD1K x_root) subUset change_color sub1set !inE (subsetP mon2). + have m2_rank: m2 <= infty by case: pc2=> [->|[?? [??->]]]; rewrite ?rank_le. + split=> //; split=> //. + - move=> y y_root; have [->{y y_root}|neq_yx]:= eqVneq y x; last first. + by rewrite geq_min pc1 ?orbT // !inE neq_yx. + rewrite rank_infty ?geq_min ?leqnn // sccs_stackF //. + by apply: (subsetP (subset_bigcup mon3)); case: colorP x_black xNstack. + - rewrite (minn_idPr _) //; case: pc2 => [->//|]; first by left. + by move=> [y]; rewrite !inE => /andP[_ ?]; right; exists y. + - by move=> y y_xedge; rewrite (@leq_trans m2) ?pc3 // geq_min leqnn orbT. +have := dfs1_is_correct _ x_root; rewrite /dfs1_correct. +case: (dfs1 _ _) => [m1 e1] post_dfs1. +move=> /(_ e1); case: (dfsrec' _ _) => [m2 e2] post_dfs'. +move=> pre {dfs1_is_correct dfs'_is_correct}. +have [e_access_to e_wf e_gwf Nbw sccs_black] := pre. +have e_uniq := wf_stack_uniq e_wf. +have x_white : x \in whites e by case: colorP xNstack xNblack. +have := post_dfs1 x_white (pre_dfs_subroots _ pre). +rewrite sub1set x_root => /(_ isT) {post_dfs1}. +case=> [x_black [[e1_wf e1_gwf Nbw1 keep_gray sccs_e1] + [[s1 s1_def s1b] mo_b1 mo_sccs1] [pc1 pc2 pc3]]]. +have e1_uniq := wf_stack_uniq e1_wf. +case: post_dfs'. +- by rewrite subCset setCK setUSS // keep_gray. +- split=> // y; rewrite !inE s1_def mem_cat. + case: (y \in s1) (subsetP s1b y) => //= [->//|_ /andP[yNb ys]]. + move=> z; rewrite inE => /andP[_ z_roots]; rewrite e_access_to //. + by rewrite !inE ys andbT; apply: contraNN yNb; apply/subsetP. +move=> rootsDx_subset [[e2_wf e2_gwf Nbw2 keep_gray2 sccs_e2] + [[s2 s2_def s2b] mo_b2 mo_sccs2] [pc21 pc22 pc23]]. +have e2_uniq := wf_stack_uniq e2_wf. +split. + rewrite -(setD1K x_root) subUset rootsDx_subset andbT sub1set. + by rewrite inE (subsetP mo_b2). +split; first by rewrite keep_gray2 keep_gray. + split. + + exists (s2 ++ s1); first by rewrite s2_def s1_def catA. + apply/subsetP=> y; rewrite mem_cat => /orP [/(subsetP s2b) //|]. + by apply/subsetP/(subset_trans s1b). + + exact/(subset_trans mo_b1). + + exact/(subset_trans mo_sccs1). +have m1_rank: m1 <= infty by case: pc2=> [->|[?? [??->]]]; rewrite ?rank_le. +have m2_rank: m2 <= infty by case: pc22=> [->|[?? [??->]]]; rewrite ?rank_le. +split. +- move=> y y_roots; have [->|neq_yx] := eqVneq y x; last first. + by rewrite (@leq_trans m2) ?geq_minr // pc21 // !inE neq_yx. + have [xs|xNs] := boolP (x \in stack e1). + by rewrite s2_def rank_catl // (@leq_trans m1) ?geq_minl // pc1 ?inE. + have x_sccs2 : x \in cover (sccs e2). + apply: (subsetP (subset_bigcup mo_sccs2)). + by case: colorP xNs x_black. + by rewrite rank_infty ?geq_min ?m1_rank //; case: colorP x_sccs2. +- case: pc22 => [->|m2_reachable]. + + rewrite (minn_idPl _) //; case: pc2=> [->|pc2]; [by left|]. + case: (ltngtP m1 #|V|) => m1_lt //; last by left. + right; exists x => //. + case: pc2=> z; rewrite inE => /eqP -> [t x_to_t m1_def]. + by exists t => //; rewrite s2_def rank_catl // -rank_lt -?m1_def. + by case: (leq_ltn_trans m1_rank m1_lt); rewrite ltnn. + + case: (leqP m1 m2) => [m12|/ltnW m21]; last first. + rewrite (minn_idPr _) //. + case: m2_reachable => y; rewrite !inE => /andP[_ y_root] [z y_to_z m2_def]. + by right; exists y => //; exists z => //. + rewrite (minn_idPl _) //. + case: (ltngtP m1 #|V|) => m1_lt //; last by left. + right; exists x => //; case: pc2=> [m1_infty|[z]]. + by rewrite m1_infty ltnn in m1_lt. + rewrite inE => /eqP -> [t x_to_t m1_def]. + by exists t => //; rewrite s2_def rank_catl // -rank_lt -?m1_def. + by case: (leq_ltn_trans m1_rank m1_lt); rewrite ltnn. +- move=> y. + rewrite !inE => /andP [y_s0 /existsP[z /and3P [z_s2 zNs0 z_to_y]]]. + move: z_s2; rewrite s2_def mem_cat orbC. + have [z_s1 _|/= zNs1 z_s2] := boolP (z \in stack e1). + rewrite rank_catl; last by rewrite s1_def mem_cat y_s0 orbT. + rewrite (@leq_trans m1) ?geq_minl // pc3 // inE y_s0. + by apply/existsP; exists z; rewrite z_s1 zNs0. + rewrite -s2_def (@leq_trans m2) ?geq_minr // pc23 // inE. + rewrite s1_def mem_cat y_s0 orbT /=. + apply/existsP; exists z; rewrite s2_def mem_cat z_s2 /= [X in _ && X]z_to_y. + by rewrite -s1_def zNs1. +Qed. + +Lemma path_xset_xedge x y (s : pred V) : + gconnect x y -> x \in s -> y \notin s -> + exists x' y', [/\ x' \in s, y' \notin s, + gconnect x x', edge x' y' & gconnect y' y]. +Proof. +move=> /connectP [p path_xp ->] xs yNs. +pose n := find (predC s) p. +have hasNs_p : has (predC s) p. + apply/hasP; exists (last x p) => //=. + have := mem_last x p; rewrite in_cons => /predU1P [eq_x|//]. + by rewrite eq_x xs in yNs. +have n_small : n < size p by rewrite -has_find. +exists (nth x (x :: p) n), (nth x p n). +rewrite [_ \notin s](@nth_find _ _ (predC s)) ?(pathP _ _) //. +have [->|n_gt0] := posnP n. + rewrite ?nth0 /= xs connect0; split=> //. + case: p {yNs n hasNs_p n_small} path_xp => //= z p. + by move=> /andP [xz zp]; rewrite (appP connectP idP) //; exists p. +rewrite -{1 2}[n]prednK //= -[_ \in s]negbK. +rewrite [_ \notin s](@before_find _ _ (predC s)) ?prednK //=. +split=> //; apply/connectP. + exists (take n p). + by move: path_xp; rewrite -{1}[p](@cat_take_drop n) cat_path=> /andP[]. + rewrite (last_nth x) size_take n_small. + by case: (n) n_gt0 => //= k _; rewrite nth_take. +exists (drop n.+1 p). + move: path_xp; rewrite -{1}[p](@cat_take_drop n.+1) cat_path=> /andP[_]. + rewrite (last_nth x) /= size_take ltn_neqAle n_small andbT. + by have [->|] := altP eqP; rewrite /= ?drop_size ?nth_take. +rewrite !(last_nth x) size_drop. +move: n_small; rewrite leq_eqVlt => /predU1P[<-|]; rewrite ?subnn //. +case: (size p) => //= - [|k] //; rewrite !ltnS => n_small. +by rewrite subSS subSn // [RHS]/= nth_drop addSn subnKC. +Qed. + +Lemma dfs1_is_correct dfs' (x : V) e : + (dfs'_correct dfs' [set y in successors x] (add_stack x e)) -> + dfs1_correct (dfs1 dfs') x e. +Proof. +rewrite /dfs1 /dfs1_correct /dfs'_correct; case: (dfs' _ _) => m1 e1. +move=> post_dfs'; set m := rank x _. +move=> x_white [access_to_x e_wf e_gwf Nbw black_sccs]. +have e_uniq := wf_stack_uniq e_wf. +case: post_dfs' => //=. + split => //; do?[exact: add_stack_ewf|exact: add_stack_gwf]; last first. + move=> y /Nbw; rewrite whites_add_stack. + rewrite ![[disjoint successors _ & _]]disjoint_sym. + by apply/disjoint_trans/subsetDl. + move=> y; rewrite grays_add_stack // => /setU1P [->|]; last first. + move=> y_gray z; rewrite inE => /(@connect1 _ edge). + by apply/connect_trans/access_to_x; rewrite ?set11. + by move=> z; rewrite inE => /(@connect1 _ edge). +move=> succ_bVg [[e1_wf e1_gwf Nbw1 keep_gray black_sccs1] + [[s/= s_def sb] mo_b mo_sccs] [pc1 pc2 pc3]]. +set s2 := rcons s x. +have e1_uniq := wf_stack_uniq e1_wf. +have xe_uniq : uniq (x :: stack e). + by have := e1_uniq; rewrite s_def cat_uniq => /and3P []. +have x_stack : x \in stack e1 by rewrite s_def mem_cat mem_head orbT. +have x_grays : x \in grays e1 by rewrite keep_gray grays_add_stack ?setU11. +have sx_subscc : is_subscc [set y in rcons s x]. + apply: (@is_subscc1 x); first by rewrite inE mem_rcons mem_head. + move=> y; rewrite !inE mem_rcons in_cons => /predU1P [->//|y_s]; split. + apply: (@wf_grays_to_stack e1) => //; first by rewrite s_def mem_cat y_s. + rewrite s_def rank_catl ?mem_head // rank_catr //=; last first. + by rewrite -(@uniq_catLR _ _ s) ?mem_cat ?y_s // -?s_def //. + rewrite rankE mem_head (leq_trans (index_size _ _)) //. + by rewrite size_rev leq_addr. + have [] := @wf_stack_to_grays _ e1_gwf y; first by rewrite s_def mem_cat y_s. + move=> z [z_gray rank_z] /connect_trans; apply. + rewrite (@wf_grays_to_stack e1) // s_def. + have := z_gray; rewrite !(inE, s_def) mem_cat. + case: (boolP (z \in s)) => [/(subsetP sb)->//|_ /= /andP [_ z_xe]]. + rewrite !rank_catl ?mem_head //. + move: z_xe; rewrite in_cons. + have [->//|neq_zx /= z_s] := altP eqP. + rewrite ltnW // rank_le_head //. + rewrite -(@uniq_catLR _ _ (rcons s x)) ?mem_rcons ?mem_head //. + by rewrite cat_rcons -s_def wf_stack_uniq. + by rewrite mem_cat mem_rcons mem_head. +case: ltnP => [m1_small|m1_big] //=; rewrite !inE eqxx /=; split=> //. + have [x1 rank_x1 x_to_x1] : exists2 x1, + rank x1 (stack e1) = m1 & gconnect x x1. + case: pc2 m1_small => [->|]; first by rewrite /m ltnNge ?rank_le. + move=> [y]; rewrite inE => /(@connect1 _ edge) x_to_y. + move=> [x1 y_to_x1 rank_x1 _]; exists x1 => //. + by rewrite (connect_trans x_to_y). + have [x' [rank_x' x'_gray x_to_x' ]] : exists x', + [/\ rank x' (stack e1) < rank x (stack e1), x' \in grays e1 & gconnect x x']. + move: m1_small; rewrite -{}rank_x1 => rank_x1. + have x1_stack : x1 \in stack e1. + by rewrite -rank_lt ?(leq_trans rank_x1) // rank_le. + have [z [z_gray rank_z y_to_z]] := wf_stack_to_grays e1_gwf x1_stack. + exists z; split=> //; rewrite 2?inE ?z_gray ?andbT. + - rewrite (leq_ltn_trans rank_z) // (leq_trans rank_x1) // /m. + by rewrite s_def rank_catl ?mem_head. + - by rewrite (connect_trans x_to_x1). + have neq_x'x : x' != x by apply: contraTneq rank_x' => ->; rewrite -ltnNge. + split=> //. + - split=> //; first exact: add_blacks_ewf. + + split => //. + move=> y z /=; rewrite grays_add_blacks => y_gray z_stack. + apply: wf_grays_to_stack => //; apply: subsetP y_gray. + by rewrite subD1set. + move=> y /= y_stack; rewrite grays_add_blacks. + have [z] // := wf_stack_to_grays e1_gwf y_stack. + have [->{z} [_ rank_x y_to_x]|] := eqVneq z x; last first. + move=> neq_zx [z_gray rank_z y_to_z]. + by exists z; split=> //; rewrite 2!inE neq_zx. + exists x'; split; rewrite 2?inE ?x'_gray ?andbT //. + - by rewrite (leq_trans _ rank_x) 1?ltnW // {2}s_def rank_catl ?mem_head. + - by rewrite (connect_trans y_to_x). + + move=> y; rewrite !inE whites_add_blacks. + move=> /predU1P [->{y}|y_black]; last first. + apply/pred0P=> z /=; rewrite 2!inE. + have /pred0P /(_ z) /= := Nbw1 _ y_black. + by apply: contraFF=> /and3P[->_->]. + apply/pred0P=> z /=; rewrite 2!inE. + have /subsetP /(_ z) := succ_bVg. + rewrite 2!inE => /implyP. + by case: (_ \in successors _) (_ == _) colorP => [] [] []. + + rewrite grays_add_blacks keep_gray grays_add_stack //. + by rewrite setU1K // whites_graysF. + + rewrite /= black_sccs1; apply/setP=> scc; rewrite !inE /=. + have [scc_gsccs|] //= := boolP (scc \in gsccs). + apply/idP/idP; first by move=> /subset_trans; apply; rewrite subsetU1. + move=> /subsetP scc_sub; apply/subsetP => y y_scc. + have /setU1P [eq_yx|//] := scc_sub y y_scc. + rewrite eq_yx in y_scc. + have x'_scc : (x' \in scc). + rewrite -(def_scc _ y_scc) // mem_scc /= x_to_x' /=. + by rewrite (wf_grays_to_stack e1_gwf) // ltnW. + have /scc_sub := x'_scc. + rewrite !inE (negPf neq_x'x) /=. + by case: colorP x'_gray. + - split=> //=. + + exists (rcons s x); first by rewrite cat_rcons. + apply/subsetP=> y; rewrite !inE mem_rcons in_cons=> /predU1P [->|]. + by rewrite eqxx. + by move=> y_s; rewrite (subsetP sb) ?orbT. + + by rewrite subsetU // mo_b orbT. + - split=> //=. + + move=> y; rewrite inE => /eqP->. + by rewrite s_def rank_catl ?mem_head // ltnW. + + by right; exists x; rewrite ?set11 //; exists x1. + + move=> y; rewrite inE => /andP [y_stack /existsP]. + move=> [z /and3P[z_stack1 zNstack zy]]. + have [eq_zx|neq_zx] := eqVneq z x. + by rewrite pc1 // -eq_zx inE. + apply: pc3; rewrite inE in_cons y_stack orbT /=. + apply/existsP; exists z. + by rewrite z_stack1 in_cons negb_or neq_zx zNstack. +have scc_max : scc_of x \subset [set y in s2]. + apply/subsetP=> y; rewrite inE=> y_sccx; apply: contraTT isT => yNs2. + have xy : gconnect x y. + by have := y_sccx; rewrite mem_scc /= => /andP[]. + have x_s2 : x \in s2 by rewrite mem_rcons mem_head. + have [x' [y' [x'_s2 y'Ns xx' x'y' y'y]]] := path_xset_xedge xy x_s2 yNs2. + apply: contraNN y'Ns => _. + have: y' \in ([set y in stack e1] :|: + (\bigcup_(scc in sccs e1) scc :|: whites e1)). + by rewrite !inE; case: colorP. + rewrite 3!inE => /or3P[]. + - rewrite s_def -cat_rcons mem_cat => /orP[//|y'_stack]. + have xNstack: x \notin stack e. + rewrite -(@uniq_catLR _ x s2) ?mem_cat ?x_s2 //. + by rewrite cat_rcons -s_def wf_stack_uniq. + have x'Nstack: x' \notin stack e. + rewrite -(@uniq_catLR _ x' s2) ?mem_cat ?x'_s2 //. + by rewrite cat_rcons -s_def wf_stack_uniq. + have rank_y': rank y' (x :: stack e) < rank x (x :: stack e). + by rewrite rank_le_head //. + have neq_y'x : y' != x by apply: contraTneq rank_y' => ->; rewrite ltnn. + have [eq_x'x|neq_x'x] := eqVneq x' x. + have := pc1 y'; rewrite inE -eq_x'x => /(_ x'y'). + rewrite leqNgt (leq_trans _ m1_big) // /m. + by rewrite s_def rank_catl ?in_cons ?y'_stack ?orbT. + apply: contraTT rank_y' => y'Ns2; rewrite -leqNgt. + rewrite [rank y' _]rank_cons (negPf neq_y'x) /=. + have := pc3 y'; rewrite inE in_cons y'_stack orbT /=. + rewrite {2}s_def -cat_rcons rank_catl // => /(_ _) /(leq_trans _) -> //. + apply/existsP; exists x'; rewrite s_def -cat_rcons mem_cat x'_s2 /=. + by rewrite in_cons (negPf neq_x'x) /= x'Nstack. + - move=> /bigcupP [scc']. + rewrite black_sccs1 inE => /andP[scc'_gsccs scc'_black]. + move=> /def_scc - /(_ scc'_gsccs) eq_scc'; rewrite -eq_scc' in scc'_black. + have : x \in scc_of y'. + have:= y_sccx; rewrite !mem_scc /= andbC => /andP[yx _]. + by rewrite (connect_trans y'y) //= (connect_trans xx') //= connect1. + by move=> /(subsetP scc'_black); case: colorP x_grays. + - move: x'_s2; rewrite mem_rcons in_cons => /predU1P [eq_x'x|x_s]. + have /subsetP /(_ y') := succ_bVg. + by rewrite 2!inE -eq_x'x => /(_ x'y'); case: colorP. + have /(_ x') := Nbw1; rewrite (subsetP sb) => // /(_ isT). + by move=> /pred0P /(_ y') /=; rewrite [_ \in _]x'y' /= => ->. +have take_s : take (index x (stack e1)) (stack e1) = s. + rewrite s_def index_cat /= eqxx addn0. + rewrite (@uniq_catLR _ _ _ (x :: stack e)) -?s_def ?wf_stack_uniq //. + by rewrite mem_head /= ?s_def take_cat ltnn subnn take0 cats0. +have drop_s : drop (index x (stack e1)).+1 (stack e1) = stack e. + rewrite s_def index_cat /= eqxx addn0. + rewrite (@uniq_catLR _ _ _ (x :: stack e)) -?s_def ?wf_stack_uniq //. + rewrite mem_head /= ?s_def drop_cat ltnNge leqW //. + by rewrite subSn // subnn //= drop0. +have g1Nx : grays e1 :\ x = grays e. + by rewrite keep_gray grays_add_stack // setU1K // whites_graysF. +split=> //. +- split=> //. + + by apply: add_sccs_wf=> //; rewrite take_s //. + + split=> //; rewrite ?grays_add_sccs ?stack_add_sccs ?take_s ?drop_s// ?g1Nx. + exact: wf_grays_to_stack. + exact: wf_stack_to_grays. + + move=> y; rewrite !inE whites_add_sccs ?take_s //. + move=> /predU1P [->|/Nbw1//]; apply/pred0P=> z //=. + rewrite 2!inE; have /subsetP /(_ z) := succ_bVg. + by rewrite 2!inE => /implyP; rewrite -negb_imply orbC => ->. + + by rewrite grays_add_sccs ?take_s ?g1Nx. + + rewrite sccs_add_sccs take_s //=; apply/setP=> scc. + rewrite !inE blacks_add_sccs ?take_s//= black_sccs1 !inE. + have x_s2 : x \in [set y in s2] by rewrite inE mem_rcons mem_head. + have s2_gsccs : [set y in rcons s x] \in gsccs. + apply/imsetP => /=; exists x => //. + rewrite -[RHS](@def_scc _ x); last 2 first. + * by apply/imsetP; exists x. + * by rewrite !inE ?connect0. + apply/eqP; rewrite eqEsubset scc_max. + have [scc' scc'_gsccs sub'] := is_subscc_in_scc sx_subscc. + by rewrite (@def_scc scc') ?sub' //; apply: (subsetP sub'). + have [scc_gsccs|] //= := boolP (scc \in gsccs); last first. + by apply: contraNF; rewrite orbF => /eqP->. + apply/idP/idP. + move=> /predU1P [->|]. + apply/subsetP => y; rewrite !inE mem_rcons in_cons. + by case: eqP=> [->|] //= _ => /(subsetP sb). + by move=> /subset_trans; apply; rewrite subsetU1. + have [x_scc|xNscc] := boolP (x \in scc). + by move=> _; rewrite -(def_scc _ x_scc) // (def_scc s2_gsccs) ?eqxx. + rewrite -subDset (setDidPl _); first by move->; rewrite orbT. + by rewrite disjoint_sym (@eq_disjoint1 _ x) // => y; rewrite !inE. +- split=> //. + + rewrite stack_add_sccs drop_s; exists [::] => //. + by apply/subsetP=> y; rewrite inE. + + by rewrite blacks_add_sccs ?take_s// (subset_trans mo_b) ?subsetU1. + + by rewrite sccs_add_sccs take_s (subset_trans mo_sccs) ?subsetU1. +- split=> //; do ?by [left]. + + move=> y; rewrite inE => /eqP->. + by rewrite stack_add_sccs drop_s leqNgt rank_lt ?whites_stackF. + + move=> y; rewrite inE stack_add_sccs drop_s => /andP[_ /existsP]. + by move=> [z /and3P[->]]. +Qed. + +Theorem tarjan_rec_terminates n (roots : {set V}) e : + n >= #|whites e| * #|V|.+1 + #|roots| -> + dfs'_correct (tarjan_rec n) roots e. +Proof. +move=> n_ge; wlog ->: e n roots {n_ge} / roots = set0 => [noroot|]; last first. + have := @dfs'_is_correct (dfs1 (tarjan_rec 0)) (tarjan_rec 0) set0 e. + rewrite /tarjan_rec /dfs'_correct /dfs' /=. + case: n=> [|n /=]; case: pickP => [x|_/=]; rewrite ?inE //; + by apply => ?; rewrite inE. +have [V0|VN0] := posnP #|V|. + have := max_card (mem roots). + by rewrite V0 leqn0 cards_eq0 => /eqP /noroot; apply. +elim: n => [|n IHn] in roots e n_ge *. + move: n_ge; rewrite leqn0 addn_eq0 cards_eq0. + by move=> /andP [_ /eqP/noroot]; apply. +move=> pre; rewrite /dfs'_correct /=. +apply: dfs'_is_correct => //= x x_root. + move=> x_white; apply: dfs1_is_correct => //; apply: IHn. + rewrite whites_add_stack cardsDS ?sub1set // cards1 subn1. + rewrite -ltnS (leq_trans _ n_ge) //. + rewrite (@ltn_div2r #|V|.+1) ?divnMDl ?divn_small ?addn0 ?ltnS ?max_card //=. + by rewrite prednK //; apply/card_gt0P; exists x. +move=> e1 whites_e1; apply: IHn; rewrite -ltnS (leq_trans _ n_ge) //. +have /subset_leq_card := whites_e1. +rewrite leq_eqVlt => /predU1P [->|lt_wh]; last first. + by rewrite (@ltn_div2r #|V|.+1) ?divnMDl ?divn_small ?addn0 ?ltnS ?max_card. +by rewrite ltn_add2l [X in _ < X](cardsD1 x) x_root. +Qed. + +Lemma tarjan_rec_is_correct : + tarjan_rec N setT e0 = (infty, Env setT [::] gsccs). +Proof. +have := @tarjan_rec_terminates N setT e0; rewrite /dfs'_correct. +case: tarjan_rec => [m e] []. +- by rewrite ?leq_add ?leq_mul ?max_card. +- split=> //. + + by move=> x; rewrite grays0 inE. + + by split=> //; rewrite /= ?cover0 ?grays0 ?set0D ?setU0. + + by move=> x; rewrite inE. + + apply/setP=> y; rewrite !inE /= subset0 andbC; case: eqP => //= ->. + by have /and3P [_ _ /negPf->]:= gsccs_partition. +rewrite subTset => /eqP blackse [[[stack_wf _ _] _ _]]. +rewrite grays0 => grayse; rewrite grayse setU0 in blackse. +rewrite /black_gsccs /= blackse => sccse _ [_ minfty _]. +have {sccse}sccse: sccs e = gsccs. + by apply/setP=> scc; rewrite sccse inE subsetT andbT. +have stacke : stack e = [::]. + have := stack_wf; rewrite grayse blackse sccse cover_gsccs set0U setDv. + by case: stack => // x s /setP /(_ x); rewrite !inE eqxx. +congr (_, _); first by case: minfty => // [[x _ [y xy]]]; rewrite stacke. +by case: e blackse sccse stacke {stack_wf grayse minfty} => //= *; congr Env. +Qed. + +Theorem tarjan_correct : tarjan = gsccs. +Proof. by rewrite /tarjan tarjan_rec_is_correct. Qed. + +End tarjan. diff --git a/core/tarjan_acyclic.v b/core/tarjan_acyclic.v new file mode 100644 index 0000000..afa6989 --- /dev/null +++ b/core/tarjan_acyclic.v @@ -0,0 +1,381 @@ +From mathcomp +Require Import all_ssreflect. + +From chip +Require Import connect acyclic tarjan. + +Set Implicit Arguments. +Unset Strict Implicit. +Unset Printing Implicit Defensive. + +(* TODO: prove everything for foldl version *) + +Section SeqSet. + +Variable V : finType. + +Definition enums (s : seq {set V}) := + foldr (fun (s0 : {set V}) => cons (enum s0)) [::] s. + +Definition enums' (s : seq {set V}) := + foldl (fun l (s0 : {set V}) => enum s0 :: l) [::] s. + +Lemma enumsP (s : seq {set V}) l : + reflect + (exists2 scc, scc \in s & enum scc = l) + (l \in enums s). +Proof. +apply/(iffP idP). +- rewrite /enums. + move => Hsc. + suff Hsuff: exists2 scc, scc \in enum s & enum scc = l. + move: Hsuff => [scc Hsc'] He. + move: Hsc'. + rewrite mem_enum => Hsc'. + by exists scc. + move: Hsc. + elim: s => //=. + move => s0 l0 IH. + rewrite in_cons. + move/orP. + case. + * move/eqP =>->. + exists s0 => //=. + rewrite mem_enum. + rewrite in_cons. + apply/orP. + by left. + * move/IH => [scc Hs] He. + exists scc => //=. + rewrite mem_enum in_cons. + apply/orP. + right. + by rewrite -mem_enum. +- move => [scc Hscc] He. + move: He Hscc =><-. + rewrite /enums /= => Hsc. + have Hsc': scc \in enum s by rewrite mem_enum. + move: Hsc'. + elim: s {Hsc}; first by rewrite mem_enum. + move => s0 l0 IH. + rewrite mem_enum in_cons. + move/orP. + case. + * move/eqP =>->. + rewrite inE. + by apply/orP; left. + * rewrite -mem_enum. + move/IH => Hl. + by apply/orP; right. +Qed. + +Lemma enums_enums'_in s : + enums s =i enums' s. +Proof. +rewrite /enums /enums'. +have {2}->: s = rev (rev s) by rewrite revK. +rewrite foldl_rev => s0. +apply/enumsP. +case: ifP. +- move/enumsP => [scc Hsc] He. + exists scc => //. + move: Hsc. + by rewrite mem_rev. +- move/enumsP. + move => He. + case => x Hx Hex. + case: He. + exists x => //. + by rewrite mem_rev. +Qed. + +Lemma enums'P (s : seq {set V}) l : + reflect + (exists2 scc, scc \in s & enum scc = l) + (l \in enums' s). +Proof. +apply/(iffP idP). +- rewrite -enums_enums'_in. + by move/enumsP. +- move/enumsP. + by rewrite -enums_enums'_in. +Qed. + +Lemma uniq_enums l : + uniq l -> + uniq (enums l). +Proof. +elim: l => //=. +move => s l IH. +move/andP => [Hs Hl]. +apply/andP. +split; last by apply: IH. +apply/negP => Hen. +move/negP: Hs. +case. +move: Hen. +elim: l {IH Hl} => //=. +move => s0 l IH. +rewrite in_cons. +move/orP. +case. +- move/eqP => Hs. + suff Hsuff: s = s0. + rewrite in_cons. + apply/orP; left. + by apply/eqP. + apply/setP. + move => x. + by rewrite -mem_enum Hs mem_enum. +- move => He. + rewrite in_cons. + apply/orP. + right. + exact: IH. +Qed. + +Lemma in_uniq_enums l : + uniq l -> + forall l0, l0 \in (enums l) -> uniq l0. +Proof. +elim: l => //=. +move => a l IH. +move/andP => [Ha Hl] l0. +rewrite in_cons. +move/orP. +case => //. +- move/eqP =>->. + exact: enum_uniq. +- move => Hla. + exact: IH. +Qed. + +Lemma uniq_flatten : forall l, + (forall a, a \in l -> uniq a) -> + uniq l -> + {in l &, forall A B : seq V, A != B -> [disjoint A & B]} -> + uniq (flatten l). +Proof. +elim => //=. +move => a l IH Ha. +move/andP => [Hal Hul] Hd. +rewrite cat_uniq. +apply/and3P. +split. +- apply: Ha. + by rewrite in_cons; apply/orP; left. +- apply/negP => Hm. + move/hasP: Hm => [x Hx] /= Ha'. + move/flattenP: Hx. + move => [y Hy] Hxy. + have Hla: a \in a :: l by rewrite in_cons; apply/orP; left. + have Hly: y \in a :: l by rewrite in_cons; apply/orP; right. + have Hn: a != y. + apply/negP => Hn. + move/eqP: Hn => Hn. + move: Hn Hal =>->. + move/negP. + by case. + have Hd' := Hd a y Hla Hly Hn. + move: Hd'. + rewrite disjoint_subset. + move/subsetP => Hd'. + move/negP: (Hd' _ Ha'). + by case. +- apply: IH => //. + move => a0 Hl. + apply: Ha. + by rewrite in_cons; apply/orP; right. +- move => a' a0 Ha' Ha0 Hneq. + apply: Hd => //. + * by rewrite in_cons; apply/orP; right. + * by rewrite in_cons; apply/orP; right. +Qed. + +Variable sc : {set {set V}}. + +Hypothesis all_in_cover : forall v : V, v \in cover sc. + +Lemma cover_all_in : + forall v : V, v \in flatten (enums (enum sc)). +Proof. +move => v. +apply/flattenP. +move/bigcupP: (all_in_cover v). +move => [s' Hv] Hs. +exists (enum s'); last by rewrite mem_enum. +apply/enumsP. +exists s' => //. +by rewrite mem_enum. +Qed. + +Hypothesis trivIset_sc : trivIset sc. + +Lemma in_enums_disjoint : + forall l l', l \in enums (enum sc) -> l' \in enums (enum sc) -> + l != l' -> [disjoint l & l']. +Proof. +move/trivIsetP: trivIset_sc => Ht. +move => l l'. +move/enumsP => [s Hs] He. +move/enumsP => [s' Hs'] He' Hl. +move: Hs. +rewrite mem_enum. +move/(Ht s s') => Hts. +move: Hs'. +rewrite mem_enum. +move/Hts. +have Hs: s != s'. + apply/negP => Hs. + move/eqP: Hs => Hs. + move/negP: Hl. + case. + rewrite -He -He'. + by rewrite Hs. +move => Hd. +move/Hd: Hs. +rewrite -He -He' /=. +rewrite 2!disjoint_subset. +move/subsetP => Hs. +apply/subsetP. +move => x. +rewrite mem_enum. +move/Hs. +rewrite /predC /=. +rewrite 2!inE. +by rewrite mem_enum. +Qed. + +End SeqSet. + +Section TarjanSeq. + +Variable V : finType. + +Variable successors : V -> seq V. + +Definition tarjans := enums (enum (tarjan successors)). + +Definition tarjans' := enums' (enum (tarjan successors)). + +Lemma tarjansP sccl : + reflect + (exists2 scc, scc \in tarjan successors & enum scc = sccl) + (sccl \in tarjans). +Proof. +apply/(iffP idP). +- move/enumsP => [scc Hsc] He. + exists scc => //. + by rewrite -mem_enum. +- move => [scc Hsc] He. + apply/enumsP. + exists scc => //. + by rewrite mem_enum. +Qed. + +End TarjanSeq. + +Section TarjanAcyclic. + +Variable V : finType. +Variable g : rel V. + +Lemma trivIset_tarjan : + trivIset (tarjan (rgraph g)). +Proof. +rewrite tarjan_correct. +exact: trivIset_gsccs. +Qed. + +Lemma class_diconnected_tarjan : + forall c, c \in tarjan (rgraph g) -> + exists x, forall y, (y \in c) = diconnect g x y. +Proof. +move => c. +rewrite tarjan_correct. +rewrite /gsccs /=. +rewrite /equivalence_partition /=. +move/imsetP => [x Hx] Hc. +exists x. +move => y. +rewrite Hc inE. +rewrite andb_idl //. +set g' : rel V := grel (rgraph g). +rewrite -(@eq_diconnect _ g') //. +move => v1 v2. +rewrite /g' /=. +by rewrite mem_enum. +Qed. + +Lemma class_diconnected_tarjans : + forall c, c \in tarjans (rgraph g) -> + exists x, forall y, (y \in c) = diconnect g x y. +Proof. +move => c. +move/tarjansP => [scc Hsc]. +move =><-. +move/class_diconnected_tarjan: Hsc. +move => [x Hy]. +exists x. +move => y. +by rewrite mem_enum. +Qed. + +Lemma cover_tarjan : cover (tarjan (rgraph g)) = [set: V]. +Proof. +rewrite tarjan_correct. +by rewrite cover_gsccs. +Qed. + +Lemma all_in_cover_tarjan : forall v : V, v \in cover (tarjan (rgraph g)). +Proof. +by move => v; rewrite tarjan_correct cover_gsccs. +Qed. + +Lemma all_in_flatten_tarjans : forall v : V, v \in flatten (tarjans (rgraph g)). +Proof. +apply: cover_all_in. +exact: all_in_cover_tarjan. +Qed. + +Lemma enum_tarjan_non_empty : set0 \notin enum (tarjan (rgraph g)). +Proof. +have Hp := gsccs_partition (rgraph g). +rewrite tarjan_correct. +rewrite /partition in Hp. +move/and3P: Hp. +case => Hc Ht Hs. +by rewrite mem_enum. +Qed. + +Lemma uniq_in_tarjans : +forall a, a \in tarjans (rgraph g) -> uniq a. +Proof. +apply: in_uniq_enums. +exact: enum_uniq. +Qed. + +Lemma uniq_flatten_tarjans : uniq (flatten (tarjans (rgraph g))). +Proof. +apply: uniq_flatten. +- move => a Ht. + exact: uniq_in_tarjans. +- apply: uniq_enums. + exact: enum_uniq. +- apply: in_enums_disjoint. + exact: trivIset_tarjan. +Qed. + +Definition tarjans_acyclic := + sccs_acyclic (fun g => tarjans (rgraph g)) g. + +Lemma tarjans_acyclicP : + reflect (acyclic g) tarjans_acyclic. +Proof. +apply/sccs_acyclicP. +- exact: uniq_flatten_tarjans. +- exact: all_in_flatten_tarjans. +- exact: class_diconnected_tarjans. +Qed. + +End TarjanAcyclic. diff --git a/core/topos.v b/core/topos.v new file mode 100644 index 0000000..024d5e1 --- /dev/null +++ b/core/topos.v @@ -0,0 +1,223 @@ +From mathcomp +Require Import all_ssreflect. + +From chip +Require Import extra connect kosaraju acyclic. + +Set Implicit Arguments. +Unset Strict Implicit. +Unset Printing Implicit Defensive. + +Section ToposAcyclic. + +Variable V : finType. + +Variable g : rel V. + +Variable ts : seq V. + +Hypothesis ts_tsorted : tsorted g (pred_of_simpl predT) ts. + +Hypothesis ts_all : forall x, x \in ts. + +Hypothesis g_acyclic : acyclic g. + +Lemma ts_nth : forall x y : V, + connect g x y -> + before + ts + (nth x ts (find (diconnect g x) ts)) y. +Proof. +move => x y. +move: (ts_all x). +by apply ts_tsorted. +Qed. + +Lemma acyclic_find_in_diconnect : + forall s x, x \in s -> + nth x s (find (diconnect g x) s) = x. +Proof. +elim => //=. +move => y s IH x. +rewrite in_cons. +move/orP. +case; first by move/eqP =>->; case: ifP => //=; move/negP; case; apply: diconnect0. +case Hx: (x == y). +- move/eqP: Hx =>->. + case: ifP => //. + move/negP; case. + exact: diconnect0. +- move/negP/negP: Hx => Hx Hs. + case: ifP; last by move => Hd; exact: IH. + move => Hd. + move/negP/negP/eqP: Hx. + case. + move: Hd. + exact: acyclic_diconnect. +Qed. + +Lemma ts_connect_before : forall x y : V, + connect g x y -> + before ts x y. +Proof. +move => x y Hc. +move: (ts_nth Hc). +by rewrite acyclic_find_in_diconnect. +Qed. + +End ToposAcyclic. + +Section ToposTseq. + +Variable V : finType. + +Variable successors : V -> seq V. + +Hypothesis g_acyclic : acyclic (grel successors). + +Lemma tseq_sorted : + tsorted (grel successors) (pred_of_simpl predT) (tseq successors). +Proof. by apply tseq_correct'. Qed. + +Lemma tseq_all : + forall x : V, x \in tseq successors. +Proof. by apply tseq_correct'. Qed. + +Lemma pdfs_uniq : forall s l x, + uniq l -> {subset l <= ~: s} -> + uniq (pdfs successors (s,l) x).2. +Proof. +move => s l x. +move => Hu Hs. +have Hus: uniq l /\ {subset l <= ~: s} by []. +have Hpc := pdfs_correct' successors (s,l) x Hus. +rewrite /= in Hpc. +move: Hpc. +set f := pdfs _ _ _. +case: f => s' l'. +case: ifP => //=. +- by move => Hx; case => Hs'; move =>->. +- by move => Hx [[Hs' Hu'] He]. +Qed. + +Lemma pdfs_subset : forall s l s' l' x, + uniq l -> {subset l <= ~: s} -> + pdfs successors (s,l) x = (s', l') -> + {subset l' <= ~: s'}. +Proof. +move => s l s' l' x. +move => Hu Hs Hp. +have Hus: uniq l /\ {subset l <= ~: s} by []. +have Hpc := pdfs_correct' successors (s,l) x Hus. +rewrite /= in Hpc. +move: Hpc. +rewrite Hp. +case: ifP => Hx; first by case =>->->. +move => [Hu' [l2 Hl2]]. +case: Hl2 => Hxl2 Hs' Hl' Hts Hc. +rewrite Hs' Hl'. +move => y. +rewrite mem_cat. +move/orP; case. +- move => Hy. + apply/setCP. + move/setDP => [Hy' Hsy]. + move/negP: Hsy; case. + by rewrite inE. +- move => Hy. + apply/setCP. + case. + move/setDP => [Hy' Hsy]. + by move/setCP: (Hs _ Hy). +Qed. + +Lemma foldr_pdfs_subset : forall l0 (s : {set V}) l s' l', + uniq l -> {subset l <= ~: s} -> + foldr (fun x : V => (pdfs successors)^~ x) (s, l) l0 = (s', l') -> + uniq l' /\ {subset l' <= ~: s'}. +Proof. +elim => //=; first by move => s l' s' l0 Hu Hs; case =><-<-. +move => x l IH s l0 s' l' Hl0 Hs. +set f := foldr _ _ _. +case Hf: f. +have [Hb Ha] := IH _ _ _ _ Hl0 Hs Hf. +have Hu := pdfs_uniq x Hb Ha. +move => Hp. +rewrite Hp /= in Hu. +split => //. +move: Hp. +exact: pdfs_subset. +Qed. + +Lemma tseq_uniq : uniq (tseq successors). +Proof. +rewrite /tseq. +set f := pdfs _. +set l := enum V. +have ->: l = rev (rev l) by rewrite revK. +rewrite foldl_rev. +have Hu: uniq (rev l) by rewrite rev_uniq; apply: enum_uniq. +move: Hu. +set l' := rev l. +move: l' => {l}. +elim => //=. +move => x l IH. +move/andP => [Hx Hul]. +set f' := foldr _ _ _. +case Hf': f'. +have Hue: @uniq V [::] by []. +have Hss: {subset [::] <= ~: [set: V]} by []. +have [Huf Hus] := foldr_pdfs_subset Hue Hss Hf'. +exact: pdfs_uniq. +Qed. + +Lemma tseq_connect_before : forall x y : V, + connect (grel successors) x y -> + before (tseq successors) x y. +Proof. +move => x y. +apply: ts_connect_before => //. +- exact: tseq_sorted. +- exact: tseq_all. +Qed. + +End ToposTseq. + +Section ToposTseqRel. + +Variable V : finType. + +Variable g : rel V. + +Hypothesis g_acyclic : acyclic g. + +Lemma tseq_rgraph_connect_before : forall x y : V, + connect g x y -> + before (tseq (rgraph g)) x y. +Proof. +move => x y Hc. +apply: tseq_connect_before. +- rewrite /acyclic => z p Hp. + apply/negP. + case => Hcp. + have Hpp: path g z p. + move: p z Hp {Hcp}. + elim => //=. + move => z p IH z0. + rewrite {1}/rgraph mem_enum. + move/andP => /= [Hz Hp]. + apply/andP; split => //. + exact: IH. + move/negP: (g_acyclic Hpp). + case. + move: Hcp. + rewrite /= 2!rcons_path /grel /rgraph /= mem_enum. + move/andP => [Hpz Hz]. + by apply/andP; split. +- rewrite /grel /rgraph /=. + erewrite eq_connect; eauto. + move => x' y'. + by rewrite /= mem_enum. +Qed. + +End ToposTseqRel. diff --git a/extraction/impacted-rbt/.gitignore b/extraction/impacted-rbt/.gitignore new file mode 100644 index 0000000..be90463 --- /dev/null +++ b/extraction/impacted-rbt/.gitignore @@ -0,0 +1,5 @@ +ocaml/impacted_rbt.ml +ocaml/impacted_rbt.mli +_build +*.native +gmon.out diff --git a/extraction/impacted-rbt/Makefile b/extraction/impacted-rbt/Makefile new file mode 100644 index 0000000..e1787dd --- /dev/null +++ b/extraction/impacted-rbt/Makefile @@ -0,0 +1,29 @@ +OCAMLBUILD = ocamlbuild -tag safe_string -I ocaml -cflag -g -package extlib +OCAMLBUILD_JSON = $(OCAMLBUILD) -package yojson + +IMPACTEDRBT = ocaml/impacted_rbt.ml ocaml/impacted_rbt.mli +CHANGE = ocaml/util.ml ocaml/change_impact.ml ocaml/change_impact.mli + +default: filtering.native + +filtering.native: $(IMPACTEDRBT) $(CHANGE) ocaml/filtering.ml + perl scripts/remove_module.pl ocaml/impacted_rbt + $(OCAMLBUILD_JSON) filtering.native + +topfiltering.native: $(IMPACTEDRBT) $(CHANGE) ocaml/topfiltering.ml + perl scripts/remove_module.pl ocaml/impacted_rbt + $(OCAMLBUILD_JSON) topfiltering.native + +filteringinv.native: $(IMPACTEDRBT) $(CHANGE) ocaml/filteringinv.ml + perl scripts/remove_module.pl ocaml/impacted_rbt + $(OCAMLBUILD_JSON) filteringinv.native + +$(IMPACTEDRBT): + +$(MAKE) -C ../.. extraction/impacted-rbt/$@ + +clean: + $(OCAMLBUILD) -clean + +.PHONY: default clean $(IMPACTEDRBT) + +.NOTPARALLEL: $(IMPACTEDRBT) diff --git a/extraction/impacted-rbt/coq/extract_impacted_rbt.v b/extraction/impacted-rbt/coq/extract_impacted_rbt.v new file mode 100644 index 0000000..a865d85 --- /dev/null +++ b/extraction/impacted-rbt/coq/extract_impacted_rbt.v @@ -0,0 +1,33 @@ +From mathcomp +Require Import all_ssreflect. +From chip +Require Import string dfs_set finn_set. + +Require Import ExtrOcamlBasic. +Require Import ExtrOcamlNatInt. +Require Import ExtrOcamlString. + +Extract Inlined Constant negb => "not". +Extract Inlined Constant app => "ExtLib.List.append". +Extract Inlined Constant fst => "fst". +Extract Inlined Constant snd => "snd". +Extract Inlined Constant List.rev_append => "ExtLib.List.rev_append". + +Extract Inlined Constant eqn => "(=)". +Extract Inlined Constant leq => "(<=)". +Extract Inlined Constant filter => "ExtLib.List.filter". +Extract Inlined Constant cat => "ExtLib.List.append". +Extract Inlined Constant map => "ExtLib.List.map". +Extract Inlined Constant foldl => "ExtLib.List.fold_left". +Extract Inlined Constant foldr => "(fun a b c -> ExtLib.List.fold_right a c b)". +Extract Inlined Constant size => "ExtLib.List.length". +Extract Inlined Constant nth => "(fun e l n -> match ExtLib.List.nth_opt l n with None -> e | Some e' -> e')". + +Extract Inlined Constant eq_string => "(=)". +Extract Inlined Constant subltn => "(fun _ _ -> (<))". + +Extract Constant SetDef.pred_of_set => "fun t a -> Obj.magic (FunFinfun.fun_of_fin t ((set_subType t).val0 (Obj.magic a)))". + +Extract Constant fintype.Finite.base2 => "fun c -> { Countable.base = c.base; Countable.mixin = (Obj.magic mixin_base __ c.mixin) }". + +Extraction "extraction/impacted-rbt/ocaml/impacted_rbt.ml" set_subType OrdinalsRunnableImpacted. diff --git a/extraction/impacted-rbt/ocaml/change_impact.ml b/extraction/impacted-rbt/ocaml/change_impact.ml new file mode 100644 index 0000000..46720d9 --- /dev/null +++ b/extraction/impacted-rbt/ocaml/change_impact.ml @@ -0,0 +1,47 @@ +open Impacted_rbt +open Util + +let impacted_fresh num_new num_old successors f_new f_old = + let module Ords = + struct + let n = num_new + let m' = num_old - 1 + end + in + let module OCI = OrdinalsRunnableImpacted(Ords) in + Obj.magic + (OCI.succs_impacted_fresh + (Obj.magic successors) + (Obj.magic (fun x -> char_list_of_string (f_new x))) + (Obj.magic (fun x -> char_list_of_string (f_old x)))) + +let runnable_impacted_fresh num_new num_old successors f_new f_old rnb = + let module Ords = + struct + let n = num_new + let m' = num_old - 1 + end + in + let module OCI = OrdinalsRunnableImpacted(Ords) in + Obj.magic + (OCI.succs_runnable_impacted_fresh + (Obj.magic successors) + (Obj.magic (fun x -> char_list_of_string (f_new x))) + (Obj.magic (fun x -> char_list_of_string (f_old x))) + rnb) + +let topsort num_new num_old successors f_new f_old rnb successors' = + let module Ords = + struct + let n = num_new + let m' = num_old - 1 + end + in + let module OCI = OrdinalsRunnableImpacted(Ords) in + Obj.magic + (OCI.succs_ts + (Obj.magic successors) + (Obj.magic (fun x -> char_list_of_string (f_new x))) + (Obj.magic (fun x -> char_list_of_string (f_old x))) + rnb + (Obj.magic successors')) diff --git a/extraction/impacted-rbt/ocaml/change_impact.mli b/extraction/impacted-rbt/ocaml/change_impact.mli new file mode 100644 index 0000000..0d17f3d --- /dev/null +++ b/extraction/impacted-rbt/ocaml/change_impact.mli @@ -0,0 +1,20 @@ +val impacted_fresh : int -> int -> + (int -> int list) -> + (int -> string) -> + (int -> string) -> + int list + +val runnable_impacted_fresh : int -> int -> + (int -> int list) -> + (int -> string) -> + (int -> string) -> + (int -> bool) -> + int list + +val topsort : int -> int -> + (int -> int list) -> + (int -> string) -> + (int -> string) -> + (int -> bool) -> + (int -> int list) -> + int list diff --git a/extraction/impacted-rbt/ocaml/filtering.ml b/extraction/impacted-rbt/ocaml/filtering.ml new file mode 100644 index 0000000..1953a51 --- /dev/null +++ b/extraction/impacted-rbt/ocaml/filtering.ml @@ -0,0 +1,108 @@ +open Yojson.Basic.Util +open Util +open ExtLib + +let new_vertex_entry json = + let id = to_int (member "id" json) in + let uri = to_string (member "uri" json) in + let runnable = to_bool (member "checkable" json) in + let checksum = to_string (member "checksum" json) in + (id, uri, runnable, checksum) + +let old_vertex_entry json = + let id = to_int (member "id" json) in + let uri = to_string (member "uri" json) in + let adjacent = List.map to_int (to_list (member "neighbors" json)) in + let runnable = to_bool (member "checkable" json) in + let checksum = to_string (member "checksum" json) in + (id, uri, adjacent, runnable, checksum) + +let build_id_idx_tbl el = + let tbl = Hashtbl.create (List.length el) in + let idx = ref 0 in + List.iter + (fun (id, _, _, _, _) -> + Hashtbl.add tbl id !idx; + idx := !idx + 1) + el; + tbl + +let extend_id_idx_tbl tbl el = + let idx = ref (Hashtbl.length tbl) in + List.iter + (fun (id, _, _, _) -> + if not (Hashtbl.mem tbl id) then + (Hashtbl.add tbl id !idx; + idx := !idx + 1)) + el; + tbl + +let build_old_idx_arr old_id_idx_tbl el = + let arr = Array.make (List.length el) (0, [], false, "") in + List.iter + (fun (id, uri, adjacent, runnable, checksum) -> + let idx = Hashtbl.find old_id_idx_tbl id in + let al = List.map (Hashtbl.find old_id_idx_tbl) adjacent in + let elt = (id, al, runnable, checksum) in + arr.(idx) <- elt) + el; + arr + +let build_new_idx_arr new_id_idx_tbl el = + let arr = Array.make (List.length el) (0, "", false, "") in + List.iter + (fun (id, uri, runnable, checksum) -> + let idx = Hashtbl.find new_id_idx_tbl id in + arr.(idx) <- (id, uri, runnable, checksum)) + el; + arr + +let build_succs_arr old_idx_arr = + let arr = Array.make (Array.length old_idx_arr) [] in + Array.iteri + (fun idx (_, adjacent, _, _) -> + List.iter (fun idx' -> arr.(idx') <- idx :: arr.(idx')) adjacent) + old_idx_arr; + arr + +let () = + let json_new = Yojson.Basic.from_file Sys.argv.(1) in + let json_old = Yojson.Basic.from_file Sys.argv.(2) in + + let new_list = to_list json_new in + let new_entries = List.map new_vertex_entry new_list in + + let old_list = to_list json_old in + let old_entries = List.map old_vertex_entry old_list in + + let old_id_idx_tbl = build_id_idx_tbl old_entries in + let old_idx_arr = build_old_idx_arr old_id_idx_tbl old_entries in + + let new_id_idx_tbl = extend_id_idx_tbl old_id_idx_tbl new_entries in + let new_idx_arr = build_new_idx_arr new_id_idx_tbl new_entries in + + let succs_arr = build_succs_arr old_idx_arr in + + let num_new = Array.length new_idx_arr in + let num_old = Array.length old_idx_arr in + + let successors k = succs_arr.(k) in + let f_new k = let (_,_,_,checksum) = new_idx_arr.(k) in checksum in + let f_old k = let (_,_,_,checksum) = old_idx_arr.(k) in checksum in + let chk k = let (_,_,runnable,_) = new_idx_arr.(k) in runnable in + + let chk_imp_fr = + Change_impact.runnable_impacted_fresh + num_new num_old + successors + f_new f_old + chk + in + + let res = + List.map + (fun k -> let (_,uri,_,_) = new_idx_arr.(k) in uri) + chk_imp_fr + in + + print_string (string_of_list (fun s -> s) "\n" "\n" res) diff --git a/extraction/impacted-rbt/ocaml/filteringinv.ml b/extraction/impacted-rbt/ocaml/filteringinv.ml new file mode 100644 index 0000000..54cd922 --- /dev/null +++ b/extraction/impacted-rbt/ocaml/filteringinv.ml @@ -0,0 +1,98 @@ +open Yojson.Basic.Util +open Util +open ExtLib + +let new_vertex_entry json = + let id = to_int (member "id" json) in + let uri = to_string (member "uri" json) in + let runnable = to_bool (member "checkable" json) in + let checksum = to_string (member "checksum" json) in + (id, uri, runnable, checksum) + +let old_vertex_entry json = + let id = to_int (member "id" json) in + let uri = to_string (member "uri" json) in + let adjacent = List.map to_int (to_list (member "neighbors" json)) in + let runnable = to_bool (member "checkable" json) in + let checksum = to_string (member "checksum" json) in + (id, uri, adjacent, runnable, checksum) + +let build_id_idx_tbl el = + let tbl = Hashtbl.create (List.length el) in + let idx = ref 0 in + List.iter + (fun (id, _, _, _, _) -> + Hashtbl.add tbl id !idx; + idx := !idx + 1) + el; + tbl + +let extend_id_idx_tbl tbl el = + let idx = ref (Hashtbl.length tbl) in + List.iter + (fun (id, _, _, _) -> + if not (Hashtbl.mem tbl id) then + (Hashtbl.add tbl id !idx; + idx := !idx + 1)) + el; + tbl + +let build_old_idx_arr old_id_idx_tbl el = + let arr = Array.make (List.length el) (0, [], false, "") in + List.iter + (fun (id, uri, adjacent, runnable, checksum) -> + let idx = Hashtbl.find old_id_idx_tbl id in + let al = List.map (Hashtbl.find old_id_idx_tbl) adjacent in + let elt = (id, al, runnable, checksum) in + arr.(idx) <- elt) + el; + arr + +let build_new_idx_arr new_id_idx_tbl el = + let arr = Array.make (List.length el) (0, "", false, "") in + List.iter + (fun (id, uri, runnable, checksum) -> + let idx = Hashtbl.find new_id_idx_tbl id in + arr.(idx) <- (id, uri, runnable, checksum)) + el; + arr + +let () = + let json_new = Yojson.Basic.from_file Sys.argv.(1) in + let json_old = Yojson.Basic.from_file Sys.argv.(2) in + + let new_list = to_list json_new in + let new_entries = List.map new_vertex_entry new_list in + + let old_list = to_list json_old in + let old_entries = List.map old_vertex_entry old_list in + + let old_id_idx_tbl = build_id_idx_tbl old_entries in + let old_idx_arr = build_old_idx_arr old_id_idx_tbl old_entries in + + let new_id_idx_tbl = extend_id_idx_tbl old_id_idx_tbl new_entries in + let new_idx_arr = build_new_idx_arr new_id_idx_tbl new_entries in + + let num_new = Array.length new_idx_arr in + let num_old = Array.length old_idx_arr in + + let successors k = let (_,al,_,_) = old_idx_arr.(k) in al in + let f_new k = let (_,_,_,checksum) = new_idx_arr.(k) in checksum in + let f_old k = let (_,_,_,checksum) = old_idx_arr.(k) in checksum in + let chk k = let (_,_,runnable,_) = new_idx_arr.(k) in runnable in + + let chk_imp_fr = + Change_impact.runnable_impacted_fresh + num_new num_old + successors + f_new f_old + chk + in + + let res = + List.map + (fun k -> let (_,uri,_,_) = new_idx_arr.(k) in uri) + chk_imp_fr + in + + print_string (string_of_list (fun s -> s) "\n" "\n" res) diff --git a/extraction/impacted-rbt/ocaml/topfiltering.ml b/extraction/impacted-rbt/ocaml/topfiltering.ml new file mode 100644 index 0000000..68bc989 --- /dev/null +++ b/extraction/impacted-rbt/ocaml/topfiltering.ml @@ -0,0 +1,121 @@ +open Yojson.Basic.Util +open Util +open ExtLib + +let new_vertex_entry json = + let id = to_int (member "id" json) in + let uri = to_string (member "uri" json) in + let adjacent = List.map to_int (to_list (member "neighbors" json)) in + let runnable = to_bool (member "checkable" json) in + let checksum = to_string (member "checksum" json) in + (id, uri, adjacent, runnable, checksum) + +let old_vertex_entry json = + let id = to_int (member "id" json) in + let uri = to_string (member "uri" json) in + let adjacent = List.map to_int (to_list (member "neighbors" json)) in + let runnable = to_bool (member "checkable" json) in + let checksum = to_string (member "checksum" json) in + (id, uri, adjacent, runnable, checksum) + +let build_id_idx_tbl el = + let tbl = Hashtbl.create (List.length el) in + let idx = ref 0 in + List.iter + (fun (id, _, _, _, _) -> + Hashtbl.add tbl id !idx; + idx := !idx + 1) + el; + tbl + +let extend_id_idx_tbl tbl el = + let idx = ref (Hashtbl.length tbl) in + List.iter + (fun (id,_, _, _, _) -> + if not (Hashtbl.mem tbl id) then + (Hashtbl.add tbl id !idx; + idx := !idx + 1)) + el; + tbl + +let build_old_idx_arr old_id_idx_tbl el = + let arr = Array.make (List.length el) (0, [], false, "") in + List.iter + (fun (id, uri, adjacent, runnable, checksum) -> + let idx = Hashtbl.find old_id_idx_tbl id in + let al = List.map (Hashtbl.find old_id_idx_tbl) adjacent in + let elt = (id, al, runnable, checksum) in + arr.(idx) <- elt) + el; + arr + +let build_new_idx_arr new_id_idx_tbl el = + let arr = Array.make (List.length el) (0, "", [], false, "") in + List.iter + (fun (id, uri, adjacent, runnable, checksum) -> + let idx = Hashtbl.find new_id_idx_tbl id in + let al = List.map (Hashtbl.find new_id_idx_tbl) adjacent in + arr.(idx) <- (id, uri, al, runnable, checksum)) + el; + arr + +let build_succs_arr old_idx_arr = + let arr = Array.make (Array.length old_idx_arr) [] in + Array.iteri + (fun idx (_, adjacent, _, _) -> + List.iter (fun idx' -> arr.(idx') <- idx :: arr.(idx')) adjacent) + old_idx_arr; + arr + +let build_succs'_arr new_idx_arr = + let arr = Array.make (Array.length new_idx_arr) [] in + Array.iteri + (fun idx (_, _, adjacent, _, _) -> + List.iter (fun idx' -> arr.(idx') <- idx :: arr.(idx')) adjacent) + new_idx_arr; + arr + +let () = + let json_new = Yojson.Basic.from_file Sys.argv.(1) in + let json_old = Yojson.Basic.from_file Sys.argv.(2) in + + let new_list = to_list json_new in + let new_entries = List.map new_vertex_entry new_list in + + let old_list = to_list json_old in + let old_entries = List.map old_vertex_entry old_list in + + let old_id_idx_tbl = build_id_idx_tbl old_entries in + let old_idx_arr = build_old_idx_arr old_id_idx_tbl old_entries in + + let new_id_idx_tbl = extend_id_idx_tbl old_id_idx_tbl new_entries in + let new_idx_arr = build_new_idx_arr new_id_idx_tbl new_entries in + + let succs_arr = build_succs_arr old_idx_arr in + let succs'_arr = build_succs'_arr new_idx_arr in + + let num_new = Array.length new_idx_arr in + let num_old = Array.length old_idx_arr in + + let successors k = succs_arr.(k) in + let f_new k = let (_,_,_,_,checksum) = new_idx_arr.(k) in checksum in + let f_old k = let (_,_,_,checksum) = old_idx_arr.(k) in checksum in + let chk k = let (_,_,_,runnable,_) = new_idx_arr.(k) in runnable in + let successors' k = succs'_arr.(k) in + + let tsorted = + Change_impact.topsort + num_new num_old + successors + f_new f_old + chk + successors' + in + + let res = + List.map + (fun k -> let (_,uri,_,_,_) = new_idx_arr.(k) in uri) + tsorted + in + + print_string (string_of_list (fun s -> s) "\n" "\n" res) diff --git a/extraction/impacted-rbt/ocaml/util.ml b/extraction/impacted-rbt/ocaml/util.ml new file mode 100644 index 0000000..7f9a6bc --- /dev/null +++ b/extraction/impacted-rbt/ocaml/util.ml @@ -0,0 +1,25 @@ +let rec string_of_list f sep fin = function + | [] -> "" + | e :: [] -> f e ^ fin + | e :: l -> f e ^ sep ^ string_of_list f sep fin l + +let string_of_int_list = + string_of_list string_of_int " " "" + +let print_int_list l = + print_string (string_of_int_list l) + +let char_list_of_string s = + let rec exp i l = + if i < 0 then l else exp (i - 1) (s.[i] :: l) in + exp (String.length s - 1) [] + +let bytes_of_char_list l = + let res = Bytes.create (List.length l) in + let rec imp i = function + | [] -> res + | c :: l -> Bytes.set res i c; imp (i + 1) l in + imp 0 l + +let string_of_char_list l = + Bytes.to_string (bytes_of_char_list l) diff --git a/extraction/impacted-rbt/scripts/remove_module.pl b/extraction/impacted-rbt/scripts/remove_module.pl new file mode 100644 index 0000000..5f363f3 --- /dev/null +++ b/extraction/impacted-rbt/scripts/remove_module.pl @@ -0,0 +1,37 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +# https://perlmaven.com/how-to-replace-a-string-in-a-file-with-perl + +my $module_name = $ARGV[0]; +my $mli_name = $module_name . '.mli'; + +my $mli = read_file($mli_name); +$mli =~ s/val predT : 'a1 simpl_pred//g; +$mli =~ s/val pred_of_argType : 'a1 simpl_pred//g; +$mli =~ s/val simplPredType : 'a1 predType//g; +write_file($mli_name, $mli); +exit; + +sub read_file { + my ($filename) = @_; + + open my $in, '<:encoding(UTF-8)', $filename or die "Could not open '$filename' for reading $!"; + local $/ = undef; + my $all = <$in>; + close $in; + + return $all; +} + +sub write_file { + my ($filename, $content) = @_; + + open my $out, '>:encoding(UTF-8)', $filename or die "Could not open '$filename' for writing $!";; + print $out $content; + close $out; + + return; +} diff --git a/extraction/impacted/.gitignore b/extraction/impacted/.gitignore new file mode 100644 index 0000000..67c53f7 --- /dev/null +++ b/extraction/impacted/.gitignore @@ -0,0 +1,5 @@ +ocaml/impacted.ml +ocaml/impacted.mli +_build +*.native +gmon.out diff --git a/extraction/impacted/Makefile b/extraction/impacted/Makefile new file mode 100644 index 0000000..208b398 --- /dev/null +++ b/extraction/impacted/Makefile @@ -0,0 +1,29 @@ +OCAMLBUILD = ocamlbuild -tag safe_string -I ocaml -cflag -g -package extlib +OCAMLBUILD_JSON = $(OCAMLBUILD) -package yojson + +IMPACTED = ocaml/impacted.ml ocaml/impacted.mli +CHANGE = ocaml/util.ml ocaml/change_impact.ml ocaml/change_impact.mli + +default: filtering.native + +filtering.native: $(IMPACTED) $(CHANGE) ocaml/filtering.ml + perl scripts/remove_module.pl ocaml/impacted + $(OCAMLBUILD_JSON) filtering.native + +topfiltering.native: $(IMPACTED) $(CHANGE) ocaml/topfiltering.ml + perl scripts/remove_module.pl ocaml/impacted + $(OCAMLBUILD_JSON) topfiltering.native + +filteringinv.native: $(IMPACTED) $(CHANGE) ocaml/filteringinv.ml + perl scripts/remove_module.pl ocaml/impacted + $(OCAMLBUILD_JSON) filteringinv.native + +$(IMPACTED): + +$(MAKE) -C ../.. extraction/impacted/$@ + +clean: + $(OCAMLBUILD) -clean + +.PHONY: default clean $(IMPACTED) + +.NOTPARALLEL: $(IMPACTED) diff --git a/extraction/impacted/coq/extract_impacted.v b/extraction/impacted/coq/extract_impacted.v new file mode 100644 index 0000000..ff4a60f --- /dev/null +++ b/extraction/impacted/coq/extract_impacted.v @@ -0,0 +1,30 @@ +From mathcomp +Require Import all_ssreflect. +From chip +Require Import string finn. + +Require Import ExtrOcamlBasic. +Require Import ExtrOcamlNatInt. +Require Import ExtrOcamlString. + +Extract Inlined Constant fst => "fst". +Extract Inlined Constant snd => "snd". +Extract Inlined Constant negb => "not". + +Extract Inlined Constant eqn => "(=)". +Extract Inlined Constant leq => "(<=)". +Extract Inlined Constant filter => "ExtLib.List.filter". +Extract Inlined Constant cat => "ExtLib.List.append". +Extract Inlined Constant map => "ExtLib.List.map". +Extract Inlined Constant foldl => "ExtLib.List.fold_left". +Extract Inlined Constant foldr => "(fun a b c -> ExtLib.List.fold_right a c b)". +Extract Inlined Constant size => "ExtLib.List.length". +Extract Inlined Constant nth => "(fun e l n -> match ExtLib.List.nth_opt l n with None -> e | Some e' -> e')". + +Extract Inlined Constant eq_string => "(=)". + +Extract Constant SetDef.pred_of_set => "fun t a -> Obj.magic (FunFinfun.fun_of_fin t ((set_subType t).val0 (Obj.magic a)))". + +Extract Constant fintype.Finite.base2 => "fun c -> { Countable.base = c.base; Countable.mixin = (Obj.magic mixin_base __ c.mixin) }". + +Extraction "extraction/impacted/ocaml/impacted.ml" set_subType succs_runnable_impacted succs_impacted_fresh succs_runnable_impacted_fresh succs_ts. diff --git a/extraction/impacted/ocaml/change_impact.ml b/extraction/impacted/ocaml/change_impact.ml new file mode 100644 index 0000000..b680322 --- /dev/null +++ b/extraction/impacted/ocaml/change_impact.ml @@ -0,0 +1,38 @@ +open Impacted +open Util + +let runnable_impacted num successors f_new f_old rnb = + Obj.magic + (succs_runnable_impacted + num (num-1) + (Obj.magic successors) + (Obj.magic (fun x -> char_list_of_string (f_new x))) + (Obj.magic (fun x -> char_list_of_string (f_old x))) + rnb) + +let impacted_fresh num_new num_old successors f_new f_old = + Obj.magic + (succs_impacted_fresh + num_new (num_old-1) + (Obj.magic successors) + (Obj.magic (fun x -> char_list_of_string (f_new x))) + (Obj.magic (fun x -> char_list_of_string (f_old x)))) + +let runnable_impacted_fresh num_new num_old successors f_new f_old rnb = + Obj.magic + (succs_runnable_impacted_fresh + num_new (num_old-1) + (Obj.magic successors) + (Obj.magic (fun x -> char_list_of_string (f_new x))) + (Obj.magic (fun x -> char_list_of_string (f_old x))) + rnb) + +let topsort num_new num_old successors f_new f_old rnb successors' = + Obj.magic + (succs_ts + num_new (num_old-1) + (Obj.magic successors) + (Obj.magic (fun x -> char_list_of_string (f_new x))) + (Obj.magic (fun x -> char_list_of_string (f_old x))) + rnb + (Obj.magic successors')) diff --git a/extraction/impacted/ocaml/change_impact.mli b/extraction/impacted/ocaml/change_impact.mli new file mode 100644 index 0000000..fead143 --- /dev/null +++ b/extraction/impacted/ocaml/change_impact.mli @@ -0,0 +1,27 @@ +val runnable_impacted : int -> + (int -> int list) -> + (int -> string) -> + (int -> string) -> + (int -> bool) -> + int list + +val impacted_fresh : int -> int -> + (int -> int list) -> + (int -> string) -> + (int -> string) -> + int list + +val runnable_impacted_fresh : int -> int -> + (int -> int list) -> + (int -> string) -> + (int -> string) -> + (int -> bool) -> + int list + +val topsort : int -> int -> + (int -> int list) -> + (int -> string) -> + (int -> string) -> + (int -> bool) -> + (int -> int list) -> + int list diff --git a/extraction/impacted/ocaml/filtering.ml b/extraction/impacted/ocaml/filtering.ml new file mode 100644 index 0000000..000b704 --- /dev/null +++ b/extraction/impacted/ocaml/filtering.ml @@ -0,0 +1,108 @@ +open Yojson.Basic.Util +open Util +open ExtLib + +let new_vertex_entry json = + let id = to_int (member "id" json) in + let uri = to_string (member "uri" json) in + let runnable = to_bool (member "checkable" json) in + let checksum = to_string (member "checksum" json) in + (id, uri, runnable, checksum) + +let old_vertex_entry json = + let id = to_int (member "id" json) in + let uri = to_string (member "uri" json) in + let adjacent = List.map to_int (to_list (member "neighbors" json)) in + let runnable = to_bool (member "checkable" json) in + let checksum = to_string (member "checksum" json) in + (id, uri, adjacent, runnable, checksum) + +let build_id_idx_tbl el = + let tbl = Hashtbl.create (List.length el) in + let idx = ref 0 in + List.iter + (fun (id, _, _, _, _) -> + Hashtbl.add tbl id !idx; + idx := !idx + 1) + el; + tbl + +let extend_id_idx_tbl tbl el = + let idx = ref (Hashtbl.length tbl) in + List.iter + (fun (id, _, _, _) -> + if not (Hashtbl.mem tbl id) then + (Hashtbl.add tbl id !idx; + idx := !idx + 1)) + el; + tbl + +let build_old_idx_arr old_id_idx_tbl el = + let arr = Array.make (List.length el) (0, [], false, "") in + List.iter + (fun (id, uri, adjacent, runnable, checksum) -> + let idx = Hashtbl.find old_id_idx_tbl id in + let al = List.map (Hashtbl.find old_id_idx_tbl) adjacent in + let elt = (id, al, runnable, checksum) in + arr.(idx) <- elt) + el; + arr + +let build_new_idx_arr new_id_idx_tbl el = + let arr = Array.make (List.length el) (0, "", false, "") in + List.iter + (fun (id, uri, runnable, checksum) -> + let idx = Hashtbl.find new_id_idx_tbl id in + arr.(idx) <- (id, uri, runnable, checksum)) + el; + arr + +let build_succs_arr old_idx_arr = + let arr = Array.make (Array.length old_idx_arr) [] in + Array.iteri + (fun idx (_, adjacent, _, _) -> + List.iter (fun idx' -> arr.(idx') <- idx :: arr.(idx')) adjacent) + old_idx_arr; + arr + +let () = + let json_new = Yojson.Basic.from_file Sys.argv.(1) in + let json_old = Yojson.Basic.from_file Sys.argv.(2) in + + let new_list = to_list json_new in + let new_entries = List.map new_vertex_entry new_list in + + let old_list = to_list json_old in + let old_entries = List.map old_vertex_entry old_list in + + let old_id_idx_tbl = build_id_idx_tbl old_entries in + let old_idx_arr = build_old_idx_arr old_id_idx_tbl old_entries in + + let new_id_idx_tbl = extend_id_idx_tbl old_id_idx_tbl new_entries in + let new_idx_arr = build_new_idx_arr new_id_idx_tbl new_entries in + + let succs_arr = build_succs_arr old_idx_arr in + + let num_new = Array.length new_idx_arr in + let num_old = Array.length old_idx_arr in + + let successors k = succs_arr.(k) in + let f_new k = let (_,_,_,checksum) = new_idx_arr.(k) in checksum in + let f_old k = let (_,_,_,checksum) = old_idx_arr.(k) in checksum in + let rnb k = let (_,_,runnable,_) = new_idx_arr.(k) in runnable in + + let rnb_imp_fr = + Change_impact.runnable_impacted_fresh + num_new num_old + successors + f_new f_old + rnb + in + + let res = + List.map + (fun k -> let (_,uri,_,_) = new_idx_arr.(k) in uri) + rnb_imp_fr + in + + print_string (string_of_list (fun s -> s) "\n" "\n" res) diff --git a/extraction/impacted/ocaml/filteringinv.ml b/extraction/impacted/ocaml/filteringinv.ml new file mode 100644 index 0000000..bffe879 --- /dev/null +++ b/extraction/impacted/ocaml/filteringinv.ml @@ -0,0 +1,98 @@ +open Yojson.Basic.Util +open Util +open ExtLib + +let new_vertex_entry json = + let id = to_int (member "id" json) in + let uri = to_string (member "uri" json) in + let runnable = to_bool (member "checkable" json) in + let checksum = to_string (member "checksum" json) in + (id, uri, runnable, checksum) + +let old_vertex_entry json = + let id = to_int (member "id" json) in + let uri = to_string (member "uri" json) in + let adjacent = List.map to_int (to_list (member "neighbors" json)) in + let runnable = to_bool (member "checkable" json) in + let checksum = to_string (member "checksum" json) in + (id, uri, adjacent, runnable, checksum) + +let build_id_idx_tbl el = + let tbl = Hashtbl.create (List.length el) in + let idx = ref 0 in + List.iter + (fun (id, _, _, _, _) -> + Hashtbl.add tbl id !idx; + idx := !idx + 1) + el; + tbl + +let extend_id_idx_tbl tbl el = + let idx = ref (Hashtbl.length tbl) in + List.iter + (fun (id, _, _, _) -> + if not (Hashtbl.mem tbl id) then + (Hashtbl.add tbl id !idx; + idx := !idx + 1)) + el; + tbl + +let build_old_idx_arr old_id_idx_tbl el = + let arr = Array.make (List.length el) (0, [], false, "") in + List.iter + (fun (id, uri, adjacent, runnable, checksum) -> + let idx = Hashtbl.find old_id_idx_tbl id in + let al = List.map (Hashtbl.find old_id_idx_tbl) adjacent in + let elt = (id, al, runnable, checksum) in + arr.(idx) <- elt) + el; + arr + +let build_new_idx_arr new_id_idx_tbl el = + let arr = Array.make (List.length el) (0, "", false, "") in + List.iter + (fun (id, uri, runnable, checksum) -> + let idx = Hashtbl.find new_id_idx_tbl id in + arr.(idx) <- (id, uri, runnable, checksum)) + el; + arr + +let () = + let json_new = Yojson.Basic.from_file Sys.argv.(1) in + let json_old = Yojson.Basic.from_file Sys.argv.(2) in + + let new_list = to_list json_new in + let new_entries = List.map new_vertex_entry new_list in + + let old_list = to_list json_old in + let old_entries = List.map old_vertex_entry old_list in + + let old_id_idx_tbl = build_id_idx_tbl old_entries in + let old_idx_arr = build_old_idx_arr old_id_idx_tbl old_entries in + + let new_id_idx_tbl = extend_id_idx_tbl old_id_idx_tbl new_entries in + let new_idx_arr = build_new_idx_arr new_id_idx_tbl new_entries in + + let num_new = Array.length new_idx_arr in + let num_old = Array.length old_idx_arr in + + let successors k = let (_,al,_,_) = old_idx_arr.(k) in al in + let f_new k = let (_,_,_,checksum) = new_idx_arr.(k) in checksum in + let f_old k = let (_,_,_,checksum) = old_idx_arr.(k) in checksum in + let rnb k = let (_,_,runnable,_) = new_idx_arr.(k) in runnable in + + let rnb_imp_fr = + Change_impact.runnable_impacted_fresh + num_new num_old + successors + f_new f_old + rnb + in + + let res = + List.map + (fun k -> let (_,uri,_,_) = new_idx_arr.(k) in uri) + rnb_imp_fr + in + + print_string (string_of_list (fun s -> s) "\n" "\n" res) diff --git a/extraction/impacted/ocaml/topfiltering.ml b/extraction/impacted/ocaml/topfiltering.ml new file mode 100644 index 0000000..e773661 --- /dev/null +++ b/extraction/impacted/ocaml/topfiltering.ml @@ -0,0 +1,121 @@ +open Yojson.Basic.Util +open Util +open ExtLib + +let new_vertex_entry json = + let id = to_int (member "id" json) in + let uri = to_string (member "uri" json) in + let adjacent = List.map to_int (to_list (member "neighbors" json)) in + let runnable = to_bool (member "checkable" json) in + let checksum = to_string (member "checksum" json) in + (id, uri, adjacent, runnable, checksum) + +let old_vertex_entry json = + let id = to_int (member "id" json) in + let uri = to_string (member "uri" json) in + let adjacent = List.map to_int (to_list (member "neighbors" json)) in + let runnable = to_bool (member "checkable" json) in + let checksum = to_string (member "checksum" json) in + (id, uri, adjacent, runnable, checksum) + +let build_id_idx_tbl el = + let tbl = Hashtbl.create (List.length el) in + let idx = ref 0 in + List.iter + (fun (id, _, _, _, _) -> + Hashtbl.add tbl id !idx; + idx := !idx + 1) + el; + tbl + +let extend_id_idx_tbl tbl el = + let idx = ref (Hashtbl.length tbl) in + List.iter + (fun (id,_, _, _, _) -> + if not (Hashtbl.mem tbl id) then + (Hashtbl.add tbl id !idx; + idx := !idx + 1)) + el; + tbl + +let build_old_idx_arr old_id_idx_tbl el = + let arr = Array.make (List.length el) (0, [], false, "") in + List.iter + (fun (id, uri, adjacent, runnable, checksum) -> + let idx = Hashtbl.find old_id_idx_tbl id in + let al = List.map (Hashtbl.find old_id_idx_tbl) adjacent in + let elt = (id, al, runnable, checksum) in + arr.(idx) <- elt) + el; + arr + +let build_new_idx_arr new_id_idx_tbl el = + let arr = Array.make (List.length el) (0, "", [], false, "") in + List.iter + (fun (id, uri, adjacent, runnable, checksum) -> + let idx = Hashtbl.find new_id_idx_tbl id in + let al = List.map (Hashtbl.find new_id_idx_tbl) adjacent in + arr.(idx) <- (id, uri, al, runnable, checksum)) + el; + arr + +let build_succs_arr old_idx_arr = + let arr = Array.make (Array.length old_idx_arr) [] in + Array.iteri + (fun idx (_, adjacent, _, _) -> + List.iter (fun idx' -> arr.(idx') <- idx :: arr.(idx')) adjacent) + old_idx_arr; + arr + +let build_succs'_arr new_idx_arr = + let arr = Array.make (Array.length new_idx_arr) [] in + Array.iteri + (fun idx (_, _, adjacent, _, _) -> + List.iter (fun idx' -> arr.(idx') <- idx :: arr.(idx')) adjacent) + new_idx_arr; + arr + +let () = + let json_new = Yojson.Basic.from_file Sys.argv.(1) in + let json_old = Yojson.Basic.from_file Sys.argv.(2) in + + let new_list = to_list json_new in + let new_entries = List.map new_vertex_entry new_list in + + let old_list = to_list json_old in + let old_entries = List.map old_vertex_entry old_list in + + let old_id_idx_tbl = build_id_idx_tbl old_entries in + let old_idx_arr = build_old_idx_arr old_id_idx_tbl old_entries in + + let new_id_idx_tbl = extend_id_idx_tbl old_id_idx_tbl new_entries in + let new_idx_arr = build_new_idx_arr new_id_idx_tbl new_entries in + + let succs_arr = build_succs_arr old_idx_arr in + let succs'_arr = build_succs'_arr new_idx_arr in + + let num_new = Array.length new_idx_arr in + let num_old = Array.length old_idx_arr in + + let successors k = succs_arr.(k) in + let f_new k = let (_,_,_,_,checksum) = new_idx_arr.(k) in checksum in + let f_old k = let (_,_,_,checksum) = old_idx_arr.(k) in checksum in + let rnb k = let (_,_,_,runnable,_) = new_idx_arr.(k) in runnable in + let successors' k = succs'_arr.(k) in + + let tsorted = + Change_impact.topsort + num_new num_old + successors + f_new f_old + rnb + successors' + in + + let res = + List.map + (fun k -> let (_,uri,_,_,_) = new_idx_arr.(k) in uri) + tsorted + in + + print_string (string_of_list (fun s -> s) "\n" "\n" res) diff --git a/extraction/impacted/ocaml/util.ml b/extraction/impacted/ocaml/util.ml new file mode 100644 index 0000000..7f9a6bc --- /dev/null +++ b/extraction/impacted/ocaml/util.ml @@ -0,0 +1,25 @@ +let rec string_of_list f sep fin = function + | [] -> "" + | e :: [] -> f e ^ fin + | e :: l -> f e ^ sep ^ string_of_list f sep fin l + +let string_of_int_list = + string_of_list string_of_int " " "" + +let print_int_list l = + print_string (string_of_int_list l) + +let char_list_of_string s = + let rec exp i l = + if i < 0 then l else exp (i - 1) (s.[i] :: l) in + exp (String.length s - 1) [] + +let bytes_of_char_list l = + let res = Bytes.create (List.length l) in + let rec imp i = function + | [] -> res + | c :: l -> Bytes.set res i c; imp (i + 1) l in + imp 0 l + +let string_of_char_list l = + Bytes.to_string (bytes_of_char_list l) diff --git a/extraction/impacted/scripts/remove_module.pl b/extraction/impacted/scripts/remove_module.pl new file mode 100644 index 0000000..5f363f3 --- /dev/null +++ b/extraction/impacted/scripts/remove_module.pl @@ -0,0 +1,37 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +# https://perlmaven.com/how-to-replace-a-string-in-a-file-with-perl + +my $module_name = $ARGV[0]; +my $mli_name = $module_name . '.mli'; + +my $mli = read_file($mli_name); +$mli =~ s/val predT : 'a1 simpl_pred//g; +$mli =~ s/val pred_of_argType : 'a1 simpl_pred//g; +$mli =~ s/val simplPredType : 'a1 predType//g; +write_file($mli_name, $mli); +exit; + +sub read_file { + my ($filename) = @_; + + open my $in, '<:encoding(UTF-8)', $filename or die "Could not open '$filename' for reading $!"; + local $/ = undef; + my $all = <$in>; + close $in; + + return $all; +} + +sub write_file { + my ($filename, $content) = @_; + + open my $out, '>:encoding(UTF-8)', $filename or die "Could not open '$filename' for writing $!";; + print $out $content; + close $out; + + return; +} diff --git a/extraction/impacted/test/new.json b/extraction/impacted/test/new.json new file mode 100644 index 0000000..8ade032 --- /dev/null +++ b/extraction/impacted/test/new.json @@ -0,0 +1,5 @@ +[ + { "uri": "file:/home/user/projects/chip/examples/simple/target/classes/p/A.class", "id": 4198844360, "checkable": false, "checksum": "10ba792368d81930027e872c2ad9a39f" }, + { "uri": "file:/home/user/projects/chip/examples/simple/target/classes/p/C.class", "id": 3873306685, "checkable": false, "checksum": "af6a1e2906998db1156805401ce35ed7" }, + { "uri": "file:/home/user/projects/chip/examples/simple/target/test-classes/p/ATest.class", "id": 1571199077, "checkable": true, "checksum": "010bb09272ec602c7c77f365cfedf9dd" } +] diff --git a/extraction/impacted/test/old.json b/extraction/impacted/test/old.json new file mode 100644 index 0000000..157d775 --- /dev/null +++ b/extraction/impacted/test/old.json @@ -0,0 +1,5 @@ +[ + { "uri": "file:/home/user/projects/chip/examples/simple/target/classes/p/A.class", "id": 4198844360, "checkable": false, "neighbors": [3873306685], "checksum": "10ba792368d81930027e872c2ad9a39f" }, + { "uri": "file:/home/user/projects/chip/examples/simple/target/classes/p/C.class", "id": 3873306685, "checkable": false, "neighbors": [], "checksum": "3716b60b40157042bf3c6e18b0f98913" }, + { "uri": "file:/home/user/projects/chip/examples/simple/target/test-classes/p/ATest.class", "id": 1571199077, "checkable": true, "neighbors": [4198844360], "checksum": "010bb09272ec602c7c77f365cfedf9dd" } +]