From 11e65e2b8b84d8d59205a30efc153b674a443af9 Mon Sep 17 00:00:00 2001 From: Aleksandar Nanevski Date: Thu, 6 Aug 2026 16:00:12 +0200 Subject: [PATCH 01/17] preparing for rocq-9.2/mathcomp-2.6.0 --- Makefile | 21 +- Makefile.common | 99 ----- _CoqProject | 35 -- examples/Make | 29 -- examples/Makefile | 7 - examples/array.v | 2 +- examples/bubblesort.v | 21 +- examples/congmath.v | 63 ++-- examples/congprog.v | 65 ++-- examples/cyclic.v | 4 +- examples/dune | 9 - examples/hashtab.v | 13 +- examples/kvmaps.v | 53 +-- examples/llist.v | 2 +- examples/queue.v | 2 +- examples/quicksort.v | 53 ++- examples/stack.v | 2 +- examples/union_find.v | 828 ++++++++---------------------------------- htt/Make | 14 - htt/Makefile | 7 - htt/domain.v | 37 +- htt/dune | 11 - htt/heapauto.v | 24 +- htt/model.v | 14 +- theories/dune | 7 - 25 files changed, 343 insertions(+), 1079 deletions(-) delete mode 100644 Makefile.common delete mode 100644 _CoqProject delete mode 100644 examples/Make delete mode 100644 examples/Makefile delete mode 100644 examples/dune delete mode 100644 htt/Make delete mode 100644 htt/Makefile delete mode 100644 htt/dune delete mode 100644 theories/dune diff --git a/Makefile b/Makefile index d5aa0bf..55119cb 100644 --- a/Makefile +++ b/Makefile @@ -1,4 +1,19 @@ -# -*- Makefile -*- +# KNOWNTARGETS will not be passed along to RocqMakefile +KNOWNTARGETS := RocqMakefile +# KNOWNFILES will not get implicit targets from the final rule, and so depending on them won’t invoke the submake +# Warning: These files get declared as PHONY, so any targets depending on them always get rebuilt +KNOWNFILES := Makefile _RocqProject -# -------------------------------------------------------------------- -include Makefile.common +.DEFAULT_GOAL := invoke-rocqmakefile + +RocqMakefile: Makefile _RocqProject + $(ROCQBIN)rocq makefile -f _RocqProject -o RocqMakefile + +invoke-rocqmakefile: RocqMakefile + $(MAKE) --no-print-directory -f RocqMakefile $(filter-out $(KNOWNTARGETS),$(MAKECMDGOALS)) + +.PHONY: invoke-rocqmakefile $(KNOWNFILES) + +# This should be the last rule, to handle any targets not declared above +%: invoke-rocqmakefile + @true diff --git a/Makefile.common b/Makefile.common deleted file mode 100644 index c523410..0000000 --- a/Makefile.common +++ /dev/null @@ -1,99 +0,0 @@ -# -*- Makefile -*- - -###################################################################### -# USAGE: # -# The rules this-config::, this-build::, this-distclean::, # -# pre-makefile::, this-clean:: and __always__:: may be extended # -# Additionally, the following variables may be customized: # -SUBDIRS?= -COQBIN?=$(dir $(shell which coqtop)) -COQMAKEFILE?=$(COQBIN)coq_makefile -COQDEP?=$(COQBIN)coqdep -COQPROJECT?=_CoqProject -COQMAKEOPTIONS?= -COQMAKEFILEOPTIONS?= -V?= -VERBOSE?=V -###################################################################### - -# local context: ----------------------------------------------------- -.PHONY: all config build clean distclean __always__ -.SUFFIXES: - -H:= $(if $(VERBOSE),,@) # not used yet -TOP = $(dir $(lastword $(MAKEFILE_LIST))) -COQMAKE = $(MAKE) -f Makefile.coq $(COQMAKEOPTIONS) -BRANCH_coq:= $(shell $(COQBIN)coqtop -v | head -1 | grep -E '(trunk|master)' \ - | wc -l | sed 's/ *//g') - -# coq version: -ifneq "$(BRANCH_coq)" "0" -COQVVV:= dev -else -COQVVV:=$(shell $(COQBIN)coqtop --print-version | cut -d" " -f1) -endif - -COQV:= $(shell echo $(COQVVV) | cut -d"." -f1) -COQVV:= $(shell echo $(COQVVV) | cut -d"." -f1-2) - -# all: --------------------------------------------------------------- -all: config build - -# Makefile.coq: ------------------------------------------------------ -.PHONY: pre-makefile - -Makefile.coq: pre-makefile $(COQPROJECT) Makefile - $(COQMAKEFILE) $(COQMAKEFILEOPTIONS) -f $(COQPROJECT) -o Makefile.coq - -# Global config, build, clean and distclean -------------------------- -config: sub-config this-config - -build: sub-build this-build - -clean: sub-clean this-clean - -distclean: sub-distclean this-distclean - -# Local config, build, clean and distclean --------------------------- -.PHONY: this-config this-build this-distclean this-clean - -this-config:: __always__ - -this-build:: this-config Makefile.coq - +$(COQMAKE) - -this-distclean:: this-clean - rm -f Makefile.coq Makefile.coq.conf Makefile.coq - -this-clean:: __always__ - @if [ -f Makefile.coq ]; then $(COQMAKE) cleanall; fi - -# Install target ----------------------------------------------------- -.PHONY: install - -install: __always__ Makefile.coq - $(COQMAKE) install -# counting lines of Coq code ----------------------------------------- -.PHONY: count - -COQFILES = $(shell grep '.v$$' $(COQPROJECT)) - -count: - @coqwc $(COQFILES) | tail -1 | \ - awk '{printf ("%d (spec=%d+proof=%d)\n", $$1+$$2, $$1, $$2)}' -# Additionally cleaning backup (*~) files ---------------------------- -this-distclean:: - rm -f $(shell find . -name '*~') - -# Make in SUBDIRS ---------------------------------------------------- -ifdef SUBDIRS -sub-%: __always__ - @set -e; for d in $(SUBDIRS); do +$(MAKE) -C $$d $(@:sub-%=%); done -else -sub-%: __always__ - @true -endif - -# Make of individual .vo --------------------------------------------- -%.vo: __always__ Makefile.coq - +$(COQMAKE) $@ diff --git a/_CoqProject b/_CoqProject deleted file mode 100644 index f4eab2f..0000000 --- a/_CoqProject +++ /dev/null @@ -1,35 +0,0 @@ --Q examples htt --Q htt htt --docroot docs # where the documentation should go - --arg -w -arg -notation-overridden --arg -w -arg -redundant-canonical-projection - -# release-specific arguments --arg -w -arg -notation-incompatible-prefix # specific to coq8.20.0 --arg -w -arg -deprecated-from-Coq # specific to coq8.21 --arg -w -arg -deprecated-dirpath-Coq # specific to coq8.21 - -htt/options.v -htt/domain.v -htt/model.v -htt/heapauto.v -examples/exploit.v -examples/gcd.v -examples/counter.v -examples/llist.v -examples/dlist.v -examples/array.v -examples/queue.v -examples/cyclic.v -examples/stack.v -examples/bintree.v -examples/bst.v -examples/kvmaps.v -examples/hashtab.v -examples/bubblesort.v -examples/quicksort.v -examples/congmath.v -examples/congprog.v -examples/tree.v -examples/union_find.v diff --git a/examples/Make b/examples/Make deleted file mode 100644 index 05db16d..0000000 --- a/examples/Make +++ /dev/null @@ -1,29 +0,0 @@ --Q . htt - --arg -w -arg -notation-overridden --arg -w -arg -redundant-canonical-projection - -# release-specific arguments --arg -w -arg -notation-incompatible-prefix # specific to coq8.20.0 --arg -w -arg -deprecated-from-Coq # specific to coq8.21 --arg -w -arg -deprecated-dirpath-Coq # specific to coq8.21 - -exploit.v -gcd.v -counter.v -llist.v -dlist.v -array.v -queue.v -cyclic.v -stack.v -bintree.v -bst.v -kvmaps.v -hashtab.v -bubblesort.v -quicksort.v -congmath.v -congprog.v -tree.v -union_find.v diff --git a/examples/Makefile b/examples/Makefile deleted file mode 100644 index 103b008..0000000 --- a/examples/Makefile +++ /dev/null @@ -1,7 +0,0 @@ -# -*- Makefile -*- - -# setting variables -COQPROJECT?=Make - -# Main Makefile -include ../Makefile.common diff --git a/examples/array.v b/examples/array.v index 3235aed..9d8c82c 100644 --- a/examples/array.v +++ b/examples/array.v @@ -63,7 +63,7 @@ End ArraySig. Module Array : ArraySig. Section Array. Context {I : finType} {T : Type}. -Notation array := {array I -> T}. +Abbreviation array := {array I -> T}. (* array is specified by finite function *) Definition shape (a : array) (f : {ffun I -> T}) : Pred heap := diff --git a/examples/bubblesort.v b/examples/bubblesort.v index 751be67..7ce3453 100644 --- a/examples/bubblesort.v +++ b/examples/bubblesort.v @@ -22,9 +22,6 @@ Import Order.NatOrder Order.TTheory. Local Open Scope order_scope. Local Open Scope nat_scope. -(* change Set to Unset when porting the file, then remove the line when requiring MathComp >= 2.6 *) -Set SsrOldRewriteGoalsOrder. - (* Brief mathematics of (bubble) array sorting: *) (* Theory of permutations built out of (adjacent-element) swaps acting on *) (* finite functions from bounded nats to ordered values. *) @@ -128,7 +125,7 @@ Lemma codom1_ax_rcons2 (f : {ffun 'I_n.+1 -> A}) (a : itv_bound nat) (i : 'I_n) rcons (rcons (&:(fgraph f) (Interval a (BLeft (i : nat)))) (f (Wo i))) (f (So i)). Proof. -move=>H; rewrite slice_xR; last first. +move=>H; rewrite slice_xR. - by apply: ltW; case: a H=>[[] ax|ab] //; rewrite !bnd_simp ltEnat /= =>/ltnW. by rewrite onth_codom1S /= slice_oSR codom1_ax_rcons. Qed. @@ -194,7 +191,7 @@ Proof. move=>Hx0 Hx1. suff E: {in &:(enum 'I_n.+1) i, f =1 pffun (swnx x) f}. - by rewrite !fgraph_codom /= !codomE /= -2!slice_map /=; move/eq_in_map: E. -move=>/= y; rewrite slice_uniq_memE /=; last by exact: enum_uniq. +move=>/= y; rewrite slice_uniq_memE /=; first by exact: enum_uniq. case: i Hx0 Hx1=>i j Hx0 Hx1 /=. case/and3P=>_; rewrite /swnx size_enum_ord index_enum_ord =>Hy1 Hy2. rewrite ffunE; case: tpermP=>// Ey; move: Hy1 Hy2; rewrite {y}Ey /=. @@ -282,7 +279,7 @@ Proof. move=>H; move: (perm_swnx f i). set f' : {ffun 'I_n.+1 -> A} := pffun (swnx i) f. rewrite {1}(slice_uxou (fgraph f) k.+1) {1}(slice_uxou (fgraph f') k.+1). -by rewrite swnx_oa /=; [rewrite perm_cat2r | rewrite ltnS]. +by rewrite swnx_oa /=; [rewrite ltnS|rewrite perm_cat2r]. Qed. End SwapNextEq. @@ -728,13 +725,13 @@ apply: [stepE f]=>//= sw m [p][Hm Hsw]; case: decP=>H. - rewrite Sbo_eq. case: sw Hsw=>/=; case=>Ep Hf; rewrite {p}Ep ?pffunE1 in Hm *. (* swap happened before the call *) - - rewrite So_eq swnx_oa; last by rewrite ltnS; apply: ltnW. + - rewrite So_eq swnx_oa; first by rewrite ltnS; apply: ltnW. rewrite swnx_Skk /=; split=>//. - rewrite (@allrel_in_l _ _ _ _ &:(codom f) `]-oo, k.+1]) //. by apply/perm_mem; rewrite perm_sym; apply: perm_swnx_ux. - by rewrite ltnS leqnn. - rewrite allrel1r slice_oSR (slice_split (x:=ls) _ true); - last by rewrite in_itv. + rewrite allrel1r slice_oSR (slice_split (x:=ls) _ true). + - by rewrite in_itv. rewrite /= all_cat; apply/andP; split. - rewrite swnx_ao //; move: Hai. by rewrite codom1_ax_rcons // allrel_rconsr; case/andP. @@ -777,13 +774,13 @@ step=>Vm; exists p; case: sw Hsw=>/=; case=>Ep Hf. move: Hsi; rewrite codom1_ax_rcons // sorted_rconsE //=. case/andP => Halsi _. move: Hils; rewrite leq_eqVlt; case/orP=>[/eqP <-|Hlsi] //. - rewrite (slice_split (x:=ls) _ true); last by rewrite in_itv. + rewrite (slice_split (x:=ls) _ true); first by rewrite in_itv. by rewrite /= all_cat Hals. rewrite Ep swnx_xu_cons /= (path_sortedE (@otrans A)) Hsk andbT. by move: Hak; rewrite codom1_ax_rcons2 // !allrel_rconsl -!andbA; case/and3P. (* swap didn't happen on last iteration *) rewrite {p}Ep pffunE1 /= in Hm *. -rewrite (slice_split (x:=i) (i:=`[ls:nat, +oo[) _ false); last first. +rewrite (slice_split (x:=i) (i:=`[ls:nat, +oo[) _ false). - by rewrite in_itv /= andbT. split=>//=. - rewrite allrel_catr Hai /= -slice_oSL codom1_xu_cons allrel_consr. @@ -860,7 +857,7 @@ Qed. Next Obligation. move=>a [f][] h /= E. apply: [gE f]=>//=. -rewrite (@itv_overL _ _ _ +oo) /=; first by split=>//; exact: allrel0r. +rewrite (@itv_overL _ _ _ +oo) /=; last by split=>//; exact: allrel0r. by rewrite leEnat addn1 size_codom /= card_ord. Qed. diff --git a/examples/congmath.v b/examples/congmath.v index 329a197..edd1018 100644 --- a/examples/congmath.v +++ b/examples/congmath.v @@ -16,9 +16,6 @@ From Stdlib Require Import Recdef Setoid ssreflect ssrbool ssrfun. From mathcomp Require Import eqtype choice ssrnat seq bigop fintype finfun. From pcm Require Import options prelude ordtype finmap pred seqext. -(* change Set to Unset when porting the file, then remove the line when requiring MathComp >= 2.6 *) -Set SsrOldRewriteGoalsOrder. - (**********************) (* Congruence closure *) (**********************) @@ -148,7 +145,7 @@ Qed. HB.instance Definition _ s := hasDecEq.Build (@exp s) (@eqexpP s). -Notation rel_exp s := (Pred (exp s * exp s)). +Abbreviation rel_exp s := (Pred (exp s * exp s)). (****************************************) (* Congruence relations over expression *) @@ -157,9 +154,9 @@ Notation rel_exp s := (Pred (exp s * exp s)). (* R is monotone if it is preserved by application *) Section Congruence. Variable s : seq constant. -Notation symb := (symb s). -Notation exp := (exp s). -Notation rel_exp := (rel_exp s). +Abbreviation symb := (symb s). +Abbreviation exp := (exp s). +Abbreviation rel_exp := (rel_exp s). Definition Reflexive (r : rel_exp) := forall x, (x, x) \In r. @@ -242,7 +239,7 @@ Lemma clos_clos (R Q : rel_exp) : Proof. case=>e1 e2; split=>H1 C H2 H3; apply: H1 =>// [[x y]] H4. - by case: H4=>H4; [apply: H4=>// [[x1 y1]] H4|]; apply: H2; [left | right]. -case: H4=>H4; apply: H2; [left | right]=>//. +case: H4=>H4; apply: H2; [left|right=>//]. by move=>C0 H5 _; apply: H5. Qed. @@ -335,9 +332,9 @@ Proof. by apply: closE. Qed. Section Structures. Variable s : seq constant. -Notation symb := (symb s). -Notation exp := (exp s). -Notation rel_exp := (rel_exp s). +Abbreviation symb := (symb s). +Abbreviation exp := (exp s). +Abbreviation rel_exp := (rel_exp s). (* Equations in canonical form, as required by the congruence closure *) (* algorithm. An equation is in canonical form if it is an equation *) @@ -526,10 +523,10 @@ Hint Resolve uniq_reps rep_in_reps clos_rep cong_rel : core. Section MathModel. Variable s : seq constant. -Notation symb := (symb s). -Notation exp := (exp s). -Notation rel_exp := (rel_exp s). -Notation data := (data s). +Abbreviation symb := (symb s). +Abbreviation exp := (exp s). +Abbreviation rel_exp := (rel_exp s). +Abbreviation data := (data s). (* termination metric is the number of equations in the use and pending lists *) Definition metric (D : data) : nat := @@ -644,7 +641,7 @@ elim: old_use D E=>[|[[c c1] c2] old_use IH] D E H1 H2 H3 /=. move: (mem_split_uniq H2 (uniq_reps D))=>[s1][s2][L1 L2 L3]. have L4 : undup (map (rep D) (enum predT)) = reps D by []. case: (fnd _ _)=>[[[d d1] d2]|]; last first. -- rewrite IH //=; last by rewrite ffunE eq_refl E. +- rewrite IH //=; first by rewrite ffunE eq_refl E. rewrite -addSnnS; congr plus. rewrite /metric /= -addnS {1}/reps L4 /=; congr plus. rewrite -(filter_predC1 H1). @@ -656,7 +653,7 @@ case: (fnd _ _)=>[[[d d1] d2]|]; last first. case S1: (x == b')=>//=. case S2: (x == a')=>//=. by rewrite ffunE S1 S2. -rewrite IH //=; last by rewrite ffunE eq_refl E. +rewrite IH //=; first by rewrite ffunE eq_refl E. rewrite /metric /reps /= L4 addnAC addSnnS -addnAC; congr (_ + _ + _). rewrite -(filter_predC1 H1). rewrite !big_filter L1 !(perm_big _ (permEl (perm_catCA _ [::b'] _))) /=. @@ -694,9 +691,9 @@ Proof. - move=>D e p' eq E. by rewrite /metric eq addSn; apply: ltP; apply: ltnSn. move=>D e p' eq H. -rewrite join_use_metric ?H //; last first. -- by rewrite join_class_eq ?mem_filter ?rep_in_reps //= ?(eq_sym (rep D (pendR e))) H. +rewrite join_use_metric ?H //. - by rewrite join_class_eq ?mem_filter ?rep_in_reps ?H //= eq_refl. +- by rewrite join_class_eq ?mem_filter ?rep_in_reps //= ?(eq_sym (rep D (pendR e))) H. rewrite -join_class_metric ?H ?rep_in_reps //. by apply: ltP; rewrite /metric /reps /= eq /= addSn. Qed. @@ -723,11 +720,11 @@ End MathModel. Section Invariants. Variable s : seq constant. -Notation symb := (symb s). -Notation exp := (exp s). -Notation rel_exp := (rel_exp s). -Notation data := (data s). -Notation pend2eq := (@pend2eq s). +Abbreviation symb := (symb s). +Abbreviation exp := (exp s). +Abbreviation rel_exp := (rel_exp s). +Abbreviation data := (data s). +Abbreviation pend2eq := (@pend2eq s). Implicit Type D : data. (* the rep function is idempotent *) @@ -879,13 +876,13 @@ End Invariants. Section MathModelProofs. Variable s : seq constant. -Notation symb := (symb s). -Notation exp := (exp s). -Notation rel_exp := (rel_exp s). -Notation data := (data s). -Notation pend2eq := (@pend2eq s). -Notation symb2eq := (@symb2eq s). -Notation closure := (@closure s). +Abbreviation symb := (symb s). +Abbreviation exp := (exp s). +Abbreviation rel_exp := (rel_exp s). +Abbreviation data := (data s). +Abbreviation pend2eq := (@pend2eq s). +Abbreviation symb2eq := (@symb2eq s). +Abbreviation closure := (@closure s). Implicit Type D : data. (* first some basic rewrite rules *) @@ -1701,9 +1698,9 @@ Section NoPend. Variables (d : data) (c c1 c2 : symb). Hypotheses (PI : propagate_inv d) (Ev : fnd (rep d c1, rep d c2) (lookup d) = None). -Notation u1' := [ffun z => if z == rep d c1 then (c, c1, c2) :: use d z +Abbreviation u1' := [ffun z => if z == rep d c1 then (c, c1, c2) :: use d z else use d z]. -Notation u2' := [ffun z => if z == rep d c2 then (c, c1, c2) :: u1' z +Abbreviation u2' := [ffun z => if z == rep d c2 then (c, c1, c2) :: u1' z else u1' z]. Lemma propagate_nopendP : diff --git a/examples/congprog.v b/examples/congprog.v index 7731441..4ef0eb6 100644 --- a/examples/congprog.v +++ b/examples/congprog.v @@ -19,9 +19,6 @@ From pcm Require Import unionmap heap autopcm automap. From htt Require Import options model heapauto llist array. From htt Require Import kvmaps hashtab congmath. -(* change Set to Unset when porting the file, then remove the line when requiring MathComp >= 2.6 *) -Set SsrOldRewriteGoalsOrder. - (***********************************) (* Congruence closure verification *) (***********************************) @@ -36,7 +33,7 @@ Set SsrOldRewriteGoalsOrder. (* The associated math properties used in the verification are *) (* proved in the accompanying file congmath.v *) -Notation finE := finset.inE. +Abbreviation finE := finset.inE. (*************) (* Signature *) @@ -78,7 +75,7 @@ End CongrSig. Module Congr : CongrSig. Section Congr. Variable s : seq constant. -Notation symb := (symb s). +Abbreviation symb := (symb s). (* the lookup table is represented as a hash table with 10 buckets *) Local Definition K : Set := symb * symb. @@ -128,11 +125,11 @@ Definition root := ptrs. Section ShapePredicates. Variable rt : ptrs. -Notation r := (let: Ptrs r _ _ _ _ := rt in r). -Notation clist := (let: Ptrs _ clist _ _ _ := rt in clist). -Notation ulist := (let: Ptrs _ _ ulist _ _ := rt in ulist). -Notation htb := (let: Ptrs _ _ _ htb _ := rt in htb). -Notation p := (let: Ptrs _ _ _ _ p := rt in p). +Abbreviation r := (let: Ptrs r _ _ _ _ := rt in r). +Abbreviation clist := (let: Ptrs _ clist _ _ _ := rt in clist). +Abbreviation ulist := (let: Ptrs _ _ ulist _ _ := rt in ulist). +Abbreviation htb := (let: Ptrs _ _ _ htb _ := rt in htb). +Abbreviation p := (let: Ptrs _ _ _ _ p := rt in p). (* Data structure's layout in the heap *) @@ -189,12 +186,12 @@ step=>x; step; apply: [stepX f]@hc=>//= [[m]] Em. apply: [gE]=>//=; split=>//. eexists [ffun z => if z == ith k pf then x else f z]. rewrite (_ : _ \+ _ = m \+ (x :-> ith k pf \+ - x.+1 :-> null \+ hct)); last by heap_congr. + x.+1 :-> null \+ hct)); first by heap_congr. hhauto; rewrite (sepitS (ith k pf)) finE /= indx_ith ltnSn. rewrite /ctab/table !ffunE eqxx; hhauto. apply: tableP2 Hct=>// a. -- by rewrite !finE ltnS indx_injE; case: ltngtP. -by rewrite !finE !ffunE indx_injE; case: eqP=>// ->; rewrite ltnn. +- by rewrite !finE ltnS inj_indxE; case: ltngtP. +by rewrite !finE !ffunE inj_indxE; case: eqP=>// ->; rewrite ltnn. Qed. Next Obligation. case=>_ ->; apply: [stepE]=>//= rx hr Er; apply: [stepU]=>//= cl hc Ec. @@ -208,7 +205,7 @@ step=>px; step; exists d; split; last by case: (initP s). split=>[a b|/=]; first by rewrite !ffunE !inE. exists f, [ffun s => null]. rewrite (_ : px :-> null \+ _ = hr \+ ((hc' \+ hrest) \+ (hu \+ Unit \+ - (ht \+ (px :-> null \+ Unit))))); last by rewrite unitR; heap_congr. + (ht \+ (px :-> null \+ Unit))))); first by rewrite unitR; heap_congr. hhauto; rewrite /sepit sepitseq_emp // => k. by rewrite /utab/table !ffunE; split=>//; case=>_ ->. Qed. @@ -218,15 +215,15 @@ Qed. Section Internal. Variable rt : ptrs. -Notation ashape' := (ashape rt). -Notation bshape' := (bshape rt). -Notation shape' := (shape rt). +Abbreviation ashape' := (ashape rt). +Abbreviation bshape' := (bshape rt). +Abbreviation shape' := (shape rt). -Notation r := (let: Ptrs r _ _ _ _ := rt in r). -Notation clist := (let: Ptrs _ clist _ _ _ := rt in clist). -Notation ulist := (let: Ptrs _ _ ulist _ _ := rt in ulist). -Notation htb := (let: Ptrs _ _ _ htb _ := rt in htb). -Notation p := (let: Ptrs _ _ _ _ p := rt in p). +Abbreviation r := (let: Ptrs r _ _ _ _ := rt in r). +Abbreviation clist := (let: Ptrs _ clist _ _ _ := rt in clist). +Abbreviation ulist := (let: Ptrs _ _ ulist _ _ := rt in ulist). +Abbreviation htb := (let: Ptrs _ _ _ htb _ := rt in htb). +Abbreviation p := (let: Ptrs _ _ _ _ p := rt in p). Definition cT (a' b' : symb) : Type := forall x : unit, STsep {D} @@ -267,7 +264,7 @@ apply: [stepX ct, th]@th=>//= _ _ [->->]. apply: vrfV=>V; case: (ct a' =P null) Cta=>[/[dup] Ea' ->|/eqP Na']. - case/(lseq_null (validX V))=>/= ->->{cta V}; step=>{}V; exists ct, ut. rewrite (_ : rh \+ _ = rh \+ (th \+ (Unit \+ - (ctb \+ ctx)) \+ h)); last by heap_congr. + (ctb \+ ctx)) \+ h)); first by heap_congr. rewrite -fin_eta; hhauto; rewrite (sepitT1 a'); hhauto. - by rewrite /ctab/table ffunE eqxx /= /= Ea'. rewrite (sepitS b') !finE eq_sym N; hhauto. @@ -286,7 +283,7 @@ set cv2 := [ffun z => if z == a' then (behead (class d a')) apply: [gE (Data r1 cv2 (use d) (lookup d) (pending d), ct2, ut)]=>/=; last by move=>?? []. - rewrite (_ : rh1 \+ _ = rh1 \+ (th2 \+ (cta' \+ (ct a' :-> a \+ - ((ct a').+1 :-> ct b' \+ ctb) \+ ctx)) \+ h)); last by heap_congr. + ((ct a').+1 :-> ct b' \+ ctb) \+ ctx)) \+ h)); first by heap_congr. hhauto; rewrite (sepitT1 a'); hhauto. - by rewrite /ctab/table/ct2/cv2 !ffunE /= eqxx. rewrite (sepitS b') !finE eq_sym N; hhauto. @@ -353,7 +350,7 @@ apply: [stepX ut, ru]@ru=>//= _ _ [->->]; apply: vrfV=>V. case: (ut a' =P null) Ua=>[/[dup] Ea' ->|/eqP Na' {V}]. - case/(lseq_null (validX V))=>/= {V} Eu1 ->{ha'}; step. rewrite (_ : rh \+ _ = rh \+ (cth \+ (ru \+ (Unit \+ (hb' \+ h)) \+ - (ht \+ (p:-> p' \+ hp))))); last by heap_congr. + (ht \+ (p:-> p' \+ hp))))); first by heap_congr. rewrite /join_use Eu Eu1 cats0 -/d1; split=>//=; exists ct, ut. hhauto; rewrite (sepitT1 a'); hhauto; first by rewrite /utab/table Ea' Eu1. by rewrite (sepitS b') !finE eq_sym N; hhauto. @@ -378,7 +375,7 @@ case: v Eqv=>[[[e1 e2 e3]]|] /= /esym Eqv. rewrite /bshape'/class_inv/ashape/d2 (join_useT (t:=a1')) //= Eqv -/d1 /=. rewrite (_ : _ \+ _ = rh \+ (cth \+ ((ru \+ (hh \+ (hb' \+ h))) \+ (ht \+ (p :-> q \+ (q :-> comp_pend c e \+ - (q.+1 :-> r0 \+ hp))))))); last by heap_congr. + (q.+1 :-> r0 \+ hp))))))); first by heap_congr. case: Htc=>x [y][->] X1 X2; hhauto; [eauto|eauto|exact: Ut2|]. rewrite (sepitT1 a'); hhauto. - by rewrite /utab/table/ut2 !ffunE /= eqxx. @@ -393,8 +390,8 @@ apply: [gE d]=>[||??[]] //=; exists (don ++ [:: c]). rewrite -/d2 Eu2 -catA; do 2!split=>//. rewrite /bshape'/class_inv/ashape/d2 (join_useT (t:=a1')) //= Eqv -/d1 /=. rewrite (_ : _ \+ _ = rh \+ (cth \+ ((ru \+ (hh \+ ((ut a' :-> c \+ - ((ut a').+1 :-> ut2 b' \+ hb')) \+ h))) \+ (ht \+ (p :-> p' \+ hp))))); - last by heap_congr. + ((ut a').+1 :-> ut2 b' \+ hb')) \+ h))) \+ (ht \+ (p :-> p' \+ hp))))). + - by heap_congr. case: Htc=>x [y][->] X1 X2; hhauto; [eauto|eauto|exact: Ut3|]. rewrite (sepitT1 a'); hhauto. - by rewrite /utab/table/ut3 ffunE /= (negbTE N) /ut2 !ffunE /= eqxx. @@ -501,8 +498,8 @@ set d1:=Data (rep d) (class d) (use d) (lookup d) (simp_pend a b :: pending d). step; apply: [gE d1]=>//=. - rewrite Ep /= in Hp; case: Hp=>->{r0} ->{hp}. rewrite (_ : _ \+ _ = hr \+ (hc \+ (hu \+ hu' \+ (ht \+ - (p :-> x \+ (x :-> simp_pend a b \+ (x.+1 :-> null \+ Unit))))))); - last by heap_congr. + (p :-> x \+ (x :-> simp_pend a b \+ (x.+1 :-> null \+ Unit))))))). + - by heap_congr. by split=>//=; exists ct, ut; hhauto; rewrite Ep. case=>m Hm _. have L: propagate_inv d1 by apply: propagate_pendP PI. @@ -523,8 +520,8 @@ case: v Ev=>[[[e0 e1 e2]]|] Ev. step; apply: [stepX pending d]@hp=>//= x _ [x1][{}hp][-> {}Hp]. step; apply: [gE d1]=>//=. - rewrite (_ : _ \+ _ = hr \+ (hc \+ (hu \+ hu' \+ (ht \+ (p :-> x \+ - (x :-> comp_pend cx ex \+ (x.+1 :-> x1 \+ hp))))))); - last by heap_congr. + (x :-> comp_pend cx ex \+ (x.+1 :-> x1 \+ hp))))))). + - by heap_congr. by split=>//; exists ct, ut; hhauto. case=>m Hm _. have L : propagate_inv d1 by apply: propagate_pendP PI. @@ -549,7 +546,7 @@ case E : (rep d c2 == rep d c1). apply: [gX ut1]@hu=>//= [[]] {Hu}hu Hu _. rewrite (_ : _ \+ _ = hr \+ (hc \+ (hu \+ (v :-> cx \+ (v.+1 :-> x' \+ (x' :-> cx \+ (x'.+1 :-> r1 \+ hu''))) \+ - hu2) \+ (ht \+ (p :-> q \+ hp))))); last by heap_congr. + hu2) \+ (ht \+ (p :-> q \+ hp))))); first by heap_congr. exists d1; split=>//; last first. - split; first by apply: propagate_nopendP. by rewrite -Erel propagate_clos_nopendP. @@ -565,7 +562,7 @@ apply: [gX ut1]@hu=>//= [[]] {Hu}hu Hu _. rewrite (_ : _ \+ _ = hr \+ (hc \+ (hu \+ (x :-> cx \+ (x.+1 :-> r0 \+ hu'') \+ ((v :-> cx \+ (v.+1 :-> x' \+ hu1) \+ hu3))) \+ - ((ht \+ (p :-> q \+ hp)))))); last by heap_congr. + ((ht \+ (p :-> q \+ hp)))))); first by heap_congr. exists d1; split; last first. - split; first by apply: propagate_nopendP. split; first by rewrite /d1. diff --git a/examples/cyclic.v b/examples/cyclic.v index 47d8d78..092d26d 100644 --- a/examples/cyclic.v +++ b/examples/cyclic.v @@ -32,7 +32,7 @@ Definition BufferEmpty : exn := exn_from_nat 20. Module Buffer. Section Buffer. Variable T : Type. -Notation buffer := (buffer T). +Abbreviation buffer := (buffer T). (* the active part of the buffer is specified by a given list *) (* the inactive part by another arbitrary list *) @@ -174,7 +174,7 @@ Qed. (* version that overwrites data in a cyclic fashion *) (* checking that capacity != 0 is the client's problem *) (* so it can be dealt with globally *) -Program Definition overwrite (x : T) (b : buffer) : +Program Definition overewrite (x : T) (b : buffer) : STsep {xs} (fun h => 0 < capacity b /\ h \In shape b xs, [vfun _ => shape b (drop ((size xs).+1 - capacity b) (rcons xs x))]) := diff --git a/examples/dune b/examples/dune deleted file mode 100644 index af8c240..0000000 --- a/examples/dune +++ /dev/null @@ -1,9 +0,0 @@ -(coq.theory - (name htt) - (package coq-htt) - (synopsis "Hoare Type Theory with examples") - (flags :standard - -w -notation-overridden - -w -local-declaration - -w -redundant-canonical-projection - -w -projection-no-head-constant)) diff --git a/examples/hashtab.v b/examples/hashtab.v index a3b6448..eb0eac0 100644 --- a/examples/hashtab.v +++ b/examples/hashtab.v @@ -19,9 +19,6 @@ From pcm Require Import pcm unionmap heap autopcm. From htt Require Import options model heapauto. From htt Require Import array kvmaps. -(* change Set to Unset when porting the file, then remove the line when requiring MathComp >= 2.6 *) -Set SsrOldRewriteGoalsOrder. - (* hash table is array of buckets, i.e. KV maps *) (* bucket indices are provided by the hash function *) (* using dynaming kv-maps for buckets *) @@ -55,9 +52,9 @@ Definition null_root K V buckets n hash : Section HashTab. Context (K : ordType) (V : Type) {buckets : dkvm K V} {n : nat} {hash : K -> 'I_n}. -Notation KVshape := (@dkvm_shape _ _ buckets). -Notation table := (table KVshape). -Notation root := (root buckets hash). +Abbreviation KVshape := (@dkvm_shape _ _ buckets). +Abbreviation table := (table KVshape). +Abbreviation root := (root buckets hash). (* hash table is specified by a single finMap *) (* which is the "flattening" of all buckets *) @@ -159,7 +156,7 @@ case: decP=>[pf H|]; last first. (* free the array *) apply: [gE]=>//=; exists tf. (* h2 is empty *) - move: H; rewrite (eq_sepit (s2 := set0)). + move: H; rewrite (eq_sepit (s2 := set0)); last first. - by rewrite sepit0=>->; rewrite unitR. by move=>y; rewrite Ek in_set in_set0 leqNgt ltn_ord. (* k < n, read from array *) @@ -295,7 +292,7 @@ End HashTab. End HashTab. (* hash table is (static) KV map *) -Notation hashtab := HashTab.root. +Abbreviation hashtab := HashTab.root. HB.instance Definition _ K V (buckets : dkvm K V) n (hash : K -> 'I_n) := isKVM.Build K V (hashtab buckets hash) HashTab.null_root HashTab.new HashTab.free HashTab.insert HashTab.remove HashTab.lookup. diff --git a/examples/kvmaps.v b/examples/kvmaps.v index 384e6c3..d06d73a 100644 --- a/examples/kvmaps.v +++ b/examples/kvmaps.v @@ -22,9 +22,6 @@ From pcm Require Import options axioms pred ordtype finmap seqext. From pcm Require Import pcm unionmap heap autopcm automap. From htt Require Import options model heapauto. -(* change Set to Unset when porting the file, then remove the line when requiring MathComp >= 2.6 *) -Set SsrOldRewriteGoalsOrder. - (* Dynamic KV map is determined by its root pointer(s). *) (* Functions such insert and remove may modify *) (* the root, and will correspondingly return the new one. *) @@ -107,7 +104,7 @@ Definition root (K : ordType) (V : Type) := ptr. Definition null_root K V : @root K V := null. Section AssocList. Variables (K : ordType) (V : Type). -Notation fmap := (finMap K V). +Abbreviation fmap := (finMap K V). (* single entry of the map as a triple of heap cells *) Definition entry (p q : ptr) (k : K) (v : V) : heap := @@ -205,7 +202,8 @@ case: s2 O1=>xs; elim: xs h1 y h2 s1 H1=>/=. move=>[k' v'] xs; rewrite /fcat /= => IH /= h1 y h2 s1 H1 srt O2 H2. case: H2=>z[h'][-> H']; rewrite joinA; apply: IH; first 1 last. - by apply/path_sorted/srt. -- move=>H0; rewrite (allrel_in_l (xs':=k'::supp s1) _); last by apply: supp_ins. +- move=>H0; rewrite (allrel_in_l (xs':=k'::supp s1) _). + - by apply: supp_ins. rewrite allrel_consl order_path_min //=. by apply/allrel_sub_r/O2=>?; rewrite inE orbC=>->. - by move=>?; apply: H'. @@ -368,14 +366,15 @@ step; case: eqP=>[|/eqP] Ek. (* k = k' - element is found, run the deallocations *) - do 4!step; rewrite !unitL; do 2![step]=>_. (* pull out fml ++ (k->v) *) - rewrite Efr -fcat_srem; last by rewrite supp_ins inE negb_or E. + rewrite Efr -fcat_srem; first by rewrite supp_ins inE negb_or E. (* drop the element in the spec *) - rewrite rem_ins {1}Ek eq_refl rem_supp; - last by rewrite Ek; apply: notin_path. + rewrite rem_ins {1}Ek eq_refl rem_supp. + - by rewrite Ek; apply: notin_path. (* heap shape is respected *) rewrite joinC; apply/shape_fcat/Hr'; last by apply: shape_seg_rcons. (* the ordering is respected as well *) - rewrite (allrel_in_l (xs':=k::supp fml) _); last by apply: supp_ins. + rewrite (allrel_in_l (xs':=k::supp fml) _). + - by apply: supp_ins. rewrite allrel_consl order_path_min //=. by apply/(allrel_trans (z:=k))/order_path_min=>//=. (* k <> k', now branch on order comparison *) @@ -385,8 +384,8 @@ case: ifP=>Ho0. (* prove that all conditions are respected *) - exists (ins k v fml), (behd fmr), k', v'; do!split=>//. (* new focus comes after fml ++ old focus *) - - rewrite (eq_all_r (s2:=k::supp fml)) /= ?Ho' /=; - last by apply: supp_ins. + - rewrite (eq_all_r (s2:=k::supp fml)) /= ?Ho' /=. + - by apply: supp_ins. by apply/sub_all/Ol=>? /trans; apply. (* new focus comes before the new suffix *) - by apply: order_path_min. @@ -401,13 +400,13 @@ case: ifP=>Ho0. by rewrite fcat_inss // -?fcat_sins // in Hm; apply: notin_path. (* k' is bigger than k, abort *) move: (connex Ek); rewrite {}Ho0 orbC /= =>Ho0. -step=>_; rewrite rem_supp. +step=>_; rewrite rem_supp; last 1 first. - (* the shape is preserved *) rewrite joinC; apply: shape_fcat; first 1 last. - by apply: shape_seg_rcons. - by rewrite Efr; apply: shape_cons=>//; apply: order_path_min. - (* ordering is preserved *) - rewrite (allrel_in_l (xs':=k::supp fml) _); last by apply: supp_ins. +- (* ordering is preserved *) + rewrite (allrel_in_l (xs':=k::supp fml) _); first by apply: supp_ins. rewrite allrel_consl Or /=. by apply/(allrel_trans (z:=k))=>//; exact: trans. (* the element wasn't found *) @@ -436,7 +435,7 @@ case: ifP=>Ho0. - step; apply: [stepE fm]=>//=; last by move=>_ ??; step. (* invariants and shape are satisfied *) exists nil, (behd fm), k, v; do!split=>//. - - by rewrite fcat_inss; [rewrite fcat0s|apply/notin_path/all_path_supp]. + - by rewrite fcat_inss; [apply/notin_path/all_path_supp|rewrite fcat0s]. by exists Unit, (entry x next k v \+ h'); split=>//; [rewrite unitL | vauto]. (* k' is bigger than k, abort *) move: (connex Ek); rewrite {}Ho0 orbC /= =>Ho0. @@ -523,7 +522,7 @@ case: eqP=>[|/eqP] Ec. rewrite fcats0 unitR [X in _ \+ entry _ _ _ _ \+ X]joinA. (* shape and ordering invariants are satisfied *) apply/shape_seg_rcons/shape_seg_rcons=>//. - rewrite (eq_all_r (s2:=k::supp fml)) /= ?Ho0 /=; last by apply: supp_ins. + rewrite (eq_all_r (s2:=k::supp fml)) /= ?Ho0 /=; first by apply: supp_ins. by apply/sub_all/Ol=>? /trans; apply. (* cur <> null, pull out the head entry from fmr *) case: (shape_cont Ec Hr)=>k'[v'][next][hr'][Efr Or' {hr Hr Ec}-> Hr']. @@ -540,8 +539,9 @@ step; case: eqP=>[|/eqP] Ek. apply: shape_fcat; first 1 last. - by apply: shape_seg_rcons. - by apply: shape_cons=>//; rewrite Ek. - rewrite (allrel_in_l (xs':=k::supp fml) _); last by apply: supp_ins. - rewrite (allrel_in_r (ys':=k0::supp (behd fmr)) _ _); last by apply: supp_ins. + rewrite (allrel_in_l (xs':=k::supp fml) _); first by apply: supp_ins. + rewrite (allrel_in_r (ys':=k0::supp (behd fmr)) _ _). + - by apply: supp_ins. rewrite allrel_consl allrel_consr /= Ho0 Or'' /=; apply/andP; split. - by apply/sub_all/Ol=>? /trans; apply. by apply: (allrel_trans (z:=k))=>//; exact: trans. @@ -552,7 +552,8 @@ case: ifP=>Ho'0. (* prove that all conditions are respected *) - exists (ins k v fml), (behd fmr), k', v'; do!split=>//. (* new focus comes after fml ++ old focus *) - - rewrite (eq_all_r (s2:=k::supp fml)) /= ?Ho' /=; last by apply: supp_ins. + - rewrite (eq_all_r (s2:=k::supp fml)) /= ?Ho' /=. + - by apply: supp_ins. by apply/sub_all/Ol=>? /trans; apply. (* the needed key is not in fml ++ old focus *) - rewrite supp_ins inE negb_or andbC El /=. @@ -562,7 +563,7 @@ case: ifP=>Ho'0. by rewrite joinC; split=>//; [apply: shape_seg_rcons | vauto]. (* reassemble the spec, as insertions of old and new foci commute *) move=>_ m Hm _; rewrite Efr. - rewrite fcat_inss // in Hm; first by rewrite -fcat_sins in Hm. + rewrite fcat_inss // in Hm; last by rewrite -fcat_sins in Hm. by apply/notin_path/all_path_supp. (* k' is bigger than k, insert at this position *) move: (connex Ek); rewrite {}Ho'0 orbC /= =>Ho0'. @@ -577,8 +578,8 @@ rewrite Efr -fcat_sins; apply: shape_fcat; first 1 last. apply/order_path_min=>//; apply/path_supp_ins=>//. by apply/path_le/all_path_supp/Or'. (* ordering is respected *) -rewrite (allrel_in_l (xs':=k::supp fml) _); last by apply: supp_ins. -rewrite (allrel_in_r (ys':=k0::k'::supp (behd fmr)) _ _); last first. +rewrite (allrel_in_l (xs':=k::supp fml) _); first by apply: supp_ins. +rewrite (allrel_in_r (ys':=k0::k'::supp (behd fmr)) _ _). - by move=>?; rewrite ?(supp_ins,inE). rewrite allrel_consl !allrel_consr /= Ho0 Ho' Or'' /=; apply/and3P; split. - by apply/sub_all/Ol=>? /trans; apply. @@ -609,7 +610,7 @@ case: ifP=>Ho0. - step; apply: [stepE fm]=>//=; last by move=>_ ??; step. (* invariants are respected *) exists nil, (behd fm), k, v; do!split=>//. - - by rewrite fcat_inss; [rewrite fcat0s|apply/notin_path/all_path_supp]. + - by rewrite fcat_inss; [apply/notin_path/all_path_supp|rewrite fcat0s]. by exists Unit, (entry x next k v \+ h'); split=>//; [rewrite unitL|vauto]. (* k' is bigger than k, insert after the head *) move: (connex Ek); rewrite {}Ho0 orbC /= =>Ho0. @@ -627,7 +628,7 @@ End AssocList. End DAList. (* association list is dynamic KV map *) -Notation dalist := DAList.root. +Abbreviation dalist := DAList.root. HB.instance Definition _ K V := isDKVM.Build K V (dalist K V) DAList.null_root DAList.new DAList.free DAList.insert DAList.remove DAList.lookup. @@ -662,7 +663,7 @@ Module AList : AList_sig. Section AssocList. Definition root : ordType -> Type -> Set := fun _ _ => ptr. Variables (K : ordType) (V : Type). -Notation fmap := (finMap K V). +Abbreviation fmap := (finMap K V). Definition null_root : root K V := null. Definition shape (x : ptr) (f : fmap) : Pred heap := @@ -745,7 +746,7 @@ End AssocList. End AList. (* association list is (static) KV map *) -Notation alist := AList.root. +Abbreviation alist := AList.root. HB.instance Definition _ K V := isKVM.Build K V (alist K V) AList.null_root AList.new AList.free AList.insert AList.remove AList.lookup. diff --git a/examples/llist.v b/examples/llist.v index 1adba0f..ad6426d 100644 --- a/examples/llist.v +++ b/examples/llist.v @@ -158,7 +158,7 @@ elim: l1 l2 p h => [|x1 xt IH] /= l2 p h V. - by case=>->->; case/lseq_null. case=>q1 /= [h1][E] H; rewrite {}E in H V *. case/(lseq_pos (defPt_nullO V))=>x2 [q2][h2][->] /=. -do 2![case/(cancel V)=>/dynE/jmE<-{}V]. +do 2![case/(cancel V)=>/inj_dyn <-{}V]. by move=><- /(IH (behead l2) _ _ V H)=>->. Qed. diff --git a/examples/queue.v b/examples/queue.v index f62d6b0..751b850 100644 --- a/examples/queue.v +++ b/examples/queue.v @@ -24,7 +24,7 @@ Definition EmptyQueue : exn := exn_from_nat 100. Module Queue. Section Queue. Variable T : Type. -Notation queue := (queue T). +Abbreviation queue := (queue T). (* queue is singly-linked list split into *) (* the initial segment and the last node *) diff --git a/examples/quicksort.v b/examples/quicksort.v index b07be05..1dde95f 100644 --- a/examples/quicksort.v +++ b/examples/quicksort.v @@ -21,9 +21,6 @@ Import Order.NatOrder Order.TTheory. Local Open Scope order_scope. Local Open Scope nat_scope. -(* change Set to Unset when porting the file, then remove the line when requiring MathComp >= 2.6 *) -Set SsrOldRewriteGoalsOrder. - (* Brief mathematics of quickorting *) (* There is some overlap with mathematics developed for bubblesort *) (* but the development is repeated here to make the files *) @@ -104,8 +101,8 @@ suff E: {in &:(enum 'I_n) i, f =1 pffun p f}. - by rewrite !fgraph_codom /= !codomE /= -2!slice_map /=; move/eq_in_map: E. move=>/= y Hy; rewrite ffunE (@out_perm _ s) //. apply/negbT/(disjointFl Hd); rewrite inE in_itv. -case: {Hd}i Hy=>i j; rewrite slice_memE1 /=; last first. -- by rewrite count_uniq_mem; [exact: leq_b1|exact: enum_uniq]. +case: {Hd}i Hy=>i j; rewrite slice_memE1 /=. +- by rewrite count_uniq_mem; [exact: enum_uniq|exact: leq_b1]. case/and3P=>_; rewrite size_enum_ord index_enum_ord. case: j=>[[] jx|[]]; case: i=>[[] ix|[]]; rewrite ?andbF ?andbT /= ?addn0 ?addn1 // leEnat ltEnat /=. @@ -155,20 +152,20 @@ case/boolP: (Order.lt i j)=>[Hij|]; last first. move: (perm_fgraph p f). rewrite {1}(slice_extrude (fgraph (pffun p f)) (i:=Interval i j)) //=. rewrite {1}(slice_extrude (fgraph f) (i:=Interval i j)) //=. -rewrite (perm_on_notin (i:=Interval -oo i) f H); last first. +rewrite (perm_on_notin (i:=Interval -oo i) f H). - rewrite disjoint_subset; apply/subsetP=>/= z. rewrite inE=>Hz; rewrite 2!inE; apply/negP=>Hz2. - suff: (z : nat) \notin order.Order.meet (Interval -oo i) (Interval i j). + suff: (z : nat) \notin Order.meet (Interval -oo i) (Interval i j). - by move/negP; apply; rewrite in_itvI Hz2. - rewrite /order.Order.meet /= /order.Order.join /= /order.Order.meet /=. + rewrite /Order.meet /= /Order.join /= /Order.meet /=. move/ltW: Hij; rewrite bound_leEmeet=>/eqP->. by rewrite itv_ge // -leNgt. -rewrite (perm_on_notin (i:=Interval j +oo) f H); last first. +rewrite (perm_on_notin (i:=Interval j +oo) f H). - rewrite disjoint_subset; apply/subsetP=>/= z. rewrite inE=>Hz; rewrite 3!inE; apply/negP=>Hz2. - suff: (z : nat) \notin order.Order.meet (Interval i j) (Interval j +oo). + suff: (z : nat) \notin Order.meet (Interval i j) (Interval j +oo). - by move/negP; apply; rewrite in_itvI Hz. - rewrite /order.Order.meet /= /order.Order.meet /=. + rewrite /Order.meet /= /Order.meet /=. move: (bound_lex1 j); rewrite bound_leEmeet=>/eqP->. move/ltW: Hij; rewrite leEjoin=>/eqP->. by rewrite itv_ge // -leNgt. @@ -310,7 +307,7 @@ case: oleqP=>Hfp. - rewrite -(eqP Hj1). apply/(subset_trans (tperm_on i j))/subsetP=>/= x; rewrite !inE ltnS. by case/orP=>/eqP->; rewrite leqnn // andbT. - - rewrite slice_oSR slice_xR; last by rewrite bnd_simp. + - rewrite slice_oSR slice_xR; first by rewrite bnd_simp. rewrite onth_codom ffunE tpermL /= all_rcons Hfp /=. rewrite tperm_notin // in_itv /= negb_and leEnat ltEnat /= -leqNgt. - by rewrite leqnn orbT. @@ -318,8 +315,8 @@ case: oleqP=>Hfp. rewrite -(eqP Hj1) /= slice_oSR. move: Hi; rewrite leq_eqVlt; case/orP=>[/eqP->|Hi]. - by rewrite itv_swapped_bnd // bnd_simp ltEnat /= ltnS. - rewrite slice_xR; last by rewrite bnd_simp. - move: Aj; rewrite slice_xL; last by rewrite bnd_simp. + rewrite slice_xR; first by rewrite bnd_simp. + move: Aj; rewrite slice_xL; first by rewrite bnd_simp. rewrite !onth_codom /=; case/andP=>Hpi Aj. rewrite all_rcons; apply/andP; split. - by rewrite ffunE tpermR. @@ -328,7 +325,7 @@ case: oleqP=>Hfp. (* j+1 < hi, loop *) apply: [gE (pffun (tperm i j) f)]=>//=. - split=>//; rewrite !Sbo_eq; first by apply/ltnW. - - rewrite slice_oSR slice_xR; last by rewrite bnd_simp. + - rewrite slice_oSR slice_xR; first by rewrite bnd_simp. rewrite onth_codom ffunE tpermL /= all_rcons Hfp /=. rewrite tperm_notin // in_itv /= negb_and leEnat ltEnat /= -leqNgt. - by rewrite leqnn orbT. @@ -336,8 +333,8 @@ case: oleqP=>Hfp. rewrite slice_oSR. move: Hi; rewrite leq_eqVlt; case/orP=>[/eqP->|Hi]. - by rewrite itv_swapped_bnd // bnd_simp ltEnat /= ltnS. - rewrite slice_xR; last by rewrite bnd_simp. - move: Aj; rewrite slice_xL; last by rewrite bnd_simp. + rewrite slice_xR; first by rewrite bnd_simp. + move: Aj; rewrite slice_xL; first by rewrite bnd_simp. rewrite !onth_codom /=; case/andP=>Hpi Aj. rewrite all_rcons; apply/andP; split. - by rewrite ffunE tpermR. @@ -358,11 +355,11 @@ case: (leq_choose Hj)=>Hj1. step=>_; split. - by rewrite leqnn /= -(eqP Hj1); apply: ltnW. exists 1%g; rewrite pffunE1; split=>//; first by exact: perm_on1. - rewrite -(eqP Hj1) slice_oSR slice_xR; last by rewrite bnd_simp. + rewrite -(eqP Hj1) slice_oSR slice_xR; first by rewrite bnd_simp. by rewrite onth_codom /= all_rcons Hfp. (* j+1 < hi, loop *) apply: [gE f]=>//=; split=>//. -rewrite Sbo_eq slice_oSR slice_xR; last by rewrite bnd_simp. +rewrite Sbo_eq slice_oSR slice_xR; first by rewrite bnd_simp. by rewrite onth_codom /= all_rcons Hfp. Qed. Next Obligation. @@ -398,18 +395,18 @@ exists (tperm v hi * p)%g; split=>//. apply/(subset_trans Pm)/subsetP=>x; rewrite !inE. by case/andP=>->/ltnW->. - by rewrite pffunEM. -- rewrite pffunEM ffunE tpermL ffunE (out_perm Pm); last first. +- rewrite pffunEM ffunE tpermL ffunE (out_perm Pm). - by rewrite inE negb_and -!ltnNge leqnn orbT. rewrite tperm_notin // in_itv negb_and /= leEnat ltEnat /= -leqNgt. - by rewrite leqnn orbT. by case/andP: Hi=>_ ->; rewrite orbT. -rewrite pffunEM ffunE tpermL ffunE (out_perm Pm); last first. +rewrite pffunEM ffunE tpermL ffunE (out_perm Pm). - by rewrite inE negb_and -!ltnNge leqnn orbT. case/andP: Hi=>_; rewrite leq_eqVlt; case/orP=>[/eqP->|Hi]. - by rewrite slice_kk. -move: Ah; rewrite slice_xL; last by rewrite bnd_simp. +move: Ah; rewrite slice_xL; first by rewrite bnd_simp. rewrite onth_codom /=; case/andP=>Hg Ha. -rewrite slice_xR; last by rewrite bnd_simp. +rewrite slice_xR; first by rewrite bnd_simp. rewrite onth_codom /= all_rcons; apply/andP; split. - by rewrite ffunE tpermR. by rewrite tperm_notin // in_itv negb_and /= ltEnat /= -!leqNgt leqnn // orbT. @@ -508,7 +505,7 @@ move: (ltn_ord v); rewrite ltnS leq_eqVlt; case/orP=>[/eqP Ev|Nv]. apply/subset_leqif_cards/subsetP=>/= z. by rewrite !inE -eqn_leq =>/eqP E; apply/eqP/ord_inj. move: Sl Hpl; rewrite Eh Ev Epr mul1g => Sl Hpl. - rewrite slice_xR; last by rewrite bnd_simp leEnat; move: Hvl; rewrite Ev. + rewrite slice_xR; first by rewrite bnd_simp leEnat; move: Hvl; rewrite Ev. rewrite {22}(_ : n = (ord_max : 'I_n.+1)) // onth_codom /= sorted_rconsE //=. move: Sl; rewrite slice_oPR /Order.lt/= lt0n -{1}Ev Nv0. move=>->; rewrite andbT; move: Al; rewrite Ev. @@ -525,7 +522,7 @@ move: (ltn_ord v); rewrite ltnS leq_eqVlt; case/orP=>[/eqP Ev|Nv]. by case/andP=>->/= Hz; apply: (leq_ltn_trans Hz); rewrite ltn_predL lt0n -Ev. (* the general case *) rewrite Nv in Hpr Sr. -rewrite (slice_split _ true (x:=v) (i:=`[l : nat, h : nat])) /=; last first. +rewrite (slice_split _ true (x:=v) (i:=`[l : nat, h : nat])) /=. - by rewrite in_itv /= leEnat; apply/andP. rewrite (slice_xL (x:=v)) // onth_codom /=. have -> : pffun (pr * (pl * p)) f v = pffun p f v. @@ -538,16 +535,16 @@ have -> : pffun (pr * (pl * p)) f v = pffun p f v. by apply/(subset_trans Hpl)/subsetP=>/= z; rewrite !inE=>->. rewrite (out_perm Hmul) // inE negb_or !negb_and -leqNgt -!ltnNge leqnn /=. by rewrite andbT ltn_predL lt0n Nv0 orbT. -rewrite {1}pffunEM (perm_on_notin _ Hpr); last first. +rewrite {1}pffunEM (perm_on_notin _ Hpr). - rewrite disjoint_subset; apply/subsetP=>/= z. rewrite 3!inE in_itv /= negb_and leEnat ltEnat /= -leqNgt -ltnNge. by case/andP=>/ltnW-> _; rewrite orbT. rewrite slice_oSL in Sr. -rewrite mulgA (perm_onC Hpr Hpl) in Sr *; last first. +rewrite mulgA (perm_onC Hpr Hpl) in Sr *. - rewrite disjoint_subset; apply/subsetP=>/= z; rewrite !inE negb_and -!ltnNge. case/andP=>Hz _; apply/orP; right. by apply/leq_ltn_trans/Hz; exact: leq_pred. -rewrite -mulgA (pffunEM _ (pr * p)%g) (perm_on_notin _ Hpl) in Sr *; last first. +rewrite -mulgA (pffunEM _ (pr * p)%g) (perm_on_notin _ Hpl) in Sr *. - rewrite disjoint_subset; apply/subsetP=>/= z. rewrite 3!inE in_itv /= negb_and leEnat /= -leqNgt -ltnNge. case/andP=>_ Hz; apply/orP; left; apply: (leq_trans Hz). diff --git a/examples/stack.v b/examples/stack.v index fda64fa..0c5f04a 100644 --- a/examples/stack.v +++ b/examples/stack.v @@ -24,7 +24,7 @@ Definition EmptyStack := exn_from_nat 25. Module Stack. Section Stack. Variable T : Type. -Notation stack := (stack T). +Abbreviation stack := (stack T). (* stack is a pointer to a singly-linked list *) Definition shape s (xs : seq T) := diff --git a/examples/union_find.v b/examples/union_find.v index 9626df3..bb28230 100644 --- a/examples/union_find.v +++ b/examples/union_find.v @@ -1,5 +1,5 @@ (* -Copyright 2023 IMDEA Software Institute +Copyright 2025 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 @@ -11,686 +11,170 @@ See the License for the specific language governing permissions and limitations under the License. *) -From mathcomp Require Import ssreflect ssrbool ssrfun fintype. -From mathcomp Require Import eqtype ssrnat seq bigop choice. -From pcm Require Import options axioms pred seqext. -From pcm Require Import prelude pcm unionmap natmap heap autopcm automap. -From htt Require Import options model heapauto tree. - -(* change Set to Unset when porting the file, then remove the line when requiring MathComp >= 2.6 *) -Set SsrOldRewriteGoalsOrder. - -(**************) -(**************) -(* Union-find *) -(**************) -(**************) - -(******************) -(* inverted trees *) -(******************) - -(* the layout of a tree in the heap and the map of set reps of the tree *) -(* should lock to avoid exposing the folds upon simplification *) -(* as they make the lemmas unreadable *) -(* will provide the explicit big equations for rewriting *) - -Fixpoint tlay (t : tree ptr) (r : ptr) : heap := - foldr (fun x h => h \+ tlay x (rt t)) (rt t :-> r) (ch t). - -Fixpoint tset (t : tree ptr) (r : ptr) : umap ptr ptr := - foldr (fun t h => h \+ tset t r) (rt t \\-> r) (ch t). - -(* explicit equations for expanding the defs of tlayout and tset *) -(* Ideally, these should have been the actual fixed point defs *) -(* but Coq can't see that such defs are well-founded *) - -Lemma tlayE t r : - tlay t r = - rt t :-> r \+ \big[join/Unit]_(x <- ch t) (tlay x (rt t)). -Proof. -case: t=>a ts /=; rewrite foldr_join; congr (_ \+ _). -elim: ts=>[|t ts IH] /=; first by rewrite big_nil. -by rewrite big_cons IH joinC. -Qed. - -Lemma tsetE t r : - tset t r = - rt t \\-> r \+ \big[join/Unit]_(x <- ch t) (tset x r). -Proof. -case: t=>a ts /=; rewrite foldr_join; congr (_ \+ _). -elim: ts=>[|t ts IH] /=; first by rewrite big_nil. -by rewrite big_cons IH joinC. -Qed. - - -(*******************) -(* dom/valid/range *) -(* inverted trees *) -(*******************) - -Lemma valid_dom_tset (t : tree ptr) r : - (valid (tset t r) = uniq (preorder t)) * - (dom (tset t r) =i - if valid (tset t r) then preorder t else [::]). -Proof. -elim/tree_ind2: t r=>a ts IH r. rewrite tsetE preorderE. -rewrite validPtUn !big_valid_dom_seq /= big_cat_mem_has. -case: allP=>H /=; last first. -- split=>[|x]; last first. - - by rewrite domUn inE validPtUn !big_valid_dom_seq; case: allP. - rewrite andbC; case: uniq_big_catE=>//=; case=>H1 _ _. - by case: H=>t T; rewrite IH // H1. -case U1: (uniq _)=>/=; last first. -- rewrite andbC; case U2: (uniq _)=>/=; last first. - - by split=>// x; rewrite domPtUn inE validPtUn /= !big_valid_dom_seq U1 andbF. - case/uniq_big_catE: U2=>H1 H2 H3. - case: uniq_big_catE U1=>//; case; split. - - by move=>i; rewrite uniq_dom. - - move=>i k X D; apply: (H2 i k X). - by rewrite (IH i X r) H in D. - move=>i j k X Y Di Dj. - apply: (H3 i j k)=>//; first by rewrite (IH i X r) H in Di. - by rewrite (IH j Y r) H in Dj. -rewrite big_cat_mem_has andbC; case: uniq_big_catE=>/=; last first. -- case/uniq_big_catE: U1=>H1 H2 H3; case; split. - - by move=>i X; rewrite -(IH i X r) H. - - by move=>i k X D; apply: (H2 i k X); rewrite (IH i X r) H. - move=>i j k X Y Di Dj; apply: (H3 i j k X Y); first by rewrite (IH i X r) H. - by rewrite (IH j Y r) H. -case=>K1 K2 K3; split=>[|x]. -- by rewrite -!all_predC; apply: eq_in_all=>i X; rewrite /= IH ?H. -rewrite domPtUn inE validPtUn /= !big_valid_dom_seq U1 andbT. -case: allP=>//= _; rewrite !big_cat_mem_has -all_predC. -case: allP=>//= A; rewrite inE big_cat_mem_has eq_sym. -by case: (x =P a)=>//= _; apply: eq_in_has=>i X; rewrite IH ?H. -Qed. - -Lemma valid_tset (t : tree ptr) r : - valid (tset t r) = uniq (preorder t). -Proof. by rewrite valid_dom_tset. Qed. - -Lemma dom_tset_ord (t : tree ptr) r : - dom (tset t r) =i - if valid (tset t r) then preorder t else [::]. -Proof. by move=>x; rewrite valid_dom_tset. Qed. - -Lemma dom_tset (t : tree ptr) r : - valid (tset t r) -> dom (tset t r) =i t. -Proof. by move=>V x; rewrite dom_tset_ord V in_preorder. Qed. - -Lemma dom_tsetE (t : tree ptr) r : - dom (tset t r) =i [pred x | valid (tset t r) && (x \in t)]. -Proof. by move=>x; rewrite inE dom_tset_ord -in_preorder; case: ifP. Qed. - -Lemma size_dom_tset (t : tree ptr) r : - valid (tset t r) -> - size (dom (tset t r)) = size (preorder t). -Proof. -move=>V; apply/eqP; rewrite -uniq_size_uniq ?uniq_dom -?(valid_tset t r) //. -by move=>x; rewrite dom_tset_ord V. -Qed. - -Lemma range_tset (t : tree ptr) r : - valid (tset t r) -> range (tset t r) =i [:: r]. -Proof. -elim/tree_ind2: t=>a ts IH. rewrite tsetE /= => V x. -rewrite rangePtUn inE validPtUn (validX V) (validPtUnD V) inE /= eq_sym. -case: eqVneq=>//= N; apply/negP=>/mem_rangeX [k]. -case/bigInX=>i /[dup] X /mem_seqP X' /mem_range. rewrite IH //. -- by rewrite inE (negbTE N). -by apply: big_validV (validX V) X. -Qed. - -Lemma domeq_tlay_tset (t : tree ptr) r1 r2 : - {in t, forall x, x != null} -> - dom_eq (tlay t r1) (tset t r2). -Proof. -elim/tree_ind1: t r1 r2=>a ts IH r1 r2 Tn. -rewrite tlayE tsetE /= domeqPtUn ?Tn // big_domeqUn //. -by move=>x X; apply: IH=>// z Z; apply: Tn (in_tnode2 X Z). -Qed. - -Lemma valid_tlayE (t : tree ptr) r : - valid (tlay t r) -> {in t, forall x, x != null}. -Proof. -elim/tree_ind1: t r=>a ts IH r; rewrite tlayE /= => V x; rewrite in_tnode. -case/orP=>[/eqP ->|]; first by rewrite (validPtUn_cond V). -case/hasPIn=>y Y; apply: IH =>//; apply: (big_validV (validX V) Y). -Qed. - -Lemma valid_tlay (t : tree ptr) r : - valid (tlay t r) = - valid (tset t r) && all (fun x => x != null) (preorder t). -Proof. -apply/idP/idP; last first. -- by case/andP=>V /tallP W; rewrite (domeqVE (domeq_tlay_tset r r W)). -move/[dup]=>V /valid_tlayE /[dup] N /tallP ->. -by rewrite -(domeqVE (domeq_tlay_tset r r N)) V. -Qed. - -Lemma valid_tlayN (t : tree ptr) r : - valid (tlay t r) -> valid (tset t r). -Proof. by rewrite valid_tlay=>/andP []. Qed. - -Lemma dom_tlay (t : tree ptr) r : - valid (tlay t r) -> dom (tlay t r) =i t. -Proof. -rewrite valid_tlay=>/andP [V /tallP A] x. -by rewrite -(dom_tset V) (domeqDE (domeq_tlay_tset r r A)). -Qed. - -Lemma dom_tlayE (t : tree ptr) r : - dom (tlay t r) =i [pred x | valid (tlay t r) && (x \in t)]. -Proof. -move=>x; apply/idP/idP; last by rewrite inE; case/andP=>V; rewrite dom_tlay. -by move=>D; rewrite inE (dom_valid D) -(dom_tlay (dom_valid D)). -Qed. - -Lemma size_dom_tlay (t : tree ptr) r : - valid (tlay t r) -> - size (dom (tlay t r)) = size (preorder t). -Proof. -move=>V; apply/eqP; rewrite -uniq_size_uniq ?uniq_dom //. -- by rewrite -(valid_tset t r) (valid_tlayN V). -by move=>x; rewrite dom_tlay // in_preorder. -Qed. - -(* no strong range_tlay lemma; weak one below *) - -(***********************************) -(* parent-child relation and roots *) -(* for inverted trees *) -(***********************************) - -Lemma find_tset x r t : - find x (tset t r) = - if valid (tset t r) && (x \in t) then Some r else None. -Proof. -case V : (valid (tset t r))=>/=; last first. -- by move/invalidE: (negbT V)=>->; rewrite find_undef. -rewrite -(dom_tset V); case: dom_find=>// v E _. -elim/tree_ind1: t V E=>a ts IH; rewrite tsetE /= => V. -rewrite !findPtUn2 //; case: (x =P a)=>//= _. -case/big_find_someX=>i X /[dup] D /In_find/In_valid W. -by apply: IH X W (D). -Qed. - -Lemma In_tsetP x r t: - reflect ((x, r) \In tset t (rt t)) - [&& valid (tset t (rt t)), x \in t & r == rt t]. -Proof. -apply/(iffP idP); rewrite In_find find_tset. -- by case/and3P=>->-> /eqP ->. -by case: ifP=>// /andP [->->][->] /=. -Qed. - -Lemma find_tlayTp (x : ptr) (t : tree ptr) (p : dynamic id) r : - find x (tlay t r) = Some p -> - exists x : ptr, p = idyn x. -Proof. -elim/tree_ind1: t r=>a t IH r; rewrite tlayE /=. -move/[dup]=>/In_find/In_valid V; rewrite findPtUn2 //. -case: eqP=>[_ [<-]|_]; first by exists r. -by case/big_find_someX=>z Z /(IH _ Z). -Qed. - -Lemma tlay_rt x (p : ptr) t r : - find x (tlay t r) = Some (idyn p) -> - if x == rt t then p = r else (p != x) && (p \in t). -Proof. -elim/tree_ind1: t r=>a ts IH r; rewrite tlayE /= => /[dup]/In_find/In_valid V. -rewrite findPtUn2 // in_tnode; case: eqVneq=>[_ [/inj_pair2]|N] //. -case/big_find_someX=>t T /(IH _ T) H; case: ifP H N=>[_ ->|_]. -- by rewrite eqxx // eq_sym =>->. -by case/andP=>-> H _; case: orP=>//; elim; right; apply/hasPIn; exists t. -Qed. - -Lemma tlay_rt_loop t x : - find x (tlay t (rt t)) = Some (idyn x) -> x = rt t. -Proof. by move/tlay_rt; rewrite eqxx /=; case: eqP. Qed. - -Lemma tlay_rt_rt (p : ptr) t r : - find (rt t) (tlay t r) = Some (idyn p) -> p = r. -Proof. by move/tlay_rt; rewrite eqxx. Qed. - - -(********************) -(********************) -(* inverted forests *) -(********************) -(********************) - -Definition flay ts := foldr (fun t h => tlay t (rt t) \+ h) Unit ts. -Definition fset ts := foldr (fun t h => tset t (rt t) \+ h) Unit ts. - -Lemma flayE ts : flay ts = \big[join/Unit]_(t <- ts) (tlay t (rt t)). -Proof. by elim: ts=>[|t ts IH] /=; [rewrite big_nil|rewrite big_cons IH]. Qed. - -Lemma fsetE ts : fset ts = \big[join/Unit]_(t <- ts) (tset t (rt t)). -Proof. by elim: ts=>[|t ts IH] /=; [rewrite big_nil|rewrite big_cons IH]. Qed. - -Lemma find_flayTp (x : ptr) (ts : seq (tree ptr)) (p : dynamic id) : - find x (flay ts) = Some p -> - exists y : ptr, p = idyn y. -Proof. -elim: ts=>[|t ts IH] //= /[dup] /In_find/In_valid V; rewrite findUnL //. -by case: ifP=>_; [apply: find_tlayTp | apply: IH]. -Qed. - -Lemma In_fsetP x r ts : - reflect ((x, r) \In fset ts) - (valid (fset ts) && has (fun t => (x \in t) && (r == rt t)) ts). -Proof. -rewrite fsetE; apply/(iffP idP). -- case/andP=>V /hasP [i] /mem_seqP X /andP [H1 H2]. - by apply: bigIn (V) (X) _; apply/In_tsetP; rewrite H1 H2 (big_validV V). -move/[dup]/In_valid=>-> /bigInX [i] /mem_seqP X /In_tsetP /andP [V H]. -by apply/hasP; exists i. -Qed. - -Lemma dom_fset (ts : seq (tree ptr)) x : - valid (fset ts) -> - x \in dom (fset ts) = has (fun t => x \in t) ts. -Proof. -elim: ts=>[|t ts IH] //= V. -by rewrite domUn V inE /= IH ?dom_tset ?(validX V). -Qed. - -Lemma dom_fsetE (ts : seq (tree ptr)) : - dom (fset ts) =i - [pred x | valid (fset ts) && has (fun t => x \in t) ts]. -Proof. -move=>x; rewrite inE. -case V : (valid (fset ts))=>/=; first by apply: dom_fset. -by move/invalidE: (negbT V)=>->; rewrite dom_undef. -Qed. - -Lemma range_fsetE ts : - range (fset ts) =i - [pred x | valid (fset ts) && has (fun t => x == rt t) ts]. -Proof. -elim: ts=>[|t ts IH] //= x. -rewrite rangeUn inE; case V : (valid _)=>//=. -by rewrite range_tset ?inE ?IH ?(validX V). -Qed. - -Lemma range_fset ts x : - valid (fset ts) -> - x \in range (fset ts) = has (fun t => x == rt t) ts. -Proof. by move=>V; rewrite range_fsetE V inE. Qed. - - -Lemma valid_fset_tset (ts : seq (tree ptr)) : - valid (fset ts) -> - {in ts, forall i, valid (tset i (rt i))}. -Proof. by move=>+ i Hi; rewrite fsetE big_valid_seq=>/andP [/allP /(_ i Hi)]. Qed. - -Lemma valid_flay_tlay (ts : seq (tree ptr)) : - valid (flay ts) -> - {in ts, forall i, valid (tlay i (rt i))}. -Proof. by move=>+ i Hi; rewrite flayE big_valid_seq=>/andP [/allP /(_ i Hi)]. Qed. - -Lemma dom_flay (ts : seq (tree ptr)) x : - valid (flay ts) -> - x \in dom (flay ts) = has (fun t => x \in t) ts. -Proof. -move=>V; rewrite flayE big_domUn inE -flayE V; apply: eq_in_has=>i H. -by rewrite dom_tlay // (valid_flay_tlay V). -Qed. - -Lemma dom_flayE (ts : seq (tree ptr)) : - dom (flay ts) =i - [pred x | valid (flay ts) && has (fun t => x \in t) ts]. -Proof. -move=>x; case V : (valid _)=>/=; last first. -- by move/invalidE: (negbT V)=>->; rewrite dom_undef. -by rewrite inE dom_flay. -Qed. - -Lemma valid_flay_fset (ts : seq (tree ptr)) : - valid (flay ts) = valid (fset ts) && - all (fun t => all (fun i => i != null) (preorder t)) ts. -Proof. -elim: ts=>[|t ts IH] //=. -rewrite !validUnAE IH -!andbA valid_tlay /=. -case V1 : (valid _)=>//=. -case V2 : (valid _)=>/=; last by rewrite andbF. -case A1 : (all _)=>/=; last by rewrite andbF. -case A2 : (all _)=>/=; last by rewrite andbF. -rewrite andbT !all_predC; rewrite V2 A2 /= in IH; congr (~~ _). -have /eq_has -> : dom (tlay t (rt t)) =i dom (tset t (rt t)). -- by move=>x; rewrite dom_tlay ?valid_tlay ?V1 ?A1 ?dom_tset. -by apply: eq_has_r=>x; rewrite dom_flay // dom_fset. -Qed. - -Lemma dom_flay_fset (ts : seq (tree ptr)) : - all (fun t => all (fun i => i != null) (preorder t)) ts -> - dom (flay ts) = dom (fset ts). -Proof. -move=>A; apply/domE=>x; rewrite dom_flayE dom_fsetE !inE valid_flay_fset A /=. -by rewrite andbT. -Qed. - -Lemma subvalid_flay (ts : seq (tree ptr)) : - valid (flay ts) -> valid (fset ts). -Proof. by rewrite valid_flay_fset=>/andP []. Qed. - -Lemma subdom_flay (ts : seq (tree ptr)) : - {subset dom (flay ts) <= dom (fset ts)}. -Proof. -move=>x /[dup] /dom_valid; rewrite valid_flay_fset=>/andP [V A]. -by rewrite dom_flay_fset. -Qed. - -Lemma valid_flayN2 t (ts : seq (tree ptr)) : - valid (tlay t (rt t) \+ flay ts) -> - valid (tset t (rt t) \+ fset ts). -Proof. -by rewrite (_ : valid _ = valid (flay (t :: ts))) // => /subvalid_flay. -Qed. - -Lemma flay_rt x (p : ptr) ts : - find x (flay ts) = Some (idyn p) -> - if x \in range (fset ts) then p == x - else (p != x) && has (fun t => (x \in t) && (p \in t)) ts. -Proof. -elim: ts=>[|t ts IH] /=; first by rewrite find0E. -move/[dup]=>/In_find/In_valid V. -rewrite findUnL // rangeUn inE (valid_flayN2 V) /=. -rewrite dom_tlayE inE (validX V) /=. -rewrite range_tset ?(valid_tlayN (validX V)) // inE. -case: eqVneq=>[->|N] /=; first by rewrite rt_in=>/tlay_rt_rt ->; rewrite eqxx. -case: ifP=>X // /tlay_rt; rewrite (negbTE N)=>/andP [P1 P2]. -rewrite {P1}(negbTE P1) range_fset ?(subvalid_flay (validX V)) // ifN ?P2 //. -apply/hasPn=>y Ty; apply: contra N=>/eqP ?; subst x; exfalso. -apply: (dom_inNLX (k:=rt y) V). -- by rewrite dom_tlayE inE (validX V). -by rewrite dom_flayE inE (validX V); apply/hasP; exists y=>//; rewrite rt_in. -Qed. - -Lemma flay_rt_domL x (p : ptr) ts : - find x (flay ts) = Some (idyn p) -> x \in dom (fset ts). -Proof. by move=>H; apply: subdom_flay (find_some H). Qed. - -Lemma flay_rt_domR x (p : ptr) ts : - find x (flay ts) = Some (idyn p) -> p \in dom (fset ts). -Proof. -move/[dup]=>/In_find/In_dom /= H /flay_rt. -case: ifP=>[_ /eqP ->|_]; first by apply: subdom_flay. -case/andP=>_ H1; rewrite dom_fset; first by apply: sub_has H1=>z /andP []. -by apply: subvalid_flay (dom_valid H). -Qed. - -Lemma size_dom_flay ts : - valid (flay ts) -> - size (dom (flay ts)) = \sum_(t <- ts) size (preorder t). -Proof. -elim: ts=>[|t ts IH /=]; first by rewrite big_nil. -move=>V; rewrite big_cons size_domUn //. -by rewrite -IH ?(validX V) // -(size_dom_tlay (validX V)). -Qed. - -Lemma dom_flay_big (ts : seq (tree ptr)) : - valid (flay ts) -> - dom (flay ts) =i \big[cat/[::]]_(t <- ts) preorder t. -Proof. -move=>V x; rewrite flayE big_domUn inE -flayE V big_cat_mem_has /=. -by apply: eq_in_has=>i H; rewrite dom_tlay ?in_preorder ?(valid_flay_tlay V H). -Qed. - -Lemma flay_uniq ts : - valid (flay ts) -> - uniq (\big[cat/[::]]_(t <- ts) preorder t). -Proof. -move=>V; rewrite -(eq_uniq _ (dom_flay_big V)) ?uniq_dom //. -by rewrite size_dom_flay ?size_big_cat. -Qed. - -Lemma flay_mem_eq x i j ts : - valid (flay ts) -> - x \in i -> i \in ts -> - x \in j -> j \in ts -> i = j. -Proof. -move=>V Xi /[dup] Ti /mem_seqP Ti' Xj /[dup] Tj /mem_seqP Tj'. -apply: big_cat_uniq_pairwise (flay_uniq V) Ti' Tj' _. -by apply/hasP; exists x=>/=; rewrite in_preorder. -Qed. - -Lemma fset_pts_rev x r ts : - valid (flay ts) -> - (x, r) \In fset ts -> - exists2 p, [pcm x :-> p <= flay ts] & (p, r) \In fset ts. -Proof. -move=>V /[dup] H /In_fsetP /andP [Vs] /hasP [i] Ti /andP [Xi /eqP E]. -have : x \in dom (flay ts) by rewrite dom_flay // -dom_fset // (In_dom H). -case/In_domX=>_ /In_find/[dup] /find_flayTp [p -> F]. -exists p; first by exists (free (flay ts) x); apply: um_eta2. -move/flay_rt: F. case: ifP=>[_ /eqP ->|_] //. -case/andP=>N /hasP [j Tj] /andP [Xj P]. -apply/In_fsetP; rewrite Vs; apply/hasP; exists j=>//. -by rewrite P E (flay_mem_eq V Xi Ti Xj Tj) eqxx. -Qed. - -Lemma froot_loop x r ts : - (x, r) \In fset ts -> - find x (flay ts) = Some (idyn x) -> - x = r. -Proof. -elim: ts r=>[|t ts IH] r //= /In_find H1 H2. -move: (dom_valid (find_some H1)) (dom_valid (find_some H2))=>V1 V2. -move: H1 H2; rewrite !findUnL ?(dom_tset,dom_tlay,validL V1,validL V2) //. -case A: (x \in t). -- rewrite find_tset ifT; first by case=>E; move/tlay_rt_loop=>K; rewrite K -E. - apply/andP; split=>//; first by apply: validL V1. -by rewrite -In_find; apply: IH. -Qed. - -Definition change_ts (ts : seq (tree ptr)) (a b : tree ptr) := - if a == b then ts - else TNode (rt b) (a :: ch b) :: - filter (fun x => (x != a) && (x != b)) ts. - -Lemma flay_cons (a : tree ptr) b : flay (a :: b) = flay [:: a] \+ flay b. -Proof. by rewrite !flayE !big_cons !big_nil unitR. Qed. - -Lemma flay_tree (a: tree ptr): - flay ([:: a]) = tlay a (rt a). -Proof. by rewrite flayE big_cons big_nil unitR. Qed. - -Lemma flay_uniq_ts ts : valid (flay ts) -> uniq ts. -Proof. -move=>/flay_uniq/uniq_big_catE [_ H _]; apply: count_mem_uniq=>t. -case T : (t \in ts); last by apply/count_memPn; apply: negbT. -by apply: (H t (rt t))=>//; rewrite in_preorder rt_in. -Qed. - -Lemma nochange_mapv (K : ordType) (V : eqType) (m : umap K V) b x : - valid m -> - x \notin range m -> - mapv [fun v => v with x |-> b] m = m. -Proof. -move=>W /negP R; apply: umem_eq=>[|//|[k v]]; first by rewrite pfV. -rewrite In_omapX /=; split=>[[w]|H]. -- by case: (w =P x)=>[->{w} /mem_range/R|_ /[swap][[]->]//]. -by exists v=>//; case: (v =P x) H=>// -> /mem_range/R. -Qed. - -Lemma change_tset ta a b: - valid (tset ta a) -> - mapv [fun v => v with a |-> b] (tset ta a) = tset ta b. -Proof. -elim/tree_ind2: ta a=>c ts IH a //; rewrite !tsetE /= => V. -rewrite omapVUn omapPt /= eq_refl big_omapVUn !(validX V). -congr (_ \+ _); apply: eq_big_seq=>i /[dup] K /mem_seqP K'. -by rewrite IH // (big_validV (validX V) K'). -Qed. - -(*******************) -(* Shape predicate *) -(*******************) - -Definition shape rs h := exists ts, [/\ h = flay ts, rs = fset ts & valid h]. - -Lemma shapeV rs h : shape rs h -> valid rs. -Proof. by case=>ts [->->]; rewrite valid_flay_fset=>/andP []. Qed. - -(*******) -(* NEW *) -(*******) - -(* Creates a new equivalence class with a single element *) - -Program Definition newT : - STsep {m} (shape m, [vfun r => shape (r \\-> r \+ m)]) := - Do (p <-- alloc null; - p ::= p;; +From HB Require Import structures. +From Stdlib Require Import Recdef ssreflect ssrfun. +From mathcomp Require Import eqtype ssrnat ssrbool seq path bigop. +From pcm Require Import options axioms pred prelude seqperm seqext. +From pcm Require Import pcm unionmap natmap heap auto autouniq autopcm automap. +From htt Require Import options model heapauto graph. + +(*****************************) +(*****************************) +(* Union-find data structure *) +(*****************************) +(*****************************) + +(* The structure maintains a set of equivalence classes *) +(* each with its own representative. Exported methods are: *) +(* - new : allocates a new element in its own equiv_class *) +(* - find x : finds representative of x's equivalence class *) +(* - union x1 x2 : joins the classes of x1 and x2, with one *) +(* of x1 or x2 the new overall representative *) + +(* NOTE: Types below are *unique* in using small-footprint *) +(* specs for the structure's methods. Quite surprisingly, *) +(* the related work on the union-find structure seems to *) +(* exclusively use large footprint specs, in contravention *) +(* to the key reasoning patterns of separation logic. *) + +(***************************************) +(* Abstractions for the specification *) +(***************************************) + +(* equiv_class s x = nodes in set s have x as representative *) +(* describes *one* inverted tree in the union-find structure *) + +Definition equiv_class (s : fset node) (x : node) : Pred heap := + fun h => exists (g : unary_graph unit), + [/\ h \In graph1 g, summits g =i loops g, + summits g =i [:: x] & dom s =i nodes g]. + +(* common inference out of equiv_class exposes graph g *) +Lemma eqcE h s x : + h \In equiv_class s x <-> + exists (g : unary_graph unit), + [/\ h \In graph1 g, valid g, valid s, x != 0, + summits g =i loops g, summits g =i [:: x], dom s =i nodes g, + x \in summits g, x \in loops g, x \in nodes g & x \in dom s]. +Proof. +split=>[[g][H1 H2 H3 H4]|[g][]]; exists g=>//. +have [N D] : x \in nodes g /\ x \in dom s by rewrite H4 loopsD // -H2 H3 inE. +by rewrite (dom_valid N) (dom_cond N) (dom_valid D) -H2 H3 inE. +Qed. + +(* clients don't need g, but reason out of disjointness of *) +(* represented classes and the representative being inside the class *) + +Lemma eqcD h s x : + h \In equiv_class s x -> + x \in dom s. +Proof. by case/eqcE=>g []. Qed. + +Lemma eqcV2 h1 h2 s1 s2 x1 x2 : + h1 \In equiv_class s1 x1 -> + h2 \In equiv_class s2 x2 -> + valid (h1 \+ h2) -> + valid (s1 \+ s2). +Proof. +case/eqcE=>g1 [H1 _ V1 ????????] /eqcE [g2][H2 _ V2 ????????]. +move/(In_graph1V2 H1 H2)=>V; apply/domeqVUn/V; apply/domeqP; +by (split; [|apply/domE]); rewrite ?(validX V, V1, V2). +Qed. + +(******************************) +(* Union-find code and proof *) +(* in small footprint style *) +(******************************) + +(* new : creates fresh equivalence class with single element *) + +Program Definition new : + STsep (emp, [vfun r h => h \In equiv_class (#r) r]) := + Do (p <-- allocb tt 2; + p.+1 ::= p;; ret p). Next Obligation. -case=>m [] h [ts] [->-> V]. step=>p. do !step. move=>V2. -by exists (TNode p nil :: ts); split. +case=>h ->; step=>p; do !step; rewrite !unitR=>V. +exists (p &1-> (tt, p)); rewrite graph1Pt; split=>// x; +by rewrite ?(summitsPt,loops1Pt,domPtK,defPt_nullO V,inE,eqxx,andbT). Qed. -(********) -(* FIND *) -(********) +(* find x : returns the equiv_class representative of x *) -(* Returns the canonical representative of the equivalence class of an element*) +(* loop invariant of find *) +Definition find_tp := forall (x : node), STsep {s y} + (fun h => h \In equiv_class s y /\ x \in dom s, + [vfun r h => h \In equiv_class s y /\ r = y]). -Definition find_tp (x : ptr) := - STsep {rs r} (fun h => shape rs h /\ (x, r) \In rs, - [vfun res h => shape rs h /\ res = r]). - -Program Definition find1 (x : ptr) : find_tp x := - Do (let root := ffix (fun (go : forall x, find_tp x) (x : ptr) => - Do (p <-- !x; - if x == p then ret p else go p)) - in root x). +Program Definition find := + ffix (fun (go : find_tp) (x : node) => + Do (p <-- !x.+1; + if x == p then ret p else go p)). Next Obligation. -move=>_ go x [rs][r] [] h //= [[ts [->-> V]] H]. -case/(fset_pts_rev V): (H)=>p [j E] K. rewrite E in V; rewrite E; step. -case: (x =P p) E =>[->|N] E; apply: vrfV=>V1. -- step=>_. split=>//; first by exists ts; split=>//=. - by apply: froot_loop K _; rewrite E findPtUn. -apply: [gE fset ts, r] => //=; first by do !split=>//=; exists ts; split. -Qed. +move=>go x [s][y][_][[g][-> Sl Sy /[dup] Dg ->]] /[dup] Dx /In_graph1X /=. +case=>-[[/= z]][/[swap] N] /[dup]/In_eta/[dup] E -> /In_valid V. +rewrite graph1layPtUn; step; rewrite -(graph1layPtUn _ (_, _)) -E. +case: (x =P z) E V N=>[<-{z}|_] E V N. +- step; split; [by exists g|apply/eqP]. + by rewrite -mem_seq1 -Sy Sl E loopsUn // loops1Pt ?(dom_cond Dx,eqxx). +apply: [gE s, y]=>//=; split; first by exists g. +case: (part_char (g:=g))=>[t|C _ /nilP L]; first by rewrite Sl. +by rewrite -N Dg nxt_leaves_closed ?L. +Qed. + +(* union : joins equivalence classes of two representatives x1, x2 *) +(* and returns one of x1, x2 as the representative of the new class *) +(* NOTE: current implementation always returns x2, *) +(* but there are implementations that return either x1 or x2, *) +(* so the spec makes no commitment *) + +Program Definition union (x1 x2 : node) : STsep {s1 s2} + (equiv_class s1 x1 # equiv_class s2 x2, + [vfun r h => h \In equiv_class (s1 \+ s2) r /\ + r \in [:: x1; x2]]) := + Do (x1.+1 ::= x2;; + ret x2). Next Obligation. -move=>x [rs][r][] h //= [[ts [->-> V]] H]. -apply: [gE fset ts, r]=>//=. -by do !split=>//=; exists ts; split. -Qed. - -(*********) -(* UNION *) -(*********) - -(* Joins the equivalence classes of the two arguments *) - -Definition union_tp (x y : ptr) := STsep {rx ry m} - (fun h => [/\ shape m h, (x, rx) \In m & (y, ry) \In m], - [vfun res h => shape (mapv [fun v => v with rx |-> ry] m) h /\ - res = ry]). - -Program Definition union (x y : ptr) : union_tp x y := - Do (x_rt <-- find1 x; - y_rt <-- find1 y; - x_rt ::= y_rt;; - ret y_rt). +move=>x1 x2 [s1][s2][_][h1][h2][->] H1 H2 /=; apply: vrfV=>V. +case/eqcE: (H1)=>g1 [G1 _ _ Nx1 Se1 Sx1 Dn1 X Lx1 _ _]. +case/eqcE: (H2)=>g2 [G2 _ _ _ Se2 Sx2 Dn2 _ _ Dx2 _]. +move/(eqcV2 H1 H2): V (V) Dx2=>{H1 H2}Vs /(In_graph1V2 G1 G2) Vg. +move/(dom_inNR Vg)=>Ng; case/(part_loop_eta (eq_subsetL Se1)): X=>-[Eg1]. +rewrite {}G1 {}G2 -graph1layUn Eg1 -joinA graph1layPtUn; do 2!step. +rewrite -(graph1layPtUn _ (_, _)) joinA. +set g1' := pts _ _ \+ _; move/graph1layVI=>Vg'. +have {Se1}Pr1' : preacyclic g1'. +- move/eq_subsetL/part_preacyclic: Se1; rewrite Eg1. + by apply: preacyclic_mutation; rewrite -Eg1 ?(validL Vg). +have Es : summits g1' =i summits g2. +- move=>z; rewrite summitsUn ?(validL Vg') // Sx2 !mem_filter /=. + rewrite domF domPt summitsPt {}Nx1 //= !inE (eq_sym x1) andbC. + case: (z =P x1)=>[|Nz /=]; first by rewrite andbT orbF. + case: (z =P x2) Ng=>[->->|_ _] //=; apply/negP. + by move/(part_summits1_free Lx1); rewrite Sx1 inE=>/eqP/Nz. +split; last by rewrite !inE eqxx orbT. +exists (g1' \+ g2); split=>// z; last first. +- by rewrite domUnE // domUnE // Dn1 Dn2 Eg1 !domPtUn !inE !validPtUn. +- by rewrite (summits1EqUnL Vg') // Es Sx2. +rewrite (summits1EqUnL Vg' Es) loopsUn // -Se2 -Es orb_idl //. +by apply: loops_summits_sub. +Qed. + +(* unit test for client-side reasoning *) + +Program Definition test1 : + STsep (emp, [vfun r h => exists s, h \In equiv_class s r /\ r \in dom s]) := + Do (x <-- new; + y <-- new; + rx <-- find x; + ry <-- find y; + union rx ry). Next Obligation. -move=>x y [a][b][_] [] _ /= [[ts [->-> Vh]] Hx Hy]. -apply: [stepE fset ts, a]=>//=; first by do !split=>//; exists ts; split. -move=>_ _ [[ts1] [-> Eq1 V1] ->]; rewrite Eq1 in Hy Hx {Vh}. -apply: [stepE fset ts1, b]=>//=; first by split=>//; exists ts1; by do !split. -move=>_ _ [[ts2] [-> Eq2 V2] ->]; rewrite Eq2 in Hy Hx {V1}. -move/In_fsetP: (Hx) => /andP [V] /hasP [ta J] /andP [X /eqP rtA]. -move/In_fsetP: (Hy) => /andP [_] /hasP [tb K] /andP [Y /eqP rtB]. -have B: a \in ta by rewrite rtA rt_in. -have C: b \in tb by rewrite rtB rt_in. -have: has (fun t => a \in t) ts2 by apply/hasP; exists ta. -rewrite -dom_flay //. -case/In_domX=>_ /[dup] /In_find/find_flayTp [v] -> /In_find Da. -move/flay_rt: (Da); move/In_range: (Hx)=>/mem_seqP U; rewrite ifT; last by []. -move/eqP=>EqV; rewrite EqV in Da; clear EqV v. -move/heap_eta2: (Da)=>Hts; rewrite Hts; do 2!step; move=>Hv. -split=>//; exists (change_ts ts2 ta tb); split=>//=. -(*CASE 1: a :-> b \+ free (flay ts) a = flay (change_ts ts ta tb) *) -- rewrite /change_ts /=; case: eqP. - - by move=>E; rewrite rtB -E -rtA. - move=>N; rewrite flay_cons flay_tree tlayE /= big_cons tlayE /= -rtB. - rewrite -rtA -!joinA joinCA; congr (_ \+ _); move:(V2). - rewrite flayE (bigD1_seq ta) //=; last by apply: flay_uniq_ts. - rewrite -big_filter (bigD1_seq tb) =>//=; last first. - by rewrite filter_uniq //; apply: flay_uniq_ts. - by rewrite mem_filter K andbT; case: eqP=>// E; rewrite E in N. - rewrite tlayE -rtA -!joinA => Vh'. - rewrite freePtUn // tlayE -rtB -joinCA -!joinA; congr (_ \+ _). - rewrite joinCA; do 2!congr (_ \+ _); rewrite -big_filter -filter_predI. - by rewrite seqext.filter_predIC big_filter //= flayE -big_filter. -(*CASE 2: mapv [fun v => v with a |-> b] c = fset (change_ts ts ta tb) *) -move: (V); rewrite Eq1 Eq2 !fsetE /change_ts; case: eqP. -- move=>E; subst tb; rewrite rtA rtB -rtA (_ : fun_of_simpl _ = id). - - by rewrite mapv_id. - by apply: fext=>z /=; case: eqP. -move=>N; rewrite big_cons tsetE /= -rtB big_cons (bigD1_seq ta) //=; last first. -- by apply: flay_uniq_ts. -simpl; rewrite -big_filter (bigD1_seq tb)=>//=; last first. -- by rewrite filter_uniq //; apply: flay_uniq_ts. -- by rewrite mem_filter K andbT; case: eqP N=>// ->. -(*Case 2.1: mapv tset a = tset b *) -rewrite -rtA -rtB big_filter_cond; move=>V'. -move/validL: (V'); move/validR: (V'); move/[dup]=>/validL Vb /validR Vc Va. -rewrite omapUn // change_tset // -!joinA joinCA; congr (_ \+ _). -rewrite omapUn; last by rewrite (validX V'). -(*Case 2.2: tset of bigger tree doesn't change *) -rewrite nochange_mapv //; last first. -rewrite range_tset // mem_seq1; case: eqP =>// eqAB. -- have: ta = tb by rewrite -eqAB in C; rewrite (flay_mem_eq V2 B J C K). - by move/eqP: N => /eqP eqF eqT; rewrite eqT in eqF. -rewrite tsetE -rtB joinA big_filter //; congr (_ \+ _). -(*Case 2.3: tset of trees different than a and b don't change *) -apply: nochange_mapv =>//; apply/negP; move/mem_rangeX; case=>k H. -case: (bigInXP H)=>j [/mem_seqP X1 /andP [X2 X3]]. -move/mem_range; rewrite range_tset //; last by apply: valid_fset_tset X1. -rewrite inE => /eqP X4; move/negP: X2; apply; apply/eqP. -by apply: flay_mem_eq X1 B J=>//; rewrite X4 rt_in. +case=>h ->; apply: stepE=>//= x1 h1 C1; apply: stepV=>//= x2 h2 C2. +apply: [stepR #x1, x1] @ h1=>//= [|_ {}h1 [{}C1 ->]]; first by rewrite domPtV. +apply: [stepR #x2, x2] @ h2=>//= [|_ {}h2 [{}C2 ->]]; first by rewrite domPtV. +apply: [gE #x1, #x2]=>//= [|??]; first by eexists _, _. +by case=>/[dup]/eqcD; exists (#x1 \+ #x2). Qed. -(*********) -(* Tests *) -(*********) -Program Definition test1: - STsep (fun h => shape Unit h, - [vfun y h => exists x, shape (x \\-> y \+ y \\-> y) h]) := - Do (x <-- newT; - y <-- newT; - res <-- union x y; - ret res). -Next Obligation. -case=>i H. -apply: [stepE Unit]=>//= x j; rewrite unitR=>X. -apply: [stepE x \\-> x]=>//= y k {X} /[dup]X [ts [A m V]]. -rewrite A in V; move: (V); rewrite valid_flay_fset. -move=> /andP [ V1 _] //; rewrite -m in V1. -apply: [stepE x, y, y \\-> y \+ x \\-> x]=>//=. -move=>a h [B ->]; step=>Vh; exists x; move: B. -rewrite omapUn // nochange_mapv; first by rewrite omapPt //= ifT // joinC. -- by apply: validX V1. -rewrite rangePt //; apply/eqP=>N; rewrite N in X. -by move/shapeV: X; rewrite invalidX. -Qed. - -Program Definition test2 (x: ptr): - STsep {y} (fun h => shape (x \\-> y \+ y \\-> y) h, - [vfun res h => shape (x \\-> y \+ y \\-> y) h /\ res = y]) := - Do (res <-- find1 x; - ret res). -Next Obligation. -move=>a [b []] _ [ts][-> B C]. -apply: [stepE fset ts, b]=>//=; last first. -- by move=>p h [H ->]; step=>_; split=>//; rewrite B. -move: (C); rewrite valid_flay_fset; move=>/andP [V1 _]. -split=>//; first by exists ts; split. -rewrite -B; apply: InL; first by rewrite B. -by apply: In_condPt. -Qed. diff --git a/htt/Make b/htt/Make deleted file mode 100644 index dca3ca7..0000000 --- a/htt/Make +++ /dev/null @@ -1,14 +0,0 @@ --Q . htt - --arg -w -arg -notation-overridden --arg -w -arg -redundant-canonical-projection - -# release-specific arguments --arg -w -arg -notation-incompatible-prefix # specific to coq8.20.0 --arg -w -arg -deprecated-from-Coq # specific to coq8.21 --arg -w -arg -deprecated-dirpath-Coq # specific to coq8.21 - -options.v -domain.v -model.v -heapauto.v diff --git a/htt/Makefile b/htt/Makefile deleted file mode 100644 index 103b008..0000000 --- a/htt/Makefile +++ /dev/null @@ -1,7 +0,0 @@ -# -*- Makefile -*- - -# setting variables -COQPROJECT?=Make - -# Main Makefile -include ../Makefile.common diff --git a/htt/domain.v b/htt/domain.v index 78338b7..8787c9c 100644 --- a/htt/domain.v +++ b/htt/domain.v @@ -16,9 +16,6 @@ From Stdlib Require Import ssreflect ssrbool ssrfun. From mathcomp Require Import ssrnat eqtype. From pcm Require Import options axioms pred prelude. -(* change Set to Unset when porting the file, then remove the line when requiring MathComp >= 2.6 *) -Set SsrOldRewriteGoalsOrder. - (**************************************************) (* This file develops some basic domain theory of *) (* posets, complete lattices, complete partial *) @@ -104,7 +101,7 @@ End IdealDef. Section SubPoset. Variables (T : poset) (s : Pred T). -Local Notation tp := {x : T | x \In s}. +Local Abbreviation tp := {x : T | x \In s}. Definition sub_leq (p1 p2 : tp) := sval p1 <== sval p2. @@ -122,7 +119,7 @@ End SubPoset. Section ProdPoset. Variables A B : poset. -Local Notation tp := (A * B)%type. +Local Abbreviation tp := (A * B)%type. Definition poset_prod_leq := [fun p1 p2 : tp => p1.1 <== p2.1 /\ p1.2 <== p2.2]. @@ -141,7 +138,7 @@ End ProdPoset. Section FunPoset. Variable (A : Type) (B : poset). -Local Notation tp := (A -> B). +Local Abbreviation tp := (A -> B). Definition poset_fun_leq := [fun p1 p2 : tp => forall x, p1 x <== p2 x]. @@ -158,7 +155,7 @@ End FunPoset. Section DFunPoset. Variables (A : Type) (B : A -> poset). -Local Notation tp := (forall x, B x). +Local Abbreviation tp := (forall x, B x). Definition poset_dfun_leq := [fun p1 p2 : tp => forall x, p1 x <== p2 x]. @@ -342,7 +339,7 @@ End BasicProperties. (* subset lattice *) Section SubLattice. Variables (T : lattice) (s : Pred T) (C : sup_closed s). -Local Notation tp := {x : T | x \In s}. +Local Abbreviation tp := {x : T | x \In s}. Definition lattice_sub_sup' (u : Pred tp) : T := sup [Pred x : T | exists y, y \In u /\ x = sval y]. @@ -362,7 +359,7 @@ End SubLattice. (* product *) Section ProdLattice. Variables (A B : lattice). -Local Notation tp := (A * B)%type. +Local Abbreviation tp := (A * B)%type. Definition lattice_prod_sup (s : Pred tp) : tp := (sup [Pred p | exists f, p = f.1 /\ f \In s], @@ -379,7 +376,7 @@ End ProdLattice. (* functions into latice form lattice *) Section FunLattice. Variables (A : Type) (B : lattice). -Local Notation tp := (A -> B). +Local Abbreviation tp := (A -> B). Definition lattice_fun_sup (s : Pred tp) : tp := fun x => sup [Pred p | exists f, f \In s /\ p = f x]. @@ -395,7 +392,7 @@ End FunLattice. (* dependent functions into a lattice form a lattice *) Section DFunLattice. Variables (A : Type) (B : A -> lattice). -Local Notation tp := (dfun_poset B). +Local Abbreviation tp := (dfun_poset B). Definition lattice_dfun_sup (s : Pred tp) : tp := fun x => sup [Pred p | exists f, f \In s /\ p = f x]. @@ -614,7 +611,7 @@ HB.mixin Record isCPO T & Poset T := { HB.structure Definition CPO := {T of Poset T & isCPO T}. Definition limx (D : cpo) (s : chain D) & phantom (Pred _) s := lim_op s. -Notation lim s := (limx (Phantom (Pred _) s)). +Abbreviation lim s := (limx (Phantom (Pred _) s)). Section Repack. Variable D : cpo. @@ -786,7 +783,7 @@ Lemma chain_closI (s1 s2 : Pred T) : chain_closed s1 -> chain_closed s2 -> chain_closed (PredI s1 s2). Proof. move=>[H1 S1][H2 S2]; split=>// d H. -by split; [apply: S1 | apply: S2]=>// x; case/H. +by split; [apply: S1| apply: S2]; move=>x /H []. Qed. End AdmissibleClosure. @@ -806,7 +803,7 @@ Qed. Section SubCPO. Variables (D : cpo) (s : Pred D) (C : chain_closed s). -Local Notation tp := {x : D | x \In s}. +Local Abbreviation tp := {x : D | x \In s}. Definition subcpo_bot := exist _ (@bot D) (proj1 C). Lemma subcpo_limX (u : chain tp) : lim (Image sval u) \In s. @@ -856,8 +853,8 @@ Proof. by []. Qed. Definition contfun_axiom (D1 D2 : cpo) (f : mono_fun D1 D2) := forall s : chain D1, f (lim s) <== lim (Image f s). -HB.mixin Record isContFun (D1 D2 : cpo) (f : D1 -> D2) - & @MonoFun D1 D2 f := {contfun_subproof : contfun_axiom f}. +HB.mixin Record isContFun (D1 D2 : cpo) (f : D1 -> D2) & + @MonoFun D1 D2 f := {contfun_subproof : contfun_axiom f}. #[short(type="cont_fun")] HB.structure Definition ContFun (D1 D2 : cpo) := @@ -941,10 +938,10 @@ by apply: poset_trans (N n) _; apply: limP; exists n. Qed. Module Exports. -Notation kleene_lfp := kleene_lfp. -Notation kleene_lfp_fixed := kleene_lfp_fixed. -Notation kleene_lfp_least := kleene_lfp_least. -Notation kleene_lfp_mono := kleene_lfp_mono. +Abbreviation kleene_lfp := kleene_lfp. +Abbreviation kleene_lfp_fixed := kleene_lfp_fixed. +Abbreviation kleene_lfp_least := kleene_lfp_least. +Abbreviation kleene_lfp_mono := kleene_lfp_mono. End Exports. End Kleene. diff --git a/htt/dune b/htt/dune deleted file mode 100644 index a6eeaa3..0000000 --- a/htt/dune +++ /dev/null @@ -1,11 +0,0 @@ -; This file was generated from `meta.yml`, please do not edit manually. - -(coq.theory - (name htt) - (package coq-htt-core) - (synopsis "Hoare Type Theory") - (flags :standard - -w -notation-overridden - -w -local-declaration - -w -redundant-canonical-projection - -w -projection-no-head-constant)) diff --git a/htt/heapauto.v b/htt/heapauto.v index bcac768..87bd172 100644 --- a/htt/heapauto.v +++ b/htt/heapauto.v @@ -444,11 +444,11 @@ Qed. Arguments gX {G A s} g m {m0 j tm k wh r2 e fm fu f fg Q}. -Notation "[gX] @ m" := (gX tt m erefl) (at level 0). +Notation "[gX] @ m" := (gX tt m erefl) (at level 1). Notation "[ 'gX' x1 , .. , xn ] @ m" := (gX (existT _ x1 .. (existT _ xn tt) ..) m erefl) - (at level 0, format "[ 'gX' x1 , .. , xn ] @ m"). + (at level 1, format "[ 'gX' x1 , .. , xn ] @ m"). Definition heapPCM : pcm := heap. @@ -474,10 +474,10 @@ Qed. Arguments stepX [G A B s] g m {m0 j tm k wh r2 e e2 fm fu f fg Q}. -Notation "[stepX] @ m" := (stepX tt m erefl) (at level 0). +Notation "[stepX] @ m" := (stepX tt m erefl) (at level 1). Notation "[ 'stepX' x1 , .. , xn ] @ m" := (stepX (existT _ x1 .. (existT _ xn tt) ..) m erefl) - (at level 0, format "[ 'stepX' x1 , .. , xn ] @ m"). + (at level 1, format "[ 'stepX' x1 , .. , xn ] @ m"). (* combination of gX + vrf_try *) Lemma tryX G A B (s : spec G A) g (m : heap) m0 j tm k wh r2 @@ -500,10 +500,10 @@ Qed. Arguments tryX {G A B s} g m {m0 j tm k wh r2 e e1 e2 fm fu f fg Q}. -Notation "[tryX] @ m" := (stepX tt m erefl) (at level 0). +Notation "[tryX] @ m" := (stepX tt m erefl) (at level 1). Notation "[ 'tryX' x1 , .. , xn ] @ m" := (tryX (existT _ x1 .. (existT _ xn tt) ..) m erefl) - (at level 0, format "[ 'tryX' x1 , .. , xn ] @ m"). + (at level 1, format "[ 'tryX' x1 , .. , xn ] @ m"). (**************************************) (* Simplified ghost lemma automations *) @@ -528,10 +528,10 @@ Qed. Arguments gR {G A s} g m {r e f Q}. -Notation "[gR] @ m" := (gR tt m) (at level 0). +Notation "[gR] @ m" := (gR tt m) (at level 1). Notation "[ 'gR' x1 , .. , xn ] @ m" := (gR (existT _ x1 .. (existT _ xn tt) ..) m) - (at level 0, format "[ 'gR' x1 , .. , xn ] @ m"). + (at level 1, format "[ 'gR' x1 , .. , xn ] @ m"). (* combination of gR + vrf_bind *) Lemma stepR G A B (s : spec G A) g i j (e : STspec G s) (e2 : A -> ST B) @@ -549,10 +549,10 @@ Qed. Arguments stepR {G A B s} g i {j e e2 f Q}. -Notation "[stepR] @ i" := (stepR tt i) (at level 0). +Notation "[stepR] @ i" := (stepR tt i) (at level 1). Notation "[ 'stepR' x1 , .. , xn ] @ i" := (stepR (existT _ x1 .. (existT _ xn tt) ..) i) - (at level 0, format "[ 'stepR' x1 , .. , xn ] @ i"). + (at level 1, format "[ 'stepR' x1 , .. , xn ] @ i"). (* combination of gR + vrf_try *) Lemma tryR G A B (s : spec G A) g i j (e : STspec G s) @@ -571,10 +571,10 @@ Qed. Arguments tryR {G A B s} g i {j e e1 e2 f Q}. -Notation "[tryR] @ i" := (tryR tt i) (at level 0). +Notation "[tryR] @ i" := (tryR tt i) (at level 1). Notation "[ 'tryR' x1 , .. , xn ] @ i" := (tryR (existT _ x1 .. (existT _ xn tt) ..) i) - (at level 0, format "[ 'tryR' x1 , .. , xn ] @ i"). + (at level 1, format "[ 'tryR' x1 , .. , xn ] @ i"). (* The following is brittle, and should eventually be substituted *) (* with overloaded lemmas. For now, sticking with the hack *) diff --git a/htt/model.v b/htt/model.v index 8c1bb4a..0742502 100644 --- a/htt/model.v +++ b/htt/model.v @@ -84,7 +84,7 @@ Parameter vrf' : forall A, ST A -> heap -> post A -> Prop. (* in practice it's more convenient to order the arguments as *) (* initial heap, program, postcondition *) -Notation vrf i e Q := (vrf' e i Q). +Abbreviation vrf i e Q := (vrf' e i Q). Parameter vrfV : forall A e i (Q : post A), (valid i -> vrf i e Q) -> vrf i e Q. @@ -340,7 +340,7 @@ Definition vrf' (e : ST A) (i : heap) (Q : post A) := exists (pf : i \In pre_of e), forall y m, prog_of e _ V pf y m -> Q y m. -Notation vrf i e Q := (vrf' e i Q). +Abbreviation vrf i e Q := (vrf' e i Q). Definition has_spec (e : ST A) := forall g i, (s g).1 i -> vrf i e (s g).2. @@ -403,7 +403,7 @@ HB.instance Definition _ := isLattice.Build STspec stspsup_is_lattice. End STspecDef. -Notation vrf i e Q := (vrf' e i Q). +Abbreviation vrf i e Q := (vrf' e i Q). (* required vrf lemmas *) @@ -455,8 +455,8 @@ End VrfLemmas. Section Fix. Variables (G A : Type) (B : A -> Type) (pq : forall x, spec G (B x)). -Notation tp := (forall x, STspec (pq x)). -Notation lat := (dfun_lattice (fun x => STspec (pq x))). +Abbreviation tp := (forall x, STspec (pq x)). +Abbreviation lat := (dfun_lattice (fun x => STspec (pq x))). Variable f : tp -> tp. (* fixed point constructor over monotone closure *) @@ -714,7 +714,7 @@ have J : x :-> v \+ j \In read_pre. - split; first by rewrite domPtUnE. by exists v; rewrite findPtUn. exists J=>_ _ [w [->->]]. -rewrite findPtUn //; case=>/inj_pair2 {w}<-. +rewrite findPtUn //; case=>/inj_tagK {w}<-. by apply: H. Qed. @@ -987,7 +987,7 @@ Lemma dealloc_mono (p1 p2 : ptr) : Proof. by move=>->. Qed. Variables (G : Type) (C : A -> Type) (pq : forall x, spec G (C x)). -Notation lat := (dfun_lattice (fun x => STspec (pq x))). +Abbreviation lat := (dfun_lattice (fun x => STspec (pq x))). Lemma fix_mono (f1 f2 : lat -> lat) : f1 <== f2 -> diff --git a/theories/dune b/theories/dune deleted file mode 100644 index 8f51667..0000000 --- a/theories/dune +++ /dev/null @@ -1,7 +0,0 @@ -; This file was generated from `meta.yml`, please do not edit manually. -; Follow the instructions on https://github.com/coq-community/templates to regenerate. - -(coq.theory - (name htt) - (package coq-htt-core) - (synopsis "Hoare Type Theory")) From 3bef4a5523ee57b6282a53a363e155070dc6cfef Mon Sep 17 00:00:00 2001 From: Aleksandar Nanevski Date: Thu, 6 Aug 2026 16:12:04 +0200 Subject: [PATCH 02/17] minor fixes --- examples/exploit.v | 44 -------------------------------------------- htt/model.v | 2 +- 2 files changed, 1 insertion(+), 45 deletions(-) delete mode 100644 examples/exploit.v diff --git a/examples/exploit.v b/examples/exploit.v deleted file mode 100644 index ed14cf6..0000000 --- a/examples/exploit.v +++ /dev/null @@ -1,44 +0,0 @@ -(* -Copyright 2009 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. -*) - -From Stdlib Require Import ssreflect ssrbool Logic.Hurkens. - -(* This file shows the unsoundness of the axiom pack_injective assumed in *) -(* the implementation of Ynot2.0. The proof relies on the lemma of *) -(* Coquand shown in his 'Mathematical Investigations of a Calculus of *) -(* Constructions'. Coquand's paper is available at *) -(* http://www.cs.chalmers.se/~coquand/meta.pdf. The lemma is stated in *) -(* several forms on page 15. The proof reduces in a few steps to *) -(* unsoundness of Girard's system U. *) - -(* A simplification of Girard's paradox is given by Hurkens, who ultimately *) -(* proves the same lemma as Coquand. The nice thing is that his proof is *) -(* available as a Coq library in Coq.Logic.Hurkens, so we can directly use *) -(* it here. *) - -Definition pack_injective := forall T (x y : T), inhabits x = inhabits y -> x = y. - -Lemma coquand : forall (B : Prop) (E : B -> Prop) (e : Prop -> B) - (H : forall A : Prop, A <-> E (e A)), False. -Proof. -by move=>B E e H; apply: (NoRetractFromSmallPropositionToProp.paradox B e E)=>A; move: (H A)=>[H1] H2. -Qed. - -Lemma pack_noninjective : pack_injective -> False. -Proof. -pose B := inhabited Prop. -pose e := @inhabits Prop. -pose E x := exists A, (e A = x) /\ A. -move/(_ Prop)=>H. -by apply: (@coquand B E e)=>A; split; [move=>x; exists A | move=>[A'][]; move/H=>->]. -Qed. diff --git a/htt/model.v b/htt/model.v index edaedd2..1ff6f45 100644 --- a/htt/model.v +++ b/htt/model.v @@ -714,7 +714,7 @@ have J : x :-> v \+ j \In read_pre. - split; first by rewrite domPtUnE. by exists v; rewrite findPtUn. exists J=>_ _ [w [->->]]. -rewrite findPtUn //; case=>/inj_tagK <-. +rewrite findPtUn //; case=>/inj_tagK <-{w}. by apply: H. Qed. From 8e6415cc9c71b6d98c31441be072ef5171db598e Mon Sep 17 00:00:00 2001 From: Aleksandar Nanevski Date: Thu, 6 Aug 2026 16:12:33 +0200 Subject: [PATCH 03/17] added graph and schorr examples --- examples/graph.v | 4776 +++++++++++++++++++++++++++++++++++++++++++++ examples/schorr.v | 278 +++ 2 files changed, 5054 insertions(+) create mode 100644 examples/graph.v create mode 100644 examples/schorr.v diff --git a/examples/graph.v b/examples/graph.v new file mode 100644 index 0000000..261e250 --- /dev/null +++ b/examples/graph.v @@ -0,0 +1,4776 @@ +(* +Copyright 2022 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. +*) + +From HB Require Import structures. +From Stdlib Require Import ssreflect ssrfun. +From mathcomp Require Import ssrbool eqtype ssrnat seq path bigop. +From pcm Require Import options axioms pred prelude seqext. +From pcm Require Import heap pcm unionmap natmap auto autouniq autopcm automap. + +Abbreviation node := nat. + +(**********) +(**********) +(* Graphs *) +(**********) +(**********) + +(* link is type with map to seq node that has partial inverse. *) +(* The map/inverse are called links/mk. *) +(* Serves to describe the linkage architecture of a graph. *) +(* V = seq node for general graphs, where each node *) +(* can have arbitrary many children *) +(* V = node * node for binary graphs, where each node *) +(* has at most two children *) + +Definition link_axiom V (links : V -> seq node) mk := + pcancel links mk /\ ocancel mk links. + +HB.mixin Record isLink V := { + links : V -> seq node; + mk : seq node -> option V; + link_subproof : link_axiom links mk}. + +#[short(type=link)] +HB.structure Definition Link := {V of isLink V}. + +(* repack *) +Lemma links_pcancel {V} : pcancel (@links V) (@mk V). +Proof. by case: (@link_subproof V). Qed. +Lemma links_ocancel {V} : ocancel (@mk V) (@links V). +Proof. by case: (@link_subproof V). Qed. +Lemma inj_links {V} : injective (@links V). +Proof. by apply/pcan_inj/links_pcancel. Qed. + +(* link with decidable equality *) +#[short(type="eqlink")] +HB.structure Definition EQLink := {U of Equality U & Link U}. + +(* V is the type organizing the edges *) +(* A is the contents/labeling of the nodes *) +(* e.g., pair for binary graphs, sequence for n-ary graphs *) +Record partial_graph' (V : link) (A : Type) := + PartialGraph {partialgraph_base : @UM.base node nat_pred (A * V)}. + +Section PartialGraphUMC. +Variables (V : link) (A : Type). +Implicit Type f : partial_graph' V A. +Local Coercion partialgraph_base : partial_graph' >-> UM.base. +Let pg_valid f := @UM.valid nat nat_pred (A * V) f. +Let pg_empty := PartialGraph (@UM.empty nat nat_pred (A * V)). +Let pg_undef := PartialGraph (@UM.Undef nat nat_pred (A * V)). +Let pg_upd k v f := PartialGraph (@UM.upd nat nat_pred (A * V) k v f). +Let pg_dom f := @UM.dom nat nat_pred (A * V) f. +Let pg_assocs f := @UM.assocs nat nat_pred (A * V) f. +Let pg_free f k := PartialGraph (@UM.free nat nat_pred (A * V) f k). +Let pg_find k f := @UM.find nat nat_pred (A * V) k f. +Let pg_union f1 f2 := PartialGraph (@UM.union nat nat_pred (A * V) f1 f2). +Let pg_empb f := @UM.empb nat nat_pred (A * V) f. +Let pg_undefb f := @UM.undefb nat nat_pred (A * V) f. +Let pg_from (f : partial_graph' V A) : UM.base _ _ := f. +Let pg_to (b : @UM.base nat nat_pred (A * V)) : partial_graph' V A := + PartialGraph b. +Let pg_pts k v := PartialGraph (@UM.pts nat nat_pred (A * V) k v). + +Lemma partialgraph_is_umc : + union_map_axiom pg_valid pg_empty pg_undef pg_upd pg_dom + pg_assocs pg_free pg_find pg_union pg_empb + pg_undefb pg_pts pg_from pg_to. +Proof. by split=>//; split=>[|[]]. Qed. + +HB.instance Definition _ := + isUnion_map.Build node nat_pred (A * V)%type + (partial_graph' V A) partialgraph_is_umc. +End PartialGraphUMC. + +HB.instance Definition _ (V : link) A := + isNatMap.Build (A * V)%type (partial_graph' V A). +HB.instance Definition _ (V : eqlink) (A : eqType) := + hasDecEq.Build (partial_graph' V A) + (@union_map_eqP node _ (A * V)%type (partial_graph' V A)). +Canonical partialgraph_PredType (V : link) A : PredType (node * (A * V)) := + um_PredType (partial_graph' V A). +Coercion Pred_of_partialgraph V A + (x : partial_graph' V A) : {Pred _} := [eta Mem_UmMap x]. + +(* using nodes g for dom g when g is partial graph *) +Abbreviation nodes g := (domT (partial_graph' _ _) g). +Abbreviation nodes0 g := (null :: nodes g). + +(* notation to infer link structure automatically *) +Definition pgx {V : link} A & phant V := partial_graph' V A. +Abbreviation partial_graph V A := (pgx A (Phant V)). + +(* general graph linkage and notation *) +Lemma gengraph_is_link : link_axiom id Some. Proof. by []. Qed. +HB.instance Definition _ := isLink.Build (seq node) gengraph_is_link. +Abbreviation pre_graph A := (partial_graph (seq node) A). +Notation "x &-> v" := (ptsT (pre_graph _) x v) (at level 30). + +(* binary graph linkage and notation *) +Definition bingraph_link (x : node * node) := [:: x.1; x.2]. +Definition bingraph_mk (s : seq node) := + if s is [:: a; b] then Some (a, b) else None. +Arguments bingraph_link x /. +Arguments bingraph_mk s /. +Lemma bingraph_is_link : link_axiom bingraph_link bingraph_mk. +Proof. by split; case=>// a [] // b []. Qed. +HB.instance Definition _ := + isLink.Build (prod node node) bingraph_is_link. +Abbreviation binary_graph A := (partial_graph (node * node) A). +Notation "x &2-> v" := (ptsT (binary_graph _) x v) (at level 30). + +(********************************) +(* labels, adj, children, edges *) +(********************************) + +(* basic operations over graphs *) + +Section GraphDefs. +Context {V : link} {A : Type}. +Implicit Type g : partial_graph V A. + +(* maps each node to its contents (ie. label) *) +Definition labels g : nmap A := mapv fst g. +HB.instance Definition _ := OmapFun.copy labels labels. +Definition olabel g x := find x (labels g). + +(* adjacency list of x includes all nodes with edges from x *) +(* explicitly including dangling edges *) +Definition adj g x := oapp (links \o snd) [::] (find x g). + +(* children is like adj, but removes dangling edges *) +Definition children g x : seq node := filter [in nodes g] (adj g x). + +(* edge is applicative variant of children *) +(* thus, dangling edges are *not* edges. *) +Definition edge g : rel node := mem \o children g. +End GraphDefs. + +Arguments edge {V A} g x y : simpl never. + +Section GraphLemmas. +Context {V : link} {A : Type}. +Implicit Type g : partial_graph V A. + +(* nodes lemmas *) + +Lemma nodes_undef : nodes (undef : partial_graph V A) = [::]. +Proof. by []. Qed. + +Lemma nodes0_undef : nodes0 (undef : partial_graph V A) = [:: null]. +Proof. by []. Qed. + +Lemma nodes_unit : nodes (Unit : partial_graph V A) = [::]. +Proof. by []. Qed. + +Lemma nodes0_unit : nodes0 (Unit : partial_graph V A) = [:: null]. +Proof. by []. Qed. + +Lemma nodesPtUn x y v g : + valid (pts x v \+ g) -> + (y \in nodes (pts x v \+ g)) = (x == y) || (y \in nodes g). +Proof. by move=>W; rewrite domPtUn inE W. Qed. + +Lemma nodes0PtUn x y v g : + valid (pts x v \+ g) -> + (y \in nodes0 (pts x v \+ g)) = (x == y) || (y \in nodes0 g). +Proof. by move=>W; rewrite inE nodesPtUn // orbCA. Qed. + +Lemma nodesUn g1 g2 : + valid (g1 \+ g2) -> + nodes (g1 \+ g2) =i nodes g1 ++ nodes g2. +Proof. by move=>W x; rewrite domUn inE W mem_cat. Qed. + +Lemma nodesUn0L g1 g2 x : + valid (g1 \+ g2) -> + (x \in nodes0 (g1 \+ g2)) = (x \in nodes0 g1) || (x \in nodes g2). +Proof. by move=>W; rewrite !inE -orbA -domUnE. Qed. + +Lemma nodesUn0R g1 g2 x : + valid (g1 \+ g2) -> + (x \in nodes0 (g1 \+ g2)) = (x \in nodes g1) || (x \in nodes0 g2). +Proof. by move=>W; rewrite !inE orbCA -domUnE. Qed. + +(* labels lemmas *) + +Lemma In_labelsX g x v : + (x, v) \In labels g <-> + exists xs, (x, (v, xs)) \In g. +Proof. +rewrite In_omfX; split; last by case=>lks H; exists (v, lks). +by case; case=>w lks /= H [<-{v}]; exists lks. +Qed. + +Lemma In_labels g x xs : + (x, xs) \In g -> + (x, xs.1) \In labels g. +Proof. by case: xs=>v lks; rewrite In_labelsX; exists lks. Qed. + +Lemma In_olabel g x xs : + (x, xs) \In g -> + olabel g x = Some xs.1. +Proof. by rewrite /olabel=>/In_labels/In_find ->. Qed. + +(* adjacency list lemmas *) + +Lemma adj_undef x : adj (undef : partial_graph V A) x = [::]. +Proof. by []. Qed. + +Lemma adj_unit x : adj (Unit : partial_graph V A) x = [::]. +Proof. by []. Qed. + +Lemma adjND g x : + x \notin nodes g -> + adj g x = [::]. +Proof. by rewrite /adj/oapp; case: dom_find. Qed. + +Lemma adjUnL g1 g2 x : + valid (g1 \+ g2) -> + adj (g1 \+ g2) x = + if x \in nodes g1 then adj g1 x else adj g2 x. +Proof. by move=>W; rewrite /adj/oapp findUnL //; case: dom_find. Qed. + +Lemma adjUnR g1 g2 x : + valid (g1 \+ g2) -> + adj (g1 \+ g2) x = + if x \in nodes g2 then adj g2 x else adj g1 x. +Proof. by rewrite joinC=>/adjUnL; apply. Qed. + +Lemma size_adj g x : + size (adj g x) > 0 -> + x \in nodes g. +Proof. by rewrite /adj/oapp; case: dom_find. Qed. + +Lemma adjD g x y : + y \in adj g x -> + x \in nodes g. +Proof. by move=>X; apply: size_adj; case: (adj g x) X. Qed. + +Lemma adjV g x y : + y \in adj g x -> + valid g. +Proof. by move/adjD/dom_valid. Qed. + +Lemma In_graph g x v xs : + (x, (v, xs)) \In g -> + adj g x = links xs. +Proof. by rewrite /adj/oapp=>/In_find ->. Qed. + +Lemma In_graphX g x : + x \in nodes g -> + exists v xs, (x, (v, xs)) \In g /\ adj g x = links xs. +Proof. by case/In_domX=>-[v xs] /[dup]/In_graph; eauto. Qed. + +Lemma graph_eta g x v : + (x, v) \In g -> + g = pts x v \+ free g x. +Proof. exact: In_eta. Qed. + +Lemma range_adj g x : + x \in nodes g -> + adj g x \in map (links \o snd) (range g). +Proof. +by case/In_graphX=>v [xs][] /In_range/(Mem_map (links \o snd))/mem_seqP H ->. +Qed. + +Lemma adjF g x y : + adj (free g x) y = if x == y then [::] else adj g y. +Proof. by rewrite /adj findF eq_sym; case: eqP. Qed. + +Lemma adjPt2 v x xs y : + adj (pts x (v, xs) : partial_graph V A) y = + if (x != 0) && (y == x) then links xs else [::]. +Proof. by rewrite /adj findPt2 andbC; case: ifP. Qed. + +Lemma adjPt v x xs : + adj (pts x (v, xs) : partial_graph V A) x = + if x != 0 then links xs else [::]. +Proof. by rewrite adjPt2 eqxx andbT. Qed. + +(* children lemmas *) + +Lemma children_undef x : children (undef : partial_graph V A) x = [::]. +Proof. by []. Qed. + +Lemma children_unit x : children (Unit : partial_graph V A) x = [::]. +Proof. by []. Qed. + +Lemma childrenND g x : + x \notin nodes g -> + children g x = [::]. +Proof. by rewrite /children=>/adjND ->. Qed. + +Lemma childrenD g x : + {subset children g x <= nodes g}. +Proof. by move=>y; rewrite /children mem_filter; case/andP. Qed. + +Lemma childrenUnL g1 g2 x : + valid (g1 \+ g2) -> + {subset children g1 x <= children (g1 \+ g2) x}. +Proof. +move=>W y; rewrite /children !mem_filter /= =>/andP [Dy Ly]. +by rewrite domUn inE W Dy adjUnL //= (adjD Ly). +Qed. + +Lemma childrenUnR g1 g2 x : + valid (g1 \+ g2) -> + {subset children g2 x <= children (g1 \+ g2) x}. +Proof. by rewrite joinC; apply: childrenUnL. Qed. + +Lemma children_adj g x : + {subset children g x <= adj g x}. +Proof. by move=>z; rewrite /children mem_filter=>/andP []. Qed. + +(* if x is node in g then g x contains all children of x *) +(* and maybe some more nodes that aren't in g *) +Lemma range_children g x : + x \in nodes g -> + exists2 xs, xs \in map (links \o snd) (range g) & + {subset children g x <= xs}. +Proof. +move=>Dx; exists (adj g x); first by apply: range_adj. +by apply: children_adj. +Qed. + +(* edge lemmas *) + +Lemma edge_undef x y : edge (undef : partial_graph V A) x y = false. +Proof. by rewrite /edge/= children_undef. Qed. + +Lemma edge_unit x y : edge (Unit : partial_graph V A) x y = false. +Proof. by rewrite /edge/= children_unit. Qed. + +Lemma edge_children g x y : + edge g x y = (y \in children g x). +Proof. by []. Qed. + +Lemma edgeUnL g1 g2 x y : + valid (g1 \+ g2) -> + edge g1 x y -> + edge (g1 \+ g2) x y. +Proof. by move=>W; apply: childrenUnL. Qed. + +Lemma edgeUnR g1 g2 x y : + valid (g1 \+ g2) -> + edge g2 x y -> + edge (g1 \+ g2) x y. +Proof. by move=>W; apply: childrenUnR. Qed. + +Lemma edgeD g x y : + edge g x y -> + (x \in nodes g) * (y \in nodes g). +Proof. +rewrite /edge/= => H; split; last by apply: childrenD H. +by apply: contraLR H=>/childrenND ->. +Qed. + +Lemma edge_adj g x y : + edge g x y = (y \in nodes g) && (y \in adj g x). +Proof. by rewrite /edge/= mem_filter /=; case: dom_find. Qed. + +Lemma edgeA g x y : + edge g x y -> + y \in adj g x. +Proof. by rewrite edge_adj=>/andP []. Qed. + +Lemma edgeV g x y : + edge g x y -> + valid g. +Proof. by move/edgeA/adjV. Qed. + +Lemma adj_edge g x y : + y \in nodes g -> + y \in adj g x -> + edge g x y. +Proof. by rewrite edge_adj=>->->. Qed. + +Lemma subrel_edgeL g1 g2 : + valid (g1 \+ g2) -> + subrel (edge g1) (edge (g1 \+ g2)). +Proof. +by move=>W a b /[dup]/edgeD [Da Db]; rewrite !edge_adj ?(adjUnL,domUnE,Da,Db). +Qed. + +Lemma subrel_edgeR g1 g2 : + valid (g1 \+ g2) -> + subrel (edge g2) (edge (g1 \+ g2)). +Proof. by rewrite joinC; apply: subrel_edgeL. Qed. + +Lemma path_nodes g x xs : + path (edge g) x xs -> + {subset xs <= nodes g}. +Proof. +elim: xs x=>[|b xs IH]x //= /andP [/edgeD [_ He] /IH]. +by apply: subset_consLI He. +Qed. + +Lemma path_nodes0 g x xs : + path (edge g) x xs -> + nilp xs || (x \in nodes g). +Proof. by case: xs=>[|y xs] //= /andP [] /edgeD []. Qed. + +Lemma edgeFE g x a b : + (edge (free g x) a b) = + [&& edge g a b, x != a & x != b]. +Proof. +rewrite /edge/children/adj/= !mem_filter /= domF findF -!(eq_sym x). +case: (x =P a)=>[<-{a}|_]; first by rewrite !andbF. +case D: (find a g)=>[c|/=]; last by rewrite !andbF. +case C: (b \in links c.2); last by rewrite !andbF. +by rewrite !andbT andbC. +Qed. + +Lemma edge_free_eq g (x : node) (xs : seq node) : + x \notin xs -> + {in xs &, edge g =2 edge (free g x)}. +Proof. +move=>N a b Ax Bx; rewrite edgeFE; case Eg2: (edge g a b)=>//=. +by case: eqP Ax N=>[<- ->//|_] Ax; case: eqP Bx=>//= <- ->. +Qed. + +Lemma edge_free_sub g (x : node) (xs : seq node) : + x \notin xs -> + {in xs &, subrel (edge g) (edge (free g x))}. +Proof. by move=>N a b Ax /(edge_free_eq g N Ax) <-. Qed. + +Lemma free_edge_sub {g} {x : node} : + subrel (edge (free g x)) (edge g). +Proof. by move=>y z; rewrite edgeFE=>/and3P []. Qed. + +Lemma path_edge_free g x y ys: + x \notin y :: ys -> + path (edge g) y ys -> + path (edge (free g x)) y ys. +Proof. by move=>N; rewrite -(eq_in_path (edge_free_eq g N)). Qed. + +(* useful renaming *) +Lemma edge_free_path g x y ys: + path (edge (free g x)) y ys -> + path (edge g) y ys. +Proof. exact: (sub_path free_edge_sub). Qed. + +End GraphLemmas. + +Prenex Implicits In_graph. + +(***********************) +(* Depth-first search *) +(***********************) + +(* lifts dfs from mathcomp fingraph to partial graphs *) + +(* list of nodes traversed by depth-first search of g *) +(* at depth n, starting from x, and avoiding v. *) +(* Definition uses children, not links; *) +(* thus, it doesn't follow dangling edges *) +(* and dfs can't express reachability to an outside node. *) +(* If the latter is desired, it can be separately defined *) +(* as a conjunct of dfs and links properties. *) + +Fixpoint dfs (V : link) A (g : partial_graph V A) (n : nat) (v : seq node) x := + if (x \notin dom g) || (x \in v) then v else + if n is n'.+1 then foldl (dfs g n') (x :: v) (children g x) else v. + +Section DFSLemmas. +Context {V : link} {A : Type}. +Implicit Type g : partial_graph V A. + +Lemma dfs_notin g n v x : + x \notin nodes g -> + dfs g n v x = v. +Proof. by elim: n=>[|n IH] /= ->. Qed. + +Lemma subset_dfs g n v x : + {subset v <= foldl (dfs g n) v x}. +Proof. +elim: n x v => [|n IHn] /=; elim=>[|x xs IHx] v //=. +- by case: ifP. +move=>y Hy; apply: IHx; case: ifP=>//= _. +by apply: IHn; rewrite inE Hy orbT. +Qed. + +(* avoidance set is bound by g *) +Lemma subset_foldl_dfs_nodes g n v x : + {subset v <= nodes g} -> + {subset foldl (dfs g n) v x <= nodes g}. +Proof. +elim: n x v=>[|n IHn]; elim=>[|x xs IHx] v //=. +- by case: ifP=>_; apply: IHx. +case: ifP; first by case: (x \in nodes g)=>//= H; apply: IHx. +case Dx: (x \in nodes g)=>//= H Gx; apply/IHx/IHn. +by move=>z; rewrite inE; case/orP=>[/eqP ->|/Gx]. +Qed. + +Lemma subset_dfs_nodes g n v x : + {subset v <= nodes g} -> + {subset dfs g n v x <= nodes g}. +Proof. +case: n=>[|n] H /=; case: ifP=>//=. +case Dx : (x \in nodes g)=>//= _; apply: subset_foldl_dfs_nodes. +by move=>z; rewrite inE; case/orP=>[/eqP ->|/H]. +Qed. + +Lemma uniq_dfs_foldl g n v x : + uniq v -> + uniq (foldl (dfs g n) v x). +Proof. +elim: n x v=>[|n IHn]; elim=>[|x xs IHx] v U //=; apply: IHx. +- by rewrite if_same. +case: (x \in nodes g)=>//=; case: ifP=>// Xv. +by rewrite IHn //= Xv. +Qed. + +Lemma uniq_dfs g n v x : + uniq v -> + uniq (dfs g n v x). +Proof. +case: n=>[|n] U /=; first by rewrite if_same. +case: (x \in nodes g)=>//=; case: ifP=>// Xv. +by rewrite uniq_dfs_foldl //= Xv. +Qed. + +(* there's a path in g from x to y avoiding v *) +Inductive dfs_path g (v : seq node) x y : Prop := + DfsPath xs of + path (edge g) x xs & + y = last x xs & + disjoint v (x :: xs). + +Lemma dfs_path_id g v x : + x \notin v -> + dfs_path g v x x. +Proof. +move=>Vx; apply: (DfsPath (xs:=[::]))=>//=. +by rewrite disjoint1R. +Qed. + +Lemma dfs_pathP g n x y v : + size (nodes g) <= size v + n -> + uniq v -> + {subset v <= nodes g} -> + y \notin v -> + x \in dom g -> + reflect (dfs_path g v x y) (y \in dfs g n v x). +Proof. +elim: n=>[|n IHn] /= in x y v * => Hv Uv Sv Ny Dx. +- rewrite addn0 in Hv; rewrite Dx if_same (negbTE Ny). + apply: ReflectF; case=>xs E _; rewrite disjoint_consR. + by rewrite (uniq_min_size Uv Sv Hv) Dx. +rewrite Dx /=; have [Vx|Vx] := ifPn. +- by rewrite (negbTE Ny); apply: ReflectF=>[[xs]]; rewrite disjoint_consR Vx. +set v1 := x :: v; set c := children g x; have [->|/eqP Nyx] := eqVneq y x. +- by rewrite subset_dfs ?inE ?eqxx //; apply/ReflectT/dfs_path_id. +apply: (@equivP (exists2 x1, x1 \in c & dfs_path g v1 x1 y))=>/=; last first. +- split=>{IHn} [[x1 Hx1 [p1 P1 E1 D1]]|[p /shortenP []]]. + - apply: (DfsPath (xs:=x1::p1))=>//=; first by rewrite edge_children -/c Hx1. + by rewrite disjoint_consR Vx (disjoint_consLE D1). + case=>[_ _ _ /Nyx|] //= x1 xs /andP [Hx1 Hp1] /and3P [N1 _ _] S1 E1 D1. + exists x1=>//; apply: (DfsPath (xs:=xs))=>//; rewrite disjoint_consL N1. + by rewrite (disjoint_consRE (disjoint_subL (subset_consLR S1) D1)). +move: (Dx). +have {Nyx Ny} : y \notin v1 by apply/norP; move/eqP: Nyx. +have {Sv Dx} : {subset v1 <= nodes g} by apply: subset_consLI. +have {Vx Uv} : uniq v1 by rewrite /= Vx. +have {Hv} : size (nodes g) <= size v1 + n by rewrite addSnnS. +have : {subset c <= nodes g} by apply: childrenD. +elim: {x v}c (x) v1=>[|x xs IHa] x' v /= Dxs Hv U Sv Nv Dx'. +- by rewrite (negbTE Nv); apply: ReflectF; case. +have Dx : x \in nodes g by apply: Dxs; rewrite inE eqxx. +have Da : {subset xs <= nodes g} by move=>z Z; apply/Dxs/subset_consR. +set v2 := dfs g n v x. +have Sv2 : {subset v <= v2} := @subset_dfs g n v [:: x]. +have [Hy2|Ny2] := boolP (y \in v2). +- rewrite subset_dfs //; apply: ReflectT. + by exists x; [rewrite inE eq_refl|apply/IHn]. +apply: {IHa} (equivP (IHa _ _ _ _ _ _ Ny2 Dx))=>//. +- by rewrite (leq_trans Hv) ?leq_add2r ?uniq_leq_size. +- by rewrite uniq_dfs. +- by apply: subset_dfs_nodes. +split=>[][x1 Hx1 [p1 P1 Ey D1]]. +- exists x1; first by rewrite inE Hx1 orbT. + by apply: DfsPath (disjoint_subR Sv2 D1). +have Nx1 : x1 \notin v by rewrite (disjoint_consRE D1). +suff D2 : disjoint v2 (x1 :: p1). +- move: Hx1; rewrite inE; case/orP=>[/eqP ?|Hx1]; last first. + - by exists x1=>//; apply: DfsPath D2. + subst x1; have : x \notin v2 by rewrite (disjoint_consRE D2). + by move/negP; elim; apply/IHn=>//; apply: dfs_path_id. +apply: contraR Ny2=>/disjointN [/= x2 Hx2v Hx2]. +case/splitPl: Hx2 Ey P1 D1=>/= pl pr Ex2. +rewrite last_cat cat_path -cat_cons lastI cat_rcons {}Ex2. +move=>Ey /andP [_ P1]; rewrite disjoint_catR=>/andP [D1 D2]. +have Nx2 : x2 \notin v by rewrite (disjoint_consRE D2). +have [p P E D] := IHn _ _ v Hv U Sv Nx2 Dx Hx2v. +apply/IHn=>//; exists (p ++ pr). +- by rewrite cat_path P -E P1. +- by rewrite last_cat -E. +by rewrite -cat_cons disjoint_catR D (disjoint_consRE D2). +Qed. + +End DFSLemmas. + +(*******************) +(* Filter by nodes *) +(*******************) + +(* select subgraph consisting of nodes *) +(* that satisfy a predicate *) + +Definition kfiltx {V : link} A (xs : pred node) (g : partial_graph V A) : + partial_graph V A := um_filterk xs g. +HB.instance Definition _ V A xs := + OmapFun.copy (@kfiltx V A xs) (@kfiltx V A xs). +Abbreviation kfilt g xs := (@kfiltx _ _ xs g). + +Section Kfilt. +Context {V : link} {A : Type}. +Implicit Type g : partial_graph V A. + +Lemma kfiltUn g (p1 p2 : pred node) : + (forall x, x \in p1 -> ~ x \in p2) -> + kfilt g (predU p1 p2) = kfilt g p1 \+ kfilt g p2. +Proof. by move=>H; apply: umfilt_dpredU=>x /H/negP. Qed. + +Lemma kfilt_predI g (p1 p2 : pred node) : + kfilt g (predI p1 p2) = kfilt (kfilt g p2) p1. +Proof. by rewrite /kfiltx umfilt_predI. Qed. + +Lemma kfilt_predIC g (p1 p2 : pred node) : + kfilt g (predI p1 p2) = kfilt (kfilt g p1) p2. +Proof. by rewrite /kfiltx umfiltC umfilt_predI. Qed. + +Lemma kfilt_predD g (p1 p2 : pred node) : + {subset p1 <= p2} -> + kfilt g p2 = kfilt g p1 \+ kfilt g (predD p2 p1). +Proof. by move=>S; apply: umfilt_predD; case=>? /= _; apply: S. Qed. + +Lemma eq_in_kfilt g (p1 p2 : pred node) : + {in nodes g, p1 =1 p2} -> + kfilt g p1 = kfilt g p2. +Proof. exact: eq_in_umfiltk. Qed. + +Lemma kfilt_eq g (p1 p2 : pred node) : + p1 =1 p2 -> + kfilt g p1 = kfilt g p2. +Proof. by move=>N; apply: eq_in_kfilt. Qed. + +Lemma adj_kfilt g p x : + adj (kfilt g p) x = + if p x then adj g x else [::]. +Proof. by rewrite /adj find_umfiltk; case: (p x). Qed. + +Lemma children_kfilt g p x y : + (y \in children (kfilt g p) x) = + [&& p x, p y & y \in children g x]. +Proof. +rewrite /children !mem_filter /= adj_kfilt dom_umfiltk inE -andbA. +by case: (p x)=>//=; rewrite !andbF. +Qed. + +Lemma edge_kfilt g (p : pred node) x y : + edge (kfilt g p) x y = [&& x \in p, y \in p & edge g x y]. +Proof. by rewrite /edge /= children_kfilt. Qed. + +Lemma edge_kfiltE g (p : pred node) : + {in p &, edge (kfilt g p) =2 edge g}. +Proof. by move=>x y X Y; rewrite edge_kfilt X Y. Qed. + +Lemma nodes_kfiltE g (p : pred node) : + nodes (kfilt g p) = filter p (nodes g). +Proof. by rewrite dom_umfiltkE. Qed. + +Lemma nodes_kfilt g (p : pred node) x : + (x \in nodes (kfilt g p)) = (x \in nodes g) && (x \in p). +Proof. by rewrite nodes_kfiltE mem_filter andbC. Qed. + +Lemma kfilt_nodesE g (p : pred node) : + {subset nodes g <= p} <-> + kfilt g p = g. +Proof. exact: umfiltk_subdomE. Qed. + +Lemma kfilt_nodes g (p : pred node) : + {subset nodes g <= p} -> + kfilt g p = g. +Proof. by move/kfilt_nodesE. Qed. + +Lemma find_kfilt g (p : pred node) x : + find x (kfilt g p) = + if x \in p then find x g else None. +Proof. exact: find_umfiltk. Qed. + +Lemma edge_kfilt_sub g p : + subrel (edge (kfilt g p)) (edge g). +Proof. by move=>a b; rewrite edge_kfilt; case/and3P. Qed. + +Lemma edge_kfilt_in_sub g p : + {in p &, subrel (edge g) (edge (kfilt g p))}. +Proof. by move=>a b Ax Bx; rewrite edge_kfilt Ax Bx. Qed. + +Lemma edge_kfilt_mono g (p1 p2 : pred node) : + {subset p1 <= p2} -> + {in p1 &, subrel (edge (kfilt g p1)) (edge (kfilt g p2))}. +Proof. by move=>H a b Ax Bx; rewrite !edge_kfiltE //; apply: H. Qed. + +Lemma kfilt_nodesI g (p : pred node) : + kfilt g p = kfilt g [predI nodes g & p]. +Proof. by rewrite kfilt_predIC [in RHS](@kfilt_nodes g). Qed. + +Lemma kfiltC g (p : pred node) : + g = kfilt g p \+ kfilt g (predC p). +Proof. exact: umfilt_predC. Qed. + +Lemma kfiltC1 g x : kfilt g (predC1 x) = free g x. +Proof. exact: umfiltkC1. Qed. + +Lemma kfiltUn_nodes g1 g2 : + [pcm g1 <= g2] -> + valid g2 -> + kfilt g2 [in nodes g1] = g1. +Proof. by case=>g -> W; rewrite /kfiltx umfiltk_dom. Qed. + +Lemma In_nodes_kfiltX g (p : pred node) x : + reflect (exists v xs, (x, (v, xs)) \In g /\ p x) + (x \in nodes (kfilt g p)). +Proof. +by case: In_dom_umfilt=>H; constructor; [case: H=>-[]|case=>v [?][]]; eauto. +Qed. + +End Kfilt. + +Arguments edge_kfilt_in_sub {V A g p}. + +(**********************) +(* Filter by contents *) +(**********************) + +(* select subgraph consisting of nodes *) +(* whose contents is in the given list of contents *) + +Definition cfiltx {V : link} {A : eqType} (xs : seq A) g : + partial_graph V A := um_filterv (mem xs \o fst) g. +HB.instance Definition _ V A xs := + OmapFun.copy (@cfiltx V A xs) (@cfiltx V A xs). +Abbreviation cfilt g xs := (@cfiltx _ _ xs g). + +Section Cfilt. +Context {V : link} {A : eqType}. +Implicit Types (g : partial_graph V A) (xs : seq A). + +(* equalities by side-conditions *) + +Lemma eq_in_cfilt g xs1 xs2 : + {in range (labels g), xs1 =i xs2} -> + cfilt g xs1 = cfilt g xs2. +Proof. +move=>H; apply: eq_in_umfiltv; case=>v k /In_rangeX [x /In_labels X]. +by apply/H/mem_range/X. +Qed. + +Lemma id_in_cfilt g xs : + {subset range (labels g) <= xs} -> + cfilt g xs = g. +Proof. +by move=>H; rewrite omf_some /omfx //= =>-[k [v a]] /In_labels/mem_range/H ->. +Qed. + +Lemma in_cfilt0 g xs : + valid g -> + {subset range (labels g) <= predC (mem xs)} -> + cfilt g xs = Unit. +Proof. +by move=>W H; apply: umfilt_mem0L=>//= k [v a] /In_labels/mem_range/H. +Qed. + +(* equalities by reducing to sets of nodes *) + +Lemma eq_cfiltD g (xs1 xs2 : seq A) : + nodes (cfilt g xs1) =i nodes (cfilt g xs2) -> + cfilt g xs1 = cfilt g xs2. +Proof. exact: eq_umfiltD. Qed. + +Lemma id_cfiltD g (xs : seq A) : + nodes (cfilt g xs) =i nodes g -> + cfilt g xs = g. +Proof. exact: id_umfiltD. Qed. + +(* equalities by complementary sequences *) + +Lemma cfiltC g xs1 xs2 : + {in range (labels g), xs2 =i [predC xs1]} -> + cfilt g xs1 \+ cfilt g xs2 = g. +Proof. +move=>H; rewrite [RHS](umfilt_predC g (mem xs1 \o fst \o snd)). +congr (_ \+ _); apply/eq_in_umfilt=>-[k [v a]] /In_labels/mem_range /=. +by move/H=>->. +Qed. + +Lemma cfiltCE g xs1 xs2 : + {in range (labels g), xs2 =i [predC xs1]} -> + cfilt g xs2 = Unit -> + cfilt g xs1 = g. +Proof. by move/cfiltC=>/[swap] E; rewrite E unitR. Qed. + +(* prefixing everything with nodes can avoid a check for validity *) +Lemma nodes_cfiltCE g xs1 xs2 : + {in range (labels g), xs2 =i [predC xs1]} -> + nodes (cfilt g xs2) =i [::] -> + nodes (cfilt g xs1) = nodes g. +Proof. +case: (normalP g)=>[->//|W] E. +have Vg : valid (cfilt g xs2) by rewrite pfVE. +by move/(dom0E Vg)/cfiltCE->. +Qed. + +(* cfilt with nodes, find, free, union *) + +Lemma nodes_cfiltE g xs x : + (x \in nodes (cfilt g xs)) = + if find x g is Some v then v.1 \in xs else false. +Proof. +rewrite dom_umfiltE mem_filter. +by case: dom_find=>//= v; rewrite andbT. +Qed. + +Lemma nodes_cfiltX a g xs x : + (x \in nodes (cfilt g xs)) = + (x \in nodes g) && (odflt a (olabel g x) \in xs). +Proof. by rewrite nodes_cfiltE /olabel find_omf /omfx; case: dom_find. Qed. + +Lemma nodes_cfilt g xs x v : + (x, v) \In g -> + (x \in nodes (cfilt g xs)) = (v.1 \in xs). +Proof. by rewrite nodes_cfiltE=>/In_find ->. Qed. + +Lemma find_cfilt g xs x : + find x (cfilt g xs) = + if find x g is Some v then + if v.1 \in xs then Some v else None + else None. +Proof. exact: find_umfilt. Qed. + +Lemma cfiltF g xs x : cfilt (free g x) xs = free (cfilt g xs) x. +Proof. exact: omfF. Qed. + +(* union and cons lemmas stated with relativized side-conditions *) + +Lemma cfiltUnX g xs1 xs2 : + {in range (labels g), {subset xs1 <= [predC xs2]}} -> + cfilt g (xs1 ++ xs2) = cfilt g xs1 \+ cfilt g xs2. +Proof. +move=>H; rewrite /cfiltx (umfiltv_predD (q1 := mem xs1 \o fst)). +- by move=>x /=; rewrite mem_cat=>->. +congr (_ \+ _); apply: eq_in_umfiltv; case=>k a X /=. +rewrite mem_cat; case D: (k \in xs1)=>//=. +case/In_rangeX: X=>b /In_labels/mem_range=>/= X. +by move/negbTE: (H k X D). +Qed. + +Lemma cfilt_consX g x xs : + {in range (labels g), forall x, x \notin xs} -> + cfilt g (x :: xs) = cfilt g [:: x] \+ cfilt g xs. +Proof. by move=>H; rewrite -cat1s cfiltUnX // => z /H. Qed. + +(* union and cons lemma variants with boolean *) +(* non-relativized side-conditions *) +(* useful for automated discharge *) + +Lemma cfiltUn g xs1 xs2 : + all (predC (mem xs2)) xs1 -> + cfilt g (xs1 ++ xs2) = cfilt g xs1 \+ cfilt g xs2. +Proof. by move/allP=>H; apply/cfiltUnX=>z _; apply: H. Qed. + +Lemma cfilt_cons g x xs : + x \notin xs -> + cfilt g (x :: xs) = cfilt g [:: x] \+ cfilt g xs. +Proof. by move=>H; rewrite -cat1s cfiltUn //= H. Qed. + +(* intersections *) + +Lemma cfilt_predI g xs1 xs2 : + cfilt (cfilt g xs1) xs2 = cfilt g (filter (mem xs1) xs2). +Proof. +rewrite /cfiltx -umfilt_predI -eq_in_umfilt. +by case=>k v /=; rewrite mem_filter andbC. +Qed. + +Lemma cfilt_predIC g xs1 xs2 : + cfilt (cfilt g xs1) xs2 = cfilt g (filter (mem xs2) xs1). +Proof. +by rewrite cfilt_predI; apply: eq_in_cfilt=>W _; apply: filter_mem_sym. +Qed. + +Lemma nodes_cfiltI g xs1 xs2 x : + (x \in nodes (cfilt (cfilt g xs1) xs2)) = + (x \in nodes (cfilt g xs1)) && (x \in nodes (cfilt g xs2)). +Proof. +rewrite !nodes_cfiltE find_cfilt; case: dom_find=>// v _ _. +by case: ifP. +Qed. + +Lemma cfilt_nil g : + valid g -> + cfilt g [::] = Unit. +Proof. exact: umfilt_pred0. Qed. + +(* memebership in disjoint filters: prop variant *) + +Lemma nodes_cfiltNX g xs1 xs2 x : + all (predC (mem xs2)) xs1 -> + x \in nodes (cfilt g xs1) -> + ~ x \in nodes (cfilt g xs2). +Proof. +move/all_filterPC=>E D1 D2. +have : x \in nodes (cfilt g (filter (mem xs2) xs1)). +- by rewrite -cfilt_predI nodes_cfiltI D1 D2. +rewrite E cfilt_nil //. +by case/In_domX: D1=>v /In_umfiltX [_] /In_valid. +Qed. + +Lemma nodes0_cfiltNX g xs1 xs2 x : + all (predC (mem xs2)) xs1 -> + x \in nodes0 (cfilt g xs1) -> + ~ x \in nodes (cfilt g xs2). +Proof. +rewrite !inE=>X /orP [/eqP -> /dom_cond //|]. +by apply: nodes_cfiltNX. +Qed. + +(* membership in disjoint filters: bool variant *) + +Lemma nodes_cfiltN g xs1 xs2 x : + all (predC (mem xs2)) xs1 -> + x \in nodes (cfilt g xs1) -> + x \notin nodes (cfilt g xs2). +Proof. by move=>E X; apply/negP/(nodes_cfiltNX E X). Qed. + +Lemma nodes0_cfiltN g xs1 xs2 x : + all (predC (mem xs2)) xs1 -> + x \in nodes0 (cfilt g xs1) -> + x \notin nodes (cfilt g xs2). +Proof. +move=>E; rewrite inE; case/orP=>[/eqP ->|/(nodes_cfiltN E)//]. +by rewrite cond_dom. +Qed. + +(* membership in subfilters: positive versions *) + +Lemma nodes_cfiltS g xs1 xs2 x : + all (mem xs2) xs1 -> + x \in nodes (cfilt g xs1) -> + x \in nodes (cfilt g xs2). +Proof. +move/allP=>X; rewrite !nodes_cfiltE. +by case: (find x g)=>// -[z v] /X. +Qed. + +Lemma nodes0_cfiltS g xs1 xs2 x : + all (mem xs2) xs1 -> + x \in nodes0 (cfilt g xs1) -> + x \in nodes0 (cfilt g xs2). +Proof. +move=>X; rewrite !inE=>/orP [->|/(nodes_cfiltS X)->] //. +by rewrite orbT. +Qed. + +(* membership in subfilters: negative versions *) + +Lemma nodes_cfiltSN g xs1 xs2 x : + all (mem xs2) xs1 -> + x \notin nodes (cfilt g xs2) -> + x \notin nodes (cfilt g xs1). +Proof. by move=>X; apply/contra/nodes_cfiltS. Qed. + +Lemma nodes0_cfiltSN g xs1 xs2 x : + all (mem xs2) xs1 -> + x \notin nodes0 (cfilt g xs2) -> + x \notin nodes (cfilt g xs1). +Proof. +by move=>X; rewrite inE negb_or; case/andP=>_ /nodes_cfiltSN; apply. +Qed. + +Lemma nodes00_cfiltSN g xs1 xs2 x : + all (mem xs2) xs1 -> + x \notin nodes0 (cfilt g xs2) -> + x \notin nodes0 (cfilt g xs1). +Proof. by move=>X; apply/contra/nodes0_cfiltS. Qed. + +Lemma nodes_cfiltC g xs1 xs2 x : + {in range (labels g), xs2 =i [predC xs1]} -> + (x \in nodes g) = + (x \in nodes (cfilt g xs1)) || + (x \in nodes (cfilt g xs2)). +Proof. +move=>E; case: (normalP g)=>[->//|W]. +rewrite -{1}(cfiltC E) domUn inE -cfiltUnX ?pfVE ?W //. +by move=>z {}/E E; rewrite inE /= E inE negbK. +Qed. + +Lemma nodes0_cfiltC g xs1 xs2 x : + {in range (labels g), xs2 =i [predC xs1]} -> + x \notin nodes0 (cfilt g xs1) -> + (x \in nodes0 g) = (x \in nodes (cfilt g xs2)). +Proof. +rewrite !inE negb_or => E /andP [/negbTE ->] /= X. +by rewrite (nodes_cfiltC x E) (negbTE X). +Qed. + +Lemma adj_cfiltS g xs x : + {subset adj (cfilt g xs) x <= adj g x}. +Proof. +by move=>z; rewrite /adj find_cfilt /=; case: (find x g)=>//=a ; case: ifP. +Qed. + +End Cfilt. + +Arguments nodes0_cfiltC {V A g xs1} xs2 {x _}. +Arguments nodes_cfiltCE {V A g xs1}. + +(* interaction of cfilt and kfilt *) + +Section CfiltKfilt. +Context {V : link} {A : eqType}. +Implicit Types (g : partial_graph V A) (p : pred node) (xs : seq A). + +Lemma ckfilt g p xs : + cfilt (kfilt g p) xs = kfilt (cfilt g xs) p. +Proof. +rewrite /cfiltx/kfiltx -!umfilt_predI. +by apply/eq_in_umfilt; case=>k v H /=; rewrite andbC. +Qed. + +(* different name for the other direction *) +Lemma kcfilt g p xs : + kfilt (cfilt g xs) p = cfilt (kfilt g p) xs. +Proof. by rewrite ckfilt. Qed. + +End CfiltKfilt. + +(******************************) +(* Updating single graph node *) +(******************************) + +(* according to function f that *) +(* modifies node's contents and linkage *) + +Definition updgf {V : link} {A} x (f : A * V -> A * V) + (g : partial_graph V A) : partial_graph V A := + if find x g is Some v then upd x (f v) g else undef. + +Section UpdgLemmas. +Context {V : link} {A : Type}. +Implicit Types (g : partial_graph V A) (f : A * V -> A * V). + +Lemma nodesUg x f g : + nodes (updgf x f g) = + if x \in nodes g then nodes g else [::]. +Proof. +rewrite /updgf; case: dom_find=>[//|[k v] /In_find H]. +by rewrite domUE // (In_dom H). +Qed. + +Lemma adjUg x f g a : + adj (updgf x f g) a = + if find x g is Some v then + if a == x then links (f v).2 + else adj g a + else [::]. +Proof. +rewrite /updgf/adj; case: (dom_find x g)=>[//|[k v] /In_find H _]. +by rewrite findU (In_cond H) (In_valid H); case: (a =P x). +Qed. + +Lemma childrenUg x f g a : + children (updgf x f g) a = + if find x g is Some v then + if a == x then filter [in nodes g] (links (f v).2) + else children g a + else [::]. +Proof. +rewrite /children adjUg nodesUg. +case: (dom_find x g)=>[//|[k v] /In_find H _]. +by case: (a =P x). +Qed. + +Lemma edgeUg x f g a b : + edge (updgf x f g) a b = + if find x g is Some v then + if a == x then (b \in nodes g) && (b \in links (f v).2) + else edge g a b + else false. +Proof. +rewrite /updgf/edge/= !mem_filter /adj. +case: (dom_find x g)=>[//|[k v] /In_find H _]. +rewrite domUE ?(In_dom H) // findU (In_cond H) (In_valid H) /=. +by case: (a =P x). +Qed. + +Lemma findUg x y f g : + find x (updgf y f g) = + if find y g is Some v then + if x == y then Some (f v) + else find x g + else None. +Proof. +rewrite /updgf; case: (dom_find y)=>[//|[k v] /In_find H _]. +by rewrite findU (In_cond H) (In_valid H). +Qed. + +Lemma umfiltUg x f p g : + um_filter p (updgf x f g) = + if find x g is Some v then + if p (x, f v) then upd x (f v) (um_filter p g) + else free (um_filter p g) x + else undef. +Proof. +rewrite /updgf. +case: (dom_find x g)=>[//|[k v] /In_find H _]. +by rewrite umfiltU ?(In_cond H). +Qed. + +Lemma kfiltUg x f p g : + kfilt (updgf x f g) p = + if p x then updgf x f (kfilt g p) + else if x \in nodes g then free (kfilt g p) x + else undef. +Proof. +rewrite /kfiltx !umfiltUg /updgf find_umfiltk /=. +by case: (p x)=>//; case: (dom_find x g). +Qed. + +Lemma InFUg w x f g : + w \In updgf x f g <-> + if find x g is Some v then + if w.1 == x then w.2 = f v + else w \In free g x + else False. +Proof. +rewrite /updgf. +case: (dom_find x g)=>[_|[k v] /In_find H _]. +- by split=>// /In_undef. +rewrite InFU validU (In_cond H) (In_valid H). +by split=>//; case. +Qed. + +Lemma InUg w x f g : + w \In updgf x f g <-> + if find x g is Some v then + if w.1 == x then w.2 = f v + else w \In g + else False. +Proof. +rewrite /updgf. +case: (dom_find x g)=>[_|[k v] /In_find H _]. +- by split=>// /In_undef. +rewrite InU validU (In_cond H) (In_valid H). +by split=>//; case. +Qed. + +End UpdgLemmas. + +(* update contents and linkage, without looking at old ones *) +Abbreviation updg x v g := (updgf x (fun => v) g). +(* update contents while preserving old linkage *) +Abbreviation updgC x a g := (updgf x (fun v => (a, v.2)) g). + + +(***********) +(* Mapping *) +(***********) + +(* modify contents and linkage of each node in the graph *) +(* according to a function *) + +Definition graph_map {V : link} {A B} f : + partial_graph V A -> partial_graph V B := + omap (fun x => Some (f x.1 x.2)). + +HB.instance Definition _ V A B f := + OmapFun.copy (@graph_map V A B f) (graph_map f). +HB.instance Definition _ (V : link) A B f := + isMapFun.Build nat nat_pred (A*V)%type (B*V)%type + (@partial_graph V A) (partial_graph V B) + (@graph_map V A B f) (fun => is_true_true). + +Section GraphMap. +Context {V : link} {A B : Type}. +Implicit Type g : partial_graph V A. +Implicit Type f : node -> A * V -> B * V. + +Lemma eq_in_graphmap f1 f2 g : + (forall k v, (k, v) \In g -> f1 k v = f2 k v) <-> + graph_map f1 g = graph_map f2 g. +Proof. by rewrite -eq_in_omap; split=>[/= H x /H ->|H k v /H []]. Qed. + +Lemma graphmap_id (f : node -> A * V -> A * V) g : + (forall k v, (k, v) \In g -> f k v = v) -> + graph_map f g = g. +Proof. by move=>H; rewrite omf_some /omfx //= =>-[k v] /H ->. Qed. + +(* renaming basic properties for easier search *) + +Lemma nodes_graphmap f g : nodes (graph_map f g) = nodes g. +Proof. exact: dom_mf. Qed. + +Lemma find_graphmap f g x : + find x (graph_map f g) = + if find x g is Some v then Some (f x v) else None. +Proof. exact: find_omf. Qed. + +Lemma graphmapPt f x v : + graph_map f (pts x v) = pts x (f x v). +Proof. exact: mfPt. Qed. + +Lemma graphmapPtUn f x v g : + graph_map f (pts x v \+ g) = pts x (f x v) \+ graph_map f g. +Proof. exact: mfPtUn. Qed. + +Lemma graphmapUnPt f x v g : + graph_map f (g \+ pts x v) = graph_map f g \+ pts x (f x v). +Proof. exact: mfUnPt. Qed. + +Lemma graphmapUn f g1 g2 : + graph_map f (g1 \+ g2) = graph_map f g1 \+ graph_map f g2. +Proof. exact: mfUn. Qed. + +Lemma graphmapF f g x : graph_map f (free g x) = free (graph_map f g) x. +Proof. exact: omfF. Qed. + +End GraphMap. + +(***********) +(* Erasure *) +(***********) + +(* erase contents of each node *) +(* that is, map a graph with contents A to *) +(* the graph with contents unit *) +(* but unmodified linkage *) + +Definition erase {V : link} A (g : partial_graph V A) := + graph_map (fun _ v => (tt, v.2)) g. +HB.instance Definition _ V A := + MapFun.copy (@erase V A) (@erase V A). + +Section Erase. +Context {V : link} {A : Type}. +Implicit Type g : partial_graph V A. + +Lemma nodes_erase g : nodes (erase g) = nodes g. +Proof. exact: nodes_graphmap. Qed. + +Lemma edge_erase g : edge (erase g) =2 edge g. +Proof. +move=>x y; rewrite /edge/erase /= !mem_filter dom_omf_some //=. +by rewrite /adj find_omf; case: (find x g). +Qed. + +Lemma find_erase g x : + find x (erase g) = + ssrfun.omap (pair tt \o snd) (find x g). +Proof. by exact: find_omf. Qed. + +Lemma adj_erase g : adj (erase g) =1 adj g. +Proof. by move=>x; rewrite /adj find_erase; case: (find x g). Qed. + +Lemma In_eraseX g x vv : + (x, vv) \In erase g <-> + exists v, (x, (v, vv.2)) \In g. +Proof. +case: vv; case=>vv; rewrite In_omfX /=; split. +- by case=>[[w1 w2]] H [<-]; exists w1. +by case=>v H; exists (v, vv). +Qed. + +Lemma In_erase g x v adj : + (x, (v, adj)) \In g -> + (x, (tt, adj)) \In erase g. +Proof. by move=>H; apply/In_eraseX; exists v. Qed. + +Lemma In_eraseA g x v : + (x, (tt, v)) \In erase g <-> + x \in nodes g /\ links v = adj g x. +Proof. +split; first by case/In_eraseX=>a /[dup] /In_dom D /In_graph. +case=>/In_domX [[a w]] /[dup] H /In_graph -> /inj_links ->. +by apply/In_eraseX; exists a. +Qed. + +Lemma erase_eq g1 g2 : + valid g1 -> + valid g2 -> + erase g1 = erase g2 <-> + [/\ nodes g1 =i nodes g2 & + adj g1 =1 adj g2]. +Proof. +move=>V1 V2; split=>[E|[En Ea]]. +- split; first by rewrite -nodes_erase E nodes_erase. + by move=>z; rewrite -adj_erase E adj_erase. +apply: umem_eq; rewrite ?pfVE //; case=>k [][xs]. +by rewrite !In_eraseA En Ea. +Qed. + +Lemma find_erase_eq g1 g2 x : + find x (erase g1) = find x (erase g2) <-> + ssrfun.omap snd (find x g1) = ssrfun.omap snd (find x g2). +Proof. +rewrite !find_erase /ssrfun.omap/obind/oapp. +case: (find x g1); case: (find x g2)=>//= a1 a2. +by split; case=>->. +Qed. + +Lemma kfilt_erase g p : kfilt (erase g) p = erase (kfilt g p). +Proof. by rewrite umfiltk_omf. Qed. + +Lemma erase_kfilt g p : erase (kfilt g p) = kfilt (erase g) p. +Proof. by rewrite umfiltk_omf. Qed. + +Lemma erase_id (g : partial_graph V unit) : erase g = g. +Proof. by rewrite omf_some //; case=>k [[]]. Qed. + +Lemma erasePt x (v : A) (xs : seq node) : + erase (pts x (v, xs)) = pts x (tt, xs). +Proof. exact: mfPt. Qed. + +Lemma erasePtUn x v xs g : + erase (pts x (v, xs) \+ g) = pts x (tt, xs) \+ erase g. +Proof. exact: mfPtUn. Qed. + +Lemma eraseUn g1 g2 : + erase (g1 \+ g2) = erase g1 \+ erase g2. +Proof. exact: mfUn. Qed. + +Lemma eraseF g x : erase (free g x) = free (erase g) x. +Proof. exact: omfF. Qed. + +End Erase. + +(*********) +(* Sinks *) +(*********) + +(* list of nodes that have an incoming edge *) +(* includes target nodes of dangling edges *) + +Definition sinks {V : link} {A} (g : partial_graph V A) : seq node := + flatten (map (links \o snd) (range g)). + +Section Sinks. +Context {V : link} {A : Type}. +Implicit Type g : partial_graph V A. + +Lemma sinks_bigadj g : + sinks g =i \big[cat/[::]]_(x <- nodes g) (adj g x). +Proof. +move=>x; rewrite /sinks/adj flatten_map_big assocs_dom !big_map. +by congr (x \in _); apply: eq_Bigr=>-[k v] /In_assocs/In_find ->. +Qed. + +(* sinks with property that x \in nodes g *) +Lemma sinksP g y : + reflect (exists2 x, x \in nodes g & y \in adj g x) + (y \in sinks g). +Proof. by rewrite sinks_bigadj big_cat_mem_has; apply: hasP. Qed. + +(* version without x \in nodes g *) +Lemma sinksPA g y : + reflect (exists x, y \in adj g x) (y \in sinks g). +Proof. +apply: (iffP (sinksP g y)); first by case=>x Dx Ay; exists x. +by case=>x Ay; exists x=>//; apply: adjD Ay. +Qed. + +Lemma sinks_undef : sinks (undef : partial_graph V A) = [::]. +Proof. by []. Qed. + +Lemma sinks_unit : sinks (Unit : partial_graph V A) = [::]. +Proof. by []. Qed. + +Lemma sinksPt x (v : A * V) : + sinks (pts x v) = if x != null then links v.2 else [::]. +Proof. by case: eqVneq=>[->//|N]; rewrite /sinks rangePtK //= cats0. Qed. + +Lemma sinksUn g1 g2 : + valid (g1 \+ g2) -> + sinks (g1 \+ g2) =i sinks g1 ++ sinks g2. +Proof. +move=>W /= x; rewrite mem_cat; case: flattenP=>/= H; apply/esym. +- case: H=>_ /mapPP [v ->] /In_rangeX [k] /InUn [] H /= X; + apply/orP; [left|right]; apply/flattenP=>//=; exists (links v.2)=>//; + by apply/mapPP; exists v=>//; apply: In_range H. +by apply: contra_notF H; case/orP=>/flattenP [_] /mapPP [v -> H /= X]; +exists (links v.2)=>//; apply/mapPP; exists v=>//; +[apply: In_rangeL H|apply: In_rangeR H]. +Qed. + +Lemma sinksUnE g1 g2 x : + valid (g1 \+ g2) -> + (x \in sinks (g1 \+ g2)) = (x \in sinks g1) || (x \in sinks g2). +Proof. by rewrite -mem_cat=>/sinksUn ->. Qed. + +Lemma sinksPtUn x (v : A * V) g : + valid (pts x v \+ g) -> + sinks (pts x v \+ g) =i links v.2 ++ sinks g. +Proof. by move=>W a; rewrite sinksUn // sinksPt (validPtUn_cond W). Qed. + +Lemma sinksPtUnK x (v : A * V) g : + valid (pts x v \+ g) -> + path ord x (nodes g) -> + sinks (pts x v \+ g) = links v.2 ++ sinks g. +Proof. by move=>W /(order_path_min trans) P; rewrite /sinks rangePtUnK. Qed. + +Lemma sinksV g x : + x \in sinks g -> + valid g. +Proof. by move/sinksP=>[y] /dom_valid. Qed. + +Lemma adj_sinks_sub g x : {subset adj g x <= sinks g}. +Proof. by move=>y X; apply/sinksPA; exists x. Qed. + +End Sinks. + +Section Sinks2. +Context {V : link} {A : Type}. +Implicit Type g : partial_graph V A. + +Lemma sinks_erase g : sinks (erase g) = sinks g. +Proof. +elim/um_indf: g=>[||k [v xs] g IH W P]. +- by rewrite pfundef. +- by rewrite pfunit. +rewrite erasePtUn !sinksPtUnK ?IH //. +- by rewrite -(erasePtUn k v xs) pfVE. +by rewrite nodes_erase. +Qed. + +Lemma sinks_kfilt_sub {g} {p} : {subset sinks (kfilt g p) <= sinks g}. +Proof. +case: (normalP g)=>[->|W x S]; first by rewrite pfundef. +by rewrite (kfiltC g p) in W *; rewrite sinksUnE // S. +Qed. + +Lemma sinks_free_sub {g} {x} : {subset sinks (free g x) <= sinks g}. +Proof. +move=>y; have [|Nx] := boolP (x \in nodes g); last by rewrite freeND. +case/um_eta=>kv [/In_find/In_valid W E] S. +by rewrite E in W *; rewrite sinksUnE // S orbT. +Qed. + +End Sinks2. + +(**********) +(* Leaves *) +(**********) + +(* leaf is a node with only null successors, if any *) + +Definition leaves {V : link} {A} (g : partial_graph V A) : seq node := + filter (fun y => all (eq_op^~ null) (adj g y)) (nodes g). + +Lemma leavesE {V : link} {A} (g : partial_graph V A) x : + (x \in leaves g) = + (x \in nodes g) && all (fun x => x == null) (adj g x). +Proof. by rewrite mem_filter andbC. Qed. + +Lemma leavesP {V : link} {A} (g : partial_graph V A) x : + reflect (x \in nodes g /\ + {in adj g x, forall x, x == null}) + (x \in leaves g). +Proof. by rewrite leavesE; apply: (iffP andP); case=>-> /allP. Qed. + +Lemma leavesD {V : link} {A} {g : partial_graph V A} : + {subset leaves g <= nodes g}. +Proof. by move=>x; rewrite mem_filter=>/andP []. Qed. + +Lemma leavesUn {V : link} {A} (g1 g2 : partial_graph V A) x : + valid (g1 \+ g2) -> + (x \in leaves (g1 \+ g2)) = (x \in leaves g1) || (x \in leaves g2). +Proof. +move=>W; rewrite !leavesE domUnE // adjUnL //. +by case D: (x \in dom g1)=>//=; rewrite (negbTE (dom_inNL W D)) orbF. +Qed. + +(*********) +(* loops *) +(*********) + +(* loop is a cycle of size 1 *) + +Definition loops {V : link} {A} (g : partial_graph V A) : seq node := + nodes (kfilt g (fun x => x \in adj g x)). + +Section LoopsLemmas. +Context {V : link} {A : Type}. +Implicit Type g : partial_graph V A. + +Lemma loopsE g x : + (x \in loops g) = (x \in nodes g) && (x \in adj g x). +Proof. exact: nodes_kfilt. Qed. + +Lemma In_loopsP g x : + reflect (exists v xs, (x, (v, xs)) \In g /\ x \in links xs) + (x \in loops g). +Proof. +apply: (iffP (In_nodes_kfiltX g _ x)); +by case=>v [xs][/[dup]/In_graph ->]; exists v, xs. +Qed. + +Lemma loopsD {g} : {subset loops g <= nodes g}. +Proof. by move=>x; rewrite loopsE=>/andP []. Qed. + +Lemma disj_loopsR g1 g2 : + valid (g1 \+ g2) -> + disjoint (nodes g1) (loops g2). +Proof. by move=>W; apply/disjoint_subL/disjointD/W/loopsD. Qed. + +Lemma disj_loopsL g1 g2 : + valid (g1 \+ g2) -> + disjoint (nodes g2) (loops g1). +Proof. by rewrite joinC; apply/disj_loopsR. Qed. + +Lemma loopsUn g1 g2 x : + valid (g1 \+ g2) -> + (x \in loops (g1 \+ g2)) = (x \in loops g1) || (x \in loops g2). +Proof. +move=>W; rewrite !loopsE domUnE // adjUnL //. +by case D: (x \in dom g1)=>//=; rewrite (negbTE (dom_inNL W D)) orbF. +Qed. + +End LoopsLemmas. + + +(****************) +(* Reachability *) +(****************) + +(* given node x, list of nodes connected to x *) + +Definition reach {V : link} A (g : partial_graph V A) x := + dfs g (size (nodes g)) [::] x. + +(***************************) +(* reach in terms of paths *) +(***************************) + +Section ReachPath. +Context {V : link} {A : Type}. +Implicit Type g : partial_graph V A. + +Lemma reachP g x y : + reflect [/\ x \in nodes g & exists xs, + path (edge g) x xs /\ y = last x xs] + (y \in reach g x). +Proof. +rewrite /reach /=. +case: (boolP (x \in nodes g))=>Dx; last first. +- by move/dfs_notin: Dx=>->; constructor; case. +apply: (iffP (dfs_pathP _ _ _ _ _))=>//. +- by case=>xs P E /disjoint_consRE [_] D; split=>//; exists xs. +by case=>_ [xs][P E]; exists xs=>//; apply/allP. +Qed. + +(* there's path from x to y with no duplicates *) +Lemma reachX g x y : + reflect [/\ x \in nodes g & exists xs, + [/\ path (edge g) x xs, y = last x xs & + uniq (x :: xs)]] + (y \in reach g x). +Proof. +case: reachP=>H; constructor; last first. +- by case=>Dx [xs][Px E _]; apply: H; split=>//; exists xs. +case: H=>Dx [xs][Px Ey]; split=>//. +by case/shortenP: Px Ey=>xs' Px U S Ey; exists xs'. +Qed. + +(* alternative characterization of reach *) +Lemma reachEA g x y : + (y \in reach g x) = + if x \in nodes g then + (y == x) || has (fun i => y \in reach (free g x) i) (adj g x) + else false. +Proof. +apply/idP/idP. +- case/reachX=>Dx [[|z xs]][/=]; rewrite Dx ?inE ?negb_or. + - by move=>_ -> _; rewrite eqxx. + case/andP=>Eg P E /andP [/andP [Nxz Nx]] /andP [Nz U]. + have Nzxs : x \notin z :: xs by rewrite inE negb_or Nxz Nx. + apply/orP; right; apply/hasP; exists z; first by rewrite edgeA. + apply/reachP; split; first by rewrite domF eq_sym (negbTE Nxz) (edgeD Eg). + by exists xs; rewrite -(eq_in_path (edge_free_eq g Nzxs)). +move=>N; apply/reachP; case: ifP N=>// Dx /orP [/eqP ->|N]; +split=>//; first by exists [::]. +case/hasP: N=>z Az /reachP []; rewrite domF eq_sym. +case: (x =P z)=>//= /eqP Nxz Dz [xs][] /shortenP [xs' P U _ E]. +move: (path_nodes P)=>P1; have Nz : x \notin z :: xs'. +- by rewrite inE negb_or Nxz (contra (P1 _)) // domF eqxx. +by exists (z :: xs'); rewrite /= adj_edge //= (eq_in_path (edge_free_eq g Nz)). +Qed. + +(* tighter alternative using children instead of adj *) +Lemma reachE g x y : + (y \in reach g x) = + if x \in nodes g then + (y == x) || has (fun i => y \in reach (free g x) i) (children g x) + else false. +Proof. +rewrite reachEA; case: ifP=>// Dx; case: (y =P x)=>//= /eqP Nyx. +apply/hasP/hasP; case=>z Eg H; exists z=>//; last first. +- by rewrite -edge_children in Eg; rewrite edgeA. +rewrite -edge_children adj_edge //. +by case/reachP: H; rewrite domF; case: eqP. +Qed. + +(* restatement via membership *) + +Lemma reachEAX g x : + reach g x =i + if x \in nodes g then + [predU pred1 x & \big[cat/[::]]_(i <- adj g x) reach (free g x) i] + else pred0. +Proof. by move=>y; rewrite 2!fun_if inE big_cat_mem_has -reachEA. Qed. + +Lemma reachEX g x : + reach g x =i + if x \in nodes g then + [predU pred1 x & \big[cat/[::]]_(i <- children g x) reach (free g x) i] + else pred0. +Proof. by move=>y; rewrite 2!fun_if inE big_cat_mem_has -reachE. Qed. + +End ReachPath. + +(***************************) +(* reach structural lemmas *) +(***************************) + +Section ReachStructurals. +Context {V : link} {A : Type}. +Implicit Type g : partial_graph V A. + +Lemma reach_undef x : reach (undef : partial_graph V A) x = [::]. +Proof. by apply: eqnil=>y; apply/reachP; case; rewrite nodes_undef. Qed. + +Lemma reach_unit x : reach (Unit : partial_graph V A) x = [::]. +Proof. by apply: eqnil=>y; apply/reachP; case; rewrite nodes_unit. Qed. + +Lemma reachV g x y : + y \in reach g x -> + valid g. +Proof. by case: (normalP g)=>[->|//]; rewrite reach_undef. Qed. + +Lemma reachD g x y : + y \in reach g x -> + (x \in nodes g) * (y \in nodes g). +Proof. +case/reachP=>Dx [xs][P E]. +have : y \in x :: xs by rewrite E mem_last. +rewrite inE; case/orP=>[/eqP ->//|Dy]. +by rewrite Dx (path_nodes P Dy). +Qed. + +Lemma reachD1 g x y : + y \in reach g x -> + x \in nodes g. +Proof. by case/reachD. Qed. + +Lemma reachD2 g x y : + y \in reach g x -> + y \in nodes g. +Proof. by case/reachD. Qed. + +Lemma reachD_kfilt g p x y : + y \in reach (kfilt g p) x -> + (x \in nodes g) * (y \in nodes g) * (x \in p) * (y \in p). +Proof. +by move/reachD; rewrite !nodes_kfilt; case=>/andP [->->] /andP [->->]. +Qed. + +Lemma reachDN g x : + x \notin nodes g -> + reach g x = [::]. +Proof. by move/negP=>D; apply/eqnil=>y; apply/reachP; case. Qed. + +Lemma reachDN_kfilt g (p : pred node) x : + x \notin p -> + reach (kfilt g p) x = [::]. +Proof. +move/negP=>Px; apply/eqnil=>y; apply/reachP; case. +by rewrite nodes_kfilt; case/andP. +Qed. + +Lemma reach0 g x : (x \in reach g x) = (x \in nodes g). +Proof. by apply/reachP/idP; [case|split=>//; exists [::]]. Qed. + +Lemma reach0I g x : + x \in nodes g -> + x \in reach g x. +Proof. by rewrite reach0=>->. Qed. + +Lemma reach0N g x y : + x \in nodes g -> + y \notin reach g x -> + x != y. +Proof. by move=>Gx; apply: contra=>/eqP <-; rewrite reach0 Gx. Qed. + +Lemma reach_trans g : transitive (fun x y => y \in reach g x). +Proof. +move=>x y z /reachP [Dy][ys][Py Ey]. +case/reachP=>Dx [xs][Px Ex]; apply/reachP. +split=>//; exists (ys ++ xs); split. +- by rewrite cat_path -Ey Py Px. +by rewrite last_cat -Ey. +Qed. + +Lemma uniq_reach g x : uniq (reach g x). +Proof. exact: uniq_dfs. Qed. + +(* reach depends only on graph erasure, not on contents *) + +Lemma reach_erase g x : reach (erase g) x =i reach g x. +Proof. +move=>y; apply/reachP/reachP; rewrite nodes_erase; +case=>Dx [xs][Px Ey]; split=>//; exists xs. +- by rewrite -(eq_path (edge_erase g)). +by rewrite (eq_path (edge_erase g)). +Qed. + +(* reachby and union *) + +Lemma reachUn g1 g2 x : + [pcm g1 <= g2] -> + valid g2 -> + {subset reach g1 x <= reach g2 x}. +Proof. +case=>g -> W y /reachP [Dx][xs][Px Ey]. +apply/reachP; split=>//; first by rewrite domUn inE W Dx. +by exists xs; split=>//; apply: sub_path Px=>z w; apply: edgeUnL. +Qed. + +Lemma reachUnL g1 g2 x : + valid (g1 \+ g2) -> + {subset reach g1 x <= reach (g1 \+ g2) x}. +Proof. by apply: reachUn. Qed. + +Lemma reachUnR g1 g2 x : + valid (g1 \+ g2) -> + {subset reach g2 x <= reach (g1 \+ g2) x}. +Proof. by apply: reachUn. Qed. + +Lemma reachF g k x : + {subset reach (free g k) x <= reach g x}. +Proof. +case: (normalP g)=>[->|W]; first by rewrite free_undef. +by apply: reachUn (pleq_free _ _) W. +Qed. + +(* reach monotonicity *) + +Lemma reach_kfilt_sub g (p : pred node) x : + {subset reach (kfilt g p) x <= reach g x}. +Proof. +case: (normalP g)=>[->|W y H]; first by rewrite pfundef. +by rewrite (kfiltC g p) reachUnL // -kfiltC. +Qed. + +Lemma reach_kfilt_mono g (p1 p2 : pred node) x : + {subset p1 <= p2} -> + {subset reach (kfilt g p1) x <= reach (kfilt g p2) x}. +Proof. +case: (normalP g)=>[->|W S]; first by rewrite !pfundef. +rewrite (kfilt_predD g S); apply: reachUn=>//. +by rewrite valid_umfiltkUn // => z _ /= ->. +Qed. + +Lemma reach_kfilt_eq g (p1 p2 : pred node) x : + p1 =i p2 -> + reach (kfilt g p1) x =i reach (kfilt g p2) x. +Proof. +by move=>S y; apply/idP/idP; apply/reach_kfilt_mono=>z; rewrite S. +Qed. + +(* relativized versions of reach_mono and reach_eq *) + +Lemma reach_kfilt_in_mono g p1 p2 x : + {in nodes g, {subset p1 <= p2}} -> + {subset reach (kfilt g p1) x <= reach (kfilt g p2) x}. +Proof. +move=>S y; rewrite kfilt_nodesI=>R; rewrite kfilt_nodesI. +apply: reach_kfilt_mono R=>z; rewrite !inE. +by case Dz : (z \in nodes g)=>//=; apply: S Dz. +Qed. + +Lemma reach_kfilt_in_eq g p1 p2 x : + {in nodes g, p1 =i p2} -> + reach (kfilt g p1) x =i reach (kfilt g p2) x. +Proof. +by move=>S y; apply/idP/idP; apply: reach_kfilt_in_mono=>z Z; rewrite S. +Qed. + +(* reach equality for two different graphs *) +(* reaches are equal if erasures are equal *) + +Lemma eq_reach g1 g2 x : + nodes g1 =i nodes g2 -> + (forall x, adj g1 x = adj g2 x) -> + reach g1 x =i reach g2 x. +Proof. +case: (normalP g1)=>[->|V1]; case: (normalP g2)=>[->|V2] //. +- move=>En Ea z; rewrite reach_undef; apply/esym/reachP. + by case; rewrite -En dom_undef. +- move=>En Ea z; rewrite reach_undef; apply/reachP. + by case; rewrite En dom_undef. +by move=>En Ea z; rewrite -reach_erase (_ : erase g1 = erase g2) +?reach_erase // erase_eq. +Qed. + +(* some alternatives *) + +Lemma eq_reach2 g1 g2 x : + find^~ (erase g1) =1 find^~ (erase g2) -> + reach g1 x =i reach g2 x. +Proof. +move=>H; apply: eq_reach=>z; move: (H z); rewrite !find_erase /adj; +by case: (dom_find z g1); case: (dom_find z g2)=>//= ?????? [->]. +Qed. + +Lemma eq_reach3 g1 g2 x : + ssrfun.omap snd \o find^~ g1 =1 ssrfun.omap snd \o find^~ g2 -> + reach g1 x =i reach g2 x. +Proof. by move=>H; apply: eq_reach2=>z; rewrite find_erase_eq; apply: H. Qed. + +(* relativized versions *) + +Lemma eq_in_reach g1 g2 (p : pred node) x : + {in p, nodes g1 =i nodes g2} -> + {in p, adj g1 =1 adj g2} -> + reach (kfilt g1 p) x =i reach (kfilt g2 p) x. +Proof. +move=>En Ea; apply: eq_reach=>z. +- rewrite !nodes_kfilt -!(andbC (z \in p)). + by case Z: (z \in p)=>//=; rewrite En. +by rewrite !adj_kfilt; case: ifP=>// Z; rewrite Ea. +Qed. + +Lemma eq_in_reach2 g1 g2 (p : pred node) x : + {in p, find^~ (erase g1) =1 find^~ (erase g2)} -> + reach (kfilt g1 p) x =i reach (kfilt g2 p) x. +Proof. +move=>H; apply: eq_reach2=>z; rewrite !erase_kfilt !find_kfilt. +by case: ifP=>// /H. +Qed. + +Lemma eq_in_reach3 g1 g2 (p : pred node) x : + {in p, ssrfun.omap snd \o find^~ g1 =1 ssrfun.omap snd \o find^~ g2} -> + reach (kfilt g1 p) x =i reach (kfilt g2 p) x. +Proof. by move=>H; apply: eq_in_reach2=>z /H; rewrite find_erase_eq. Qed. + +End ReachStructurals. + +(********************************) +(* (de)constructing reach paths *) +(********************************) + +Section ReachPathSurgery. +Context {V : link} {A : Type}. +Implicit Type g : partial_graph V A. + +(* deconstructing connecting path from the beginning *) +Lemma edge_reachX g x y : + y != x -> + y \in reach g x -> + exists2 z, edge g x z & y \in reach (free g x) z. +Proof. +move=>Nxy; rewrite reachE (negbTE Nxy) /=. +by case: ifP=>// Dx /hasP [z Az H]; exists z. +Qed. + +(* weakened variant *) +Lemma edge_reach g x y : + y != x -> + y \in reach g x -> + exists2 z, edge g x z & y \in reach g z. +Proof. +by move=>Nxy /(edge_reachX Nxy) [z Eg H]; exists z=>//; apply/reachF/H. +Qed. + +(* deconstructing connecting path from the end *) +Lemma reach_edgeX g x y : + y != x -> + y \in reach g x -> + exists2 z, z \in reach (free g y) x & edge g z y. +Proof. +move/eqP=>Nxy /reachX [D][xs] /=. +case: {xs}(lastP xs)=>[|xs z][/[swap]]; first by move/Nxy. +rewrite last_rcons=><-; rewrite rcons_path=>/andP [Pxs Pz]. +rewrite rcons_uniq mem_rcons inE negb_or -andbA. +case/and4P=>N1 N2 N3 N4; exists (last x xs)=>//. +apply/reachP; split; first by rewrite domF (negbTE N1). +exists xs; split=>//. +have N : y \notin x :: xs by rewrite inE negb_or eq_sym N1 N3. +by rewrite -(eq_in_path (edge_free_eq g N)). +Qed. + +(* weakened variant *) +Lemma reach_edge g x y : + y != x -> + y \in reach g x -> + exists2 z, z \in reach g x & edge g z y. +Proof. +by move=>Nxy /(reach_edgeX Nxy) [z H Eg]; exists z=>//; apply/reachF/H. +Qed. + +(* extending connecting path from the beginning *) +Lemma edge_reachI g x y z : + edge g x y -> + z \in reach g y -> + z \in reach g x. +Proof. +move=>Eg /reachP [Dy][ys][Py Ez]; apply/reachP. +split=>//; first by rewrite (edgeD Eg). +by exists (y::ys); split=>//=; rewrite Eg Py. +Qed. + +(* extending connecting path from the end *) +Lemma reach_edgeI g x y z : + y \in reach g x -> + edge g y z -> + z \in reach g x. +Proof. +case/reachP=>Dx [xs][Px Ey] Eg; apply/reachP; split=>//. +by exists (rcons xs z); rewrite rcons_path last_rcons -Ey Px Eg. +Qed. + +(* if y reachable from x, then anything reachable from x *) +(* can be reached by y-free path, or is otherwise itself *) +(* reachable from y *) +Lemma reach_in {g x} y : + y \in reach g x -> + reach g x =i [predU reach (free g y) x & reach g y]. +Proof. +move=>Ry z; rewrite inE; apply/idP/idP; last first. +- by case/orP=>[/reachF|/(reach_trans Ry)]. +case/reachP=>Dx [xs][P E]. +have [Nx|Mx] := boolP (y \in x :: xs); last first. +(* if y isn't in the path, choose left *) +- move: (Mx); rewrite inE negb_or; case/andP=>Mx1 _. + apply/orP; left; apply/reachP; split. + - by rewrite domF eq_sym (negbTE Mx1). + by exists xs; rewrite -(eq_in_path (edge_free_eq g Mx)). +(* if y in the path, then z reachable from y; choose right *) +case/splitPl: Nx P E=>/= p1 p2 Ey. +rewrite cat_path last_cat {}Ey=>/andP [_ P] E. +apply/orP; right; apply/reachP. +by split; [rewrite (reachD Ry)|exists p2]. +Qed. + +(* if y not reachable from x, then removing y from g *) +(* doesn't change reachability from x *) +Lemma reach_notin {g x} y : + y \notin reach g x -> + reach g x =i reach (free g y) x. +Proof. +move=>Ry z; apply/idP/idP; last by apply: reachF. +case/reachP=>Dx [xs][P E]. +have [Nx|Mx] := boolP (y \in x :: xs); last first. +(* if y isn't in the path, trivial *) +- move: (Mx); rewrite inE negb_or; case/andP=>Mx1 _. + apply/reachP; split=>//; first by rewrite domF eq_sym (negbTE Mx1). + by exists xs; rewrite -(eq_in_path (edge_free_eq g Mx)). +(* otherwise suffices to show that y reachable from x to contradict Ry *) +suff : y \in reach g x by rewrite (negbTE Ry). +(* split the path at y *) +case/splitPl: Nx {E} P=>/= p1 p2 Ey. +rewrite cat_path; case/andP=>P _. +by apply/reachP; split=>//; exists p1. +Qed. + +(* putting the above two lemmas together *) +Lemma reach_mem {g x} y z : + (z \in reach g x) = + if y \in reach g x then + (z \in reach (free g y) x) || (z \in reach g y) + else z \in reach (free g y) x. +Proof. by case: ifPn=>Y; [apply: reach_in|apply: reach_notin]. Qed. + +(* if y is reachable from x, but not from x', then *) +(* y is reachable from x by a path that avoids whole *) +(* subcomponent of x' *) +Lemma reach_avoid g x x' y : + y \notin reach g x' -> + (y \in reach g x) = + (y \in reach (kfilt g [predC reach g x']) x). +Proof. +move=>Ny; apply/idP/idP; last by move/reach_kfilt_sub. +case/reachP=>Dx [xs][Px Ey]. +have [Nx|Mx] := boolP (has [in reach g x'] (x :: xs)); last first. +(* if path contains no nodes reachable from x', trivial *) +- move/hasPn: Mx=>/= Mx; apply/reachP; split. + - by rewrite nodes_kfilt !inE Dx Mx // inE eqxx. + exists xs; split=>//. + by apply/(sub_in_path edge_kfilt_in_sub)/Px/allP. +(* if path contains node z reachable from x' *) +(* (we pick last such z, but it doesn't matter) *) +case: {-1} _ _ _ / {Nx} (split_findlast Nx) (erefl (x::xs)). +move=>/= z p1 p2=>Rz _ X. +(* suffices to show that y is reachable from z *) +(* because then y is also reachable from x'; contradiction *) +suff Ry : y \in reach g z by rewrite (reach_trans Rz Ry) in Ny. +case: p1 X Ey Px=>[[<- _]|b p1 [_ ->]] /= Ey Px. +- by apply/reachP; split=>//; exists xs. +rewrite cat_path last_cat last_rcons rcons_path -andbA in Ey Px. +case/and3P: Px=>_ Ea Pz; apply/reachP; rewrite (reachD Rz). +by split=>//; exists p2. +Qed. + +Lemma reach_avoid1 {g x x'} y : + y \notin reach g x' -> + (y \in reach g x) = (y \in reach (free g x') x). +Proof. by move=>Y; rewrite (reach_mem x') (negbTE Y) orbF if_same. Qed. + +(* reachability out of x for the reachable subgraph *) +(* equals reachability out of x for the graph *) +Lemma reach_reach g x : + reach (kfilt g [in reach g x]) x =i reach g x. +Proof. +move=>y; apply/idP/idP; case/reachP. +- rewrite nodes_kfilt=>/andP [Dx Rx][xs][Px Ey]. + apply/reachP; split=>//; exists xs; split=>//. + by apply/sub_path/Px=>a b; rewrite edge_kfilt; case/and3P. +move=>Dx [xs][Px Ey]; apply/reachP; split. +- by rewrite nodes_kfilt reach0 Dx. +exists xs; split=>//; apply/(sub_in_path edge_kfilt_in_sub)/Px. +apply/allP=>z; rewrite inE; case/orP=>[/eqP ->|Hz]. +- by rewrite reach0. +case/splitPr: Hz Px=>xs1 xs2. +rewrite -cat1s catA cats1 cat_path=>/andP [Px _]. +by apply/reachP; split=>//; exists (rcons xs1 z); rewrite last_rcons. +Qed. + +Lemma nodes_reach g x : + nodes (kfilt g [in reach g x]) =i reach g x. +Proof. +move=>z; rewrite nodes_kfilt; case D: (z \in _)=>//=. +by apply/esym/negP=>/reachD2; rewrite D. +Qed. + +Lemma path_reach_sub g x xs : + path (edge g) x xs -> + {subset xs <= reach g x}. +Proof. +case: xs=>[|y xs] // /[dup]/path_nodes0 D + z Z; case/splitPr: Z=>p q. +rewrite cat_path /=; case/and3P=>E1 E2 _; apply/reachP; split=>//. +by exists (rcons p z); rewrite rcons_path last_rcons E1 E2. +Qed. + +End ReachPathSurgery. + +(******************) +(* Bireachability *) +(******************) + +(* y is bireachable from x iff *) +(* x and y are mutually reachable *) +(* (symmetric closure of reach) *) +(* Thus, x-y-x is a loop (also y-x-y) *) + +Definition bireach {V : link} A (g : partial_graph V A) x : seq node := + filter (fun y => x \in reach g y) (reach g x). + +Section BireachLemmas. +Context {V : link} {A : Type}. +Implicit Type g : partial_graph V A. + +Lemma bireach_sym g x y : + (x \in bireach g y) = (y \in bireach g x). +Proof. by rewrite !mem_filter andbC. Qed. + +Lemma bireach_symE g x y : + x \in bireach g y -> y \in bireach g x. +Proof. by rewrite bireach_sym. Qed. + +Lemma bireach0 g x : + (x \in bireach g x) = (x \in nodes g). +Proof. by rewrite mem_filter reach0 andbb. Qed. + +Lemma bireach0I g x : + x \in nodes g -> + x \in bireach g x. +Proof. by rewrite bireach0. Qed. + +Lemma bireach0N g x y : + x \in nodes g -> + y \notin bireach g x -> + x != y. +Proof. by move=>Gx; apply: contra=>/eqP <-; rewrite bireach0 Gx. Qed. + +Lemma bireach_trans g : transitive (fun x y => y \in bireach g x). +Proof. +move=>x y z; rewrite !mem_filter. +case/andP=>Hyx Hxy /andP [Hxz Hzx]. +by rewrite (reach_trans Hxz Hyx) (reach_trans Hxy Hzx). +Qed. + +Lemma bireachUn g1 g2 x : + [pcm g1 <= g2] -> + valid g2 -> + {subset bireach g1 x <= bireach g2 x}. +Proof. +move=>H W y; rewrite !mem_filter; case/andP=>[Rx Ry]. +by apply/andP; split; apply: (reachUn H). +Qed. + +Lemma bireachUnL g1 g2 x : + valid (g1 \+ g2) -> + {subset bireach g1 x <= bireach (g1 \+ g2) x}. +Proof. by apply: bireachUn. Qed. + +Lemma bireachUnR g1 g2 x : + valid (g1 \+ g2) -> + {subset bireach g2 x <= bireach (g1 \+ g2) x}. +Proof. by apply: bireachUn. Qed. + +Lemma bireach_kfilt_mono g (p1 p2 : pred node) (x : node) : + {subset p1 <= p2} -> + {subset bireach (kfilt g p1) x <= bireach (kfilt g p2) x}. +Proof. +move=>S y; rewrite !mem_filter; case/andP. +by do 2![move/(reach_kfilt_mono S)=>->]. +Qed. + +Lemma bireach_kfilt_eq g (p1 p2 : pred node) (x : node) : + p1 =i p2 -> + bireach (kfilt g p1) x =i bireach (kfilt g p2) x. +Proof. by move=>S y; rewrite !mem_filter !(reach_kfilt_eq g _ S). Qed. + +End BireachLemmas. + +(*********) +(* Cycle *) +(*********) + +Section CycleLemmas. +Context {V : link} {A : Type}. +Implicit Type g : partial_graph V A. + +(* elements in a cycle are mutually reachable *) +(* using cycle elements only *) +Lemma reach_cycle_kfilt g xs : + cycle (edge g) xs -> + {in xs &, forall x y, y \in reach (kfilt g [in xs]) x}. +Proof. +move=>C x y /rot_to [i q Hr]; rewrite -(mem_rot i) Hr => Hy. +have Hx : x \in xs by rewrite -(mem_rot i) Hr inE eqxx. +have /= Hp1: cycle (edge g) (x :: q) by rewrite -Hr rot_cycle. +have Dx : x \in dom g. +- by move: Hp1; rewrite rcons_path=>/andP [_ /edgeD][]. +case/splitPl: Hy Hp1 Hr=>r s Ey. +rewrite rcons_cat cat_path=>/andP [Hxr]. +rewrite Ey rcons_path; case/andP=>Hlx /= Ex Hr. +apply/reachP; split=>//; first by rewrite nodes_kfilt Dx Hx. +exists r; split=>//; apply/(sub_in_path edge_kfilt_in_sub)/Hxr. +by apply/allP=>z; rewrite -(mem_rot i xs) Hr !inE mem_cat orbA=>->. +Qed. + +(* weakened form *) +Lemma reach_cycle g xs : + cycle (edge g) xs -> + {in xs &, forall x y, y \in reach g x}. +Proof. by move=>C x y Hx /(reach_cycle_kfilt C Hx)/reach_kfilt_sub. Qed. + +(* elements in a cycle are mutually bi-reachable *) +(* using cycle elements only *) +Lemma bireach_cycle_kfilt g xs : + cycle (edge g) xs -> + {in xs &, forall x y, y \in bireach (kfilt g [in xs]) x}. +Proof. by move=>C x y Hx Hy; rewrite mem_filter !(reach_cycle_kfilt C). Qed. + +(* weakened form *) +Lemma bireach_cycle g xs : + cycle (edge g) xs -> + {in xs &, forall x y, y \in bireach g x}. +Proof. by move=>C x y Hx Hy; rewrite mem_filter !(reach_cycle C). Qed. + +(* characterization of bireach in terms of cycles *) +Lemma bireach_cycleP g x y : + x != y -> + reflect (exists2 xs, y \in xs & cycle (edge g) (x :: xs)) + (y \in bireach g x). +Proof. +move=>Nxy; apply/(iffP idP)=>[|[ys Py Cy]]; last first. +- by apply: (bireach_cycle Cy); rewrite inE ?eqxx ?Py ?orbT. +rewrite mem_filter=>/andP [] /reachP [Dy][ys][Py Ex]. +elim/last_ind: ys x Py Ex Nxy=>[x _ ->|ys x IH] /=; first by rewrite eqxx. +rewrite rcons_path last_rcons=>_ /andP [Py Ex] -> Nxy. +case/reachP=>Dx [xs][Px Ey]; exists (xs ++ ys). +- have := mem_last x xs. + by rewrite -Ey inE eq_sym (negbTE Nxy) /= mem_cat=>->. +by rewrite rcons_path cat_path last_cat -Ey Px Py Ex. +Qed. + +Lemma bireach_kfilt_cycleP p g x y : + x != y -> + reflect (exists xs, + [/\ y \in xs, cycle (edge g) (x :: xs) & + {subset x :: xs <= p}]) + (y \in bireach (kfilt g p) x). +Proof. +move=>Nxy; apply/(iffP (bireach_cycleP _ Nxy))=>/=. +- case=>xs Dy Px; exists xs; split=>//. + - by apply/sub_path/Px/edge_kfilt_sub. + move=>z Z; have : z \in rcons xs x by rewrite mem_rcons. + by move/(path_nodes Px); rewrite nodes_kfilt; case/andP. +case=>xs [Dy Px S]; exists xs=>//. +apply/(sub_in_path edge_kfilt_in_sub)/Px/allP=>z. +by rewrite inE mem_rcons inE orbA orbb -inE=>/S. +Qed. + +Lemma cycle_nodes g xs : + cycle (edge g) xs -> + {subset xs <= nodes g}. +Proof. by rewrite (cycle_path null)=>/path_nodes. Qed. + +Lemma cycle_edge_free g x ys : + x \notin ys -> + cycle (edge g) ys -> + cycle (edge (free g x)) ys. +Proof. +case: ys=>//= y ys /[dup] N; rewrite inE negb_or=>/andP [Nxy Nys]. +rewrite !rcons_path edgeFE Nxy andbT=>/andP [P ->] /=. +by rewrite path_edge_free //=; case: eqP (mem_last y ys) N=>//= <- ->. +Qed. + +(* useful renaming *) +Lemma edge_free_cycle g x : + subpred (cycle (edge (free g x))) (cycle (edge g)). +Proof. exact: (sub_cycle free_edge_sub). Qed. + +Lemma loops_cycleE g x : (x \in loops g) = cycle (edge g) [:: x]. +Proof. by rewrite /= loopsE edge_adj andbT. Qed. + +End CycleLemmas. + +(**************) +(* Acyclicity *) +(**************) + +(* graph is preacyclic iff *) +(* the only biconnected paths (i.e., loops) are self-loops *) +Definition preacyclic {V : link} A (g : partial_graph V A) := + all2rel (fun x y => (y \in bireach g x) ==> (x == y)) (nodes g). + +(* graph is acyclic if it doesn't even have self-loops *) +(* (thus, it has no loops of any sort, but this will be proved) *) +Definition acyclic {V : link} A (g : partial_graph V A) := + preacyclic g && all (fun x => ~~ edge g x x) (nodes g). + +Section AcyclicityLemmas. +Context {V : link} {A : Type}. +Implicit Type g : partial_graph V A. + +Lemma preacyclicP g : + reflect {in nodes g &, + forall x y, y \in bireach g x -> x = y} + (preacyclic g). +Proof. +apply: (iffP idP)=>[|H]. +- by move/allrelP=>H x y Dx Dy C; apply/eqP/(implyP _ C)/H. +by apply/allrelP=>x y Dx Dy; apply/implyP=>K; apply/eqP/H. +Qed. + +Lemma preacyclic_undef : preacyclic (undef : partial_graph V A). +Proof. by apply/preacyclicP=>x y; rewrite dom_undef. Qed. + +Lemma preacyclic_unit : preacyclic (Unit : partial_graph V A). +Proof. by apply/preacyclicP=>x y; rewrite dom0. Qed. + +Lemma preacyclicUnSub g1 g2 : + [pcm g1 <= g2] -> + valid g2 -> + preacyclic g2 -> + preacyclic g1. +Proof. +case=>g -> W /preacyclicP/= H; apply/preacyclicP. +move=>x y Dx Dy C; apply/H/bireachUnL/C=>//; +by rewrite domUn inE W ?Dx ?Dy. +Qed. + +Lemma preacyclicUnL g1 g2 : + valid (g1 \+ g2) -> + preacyclic (g1 \+ g2) -> + preacyclic g1. +Proof. by apply: preacyclicUnSub. Qed. + +Lemma preacyclicUnR g1 g2 : + valid (g1 \+ g2) -> + preacyclic (g1 \+ g2) -> + preacyclic g2. +Proof. by apply: preacyclicUnSub. Qed. + +Lemma acyclicUn g1 g2 : + [pcm g1 <= g2] -> + valid g2 -> + acyclic g2 -> + acyclic g1. +Proof. +case=>g -> W /andP [Hp /allP /= Ha]. +apply/andP; split; first by apply: preacyclicUnL Hp. +apply/allP=>x Dx; apply: contra (edgeUnL W) (Ha x _). +by rewrite domUn inE W Dx. +Qed. + +Lemma acyclicUnL g1 g2 : + valid (g1 \+ g2) -> + acyclic (g1 \+ g2) -> + acyclic g1. +Proof. by apply: acyclicUn. Qed. + +Lemma acyclicUnR g1 g2 : + valid (g1 \+ g2) -> + acyclic (g1 \+ g2) -> + acyclic g2. +Proof. by apply: acyclicUn. Qed. + +(* graph is acyclic iff has no cycles *) + +Lemma acyclic_cycleP g : + reflect (forall x xs, x \in nodes g -> + ~~ cycle (edge g) (x :: xs)) + (acyclic g). +Proof. +apply: (iffP idP)=>[|H]; last first. +- apply/andP; split; last first. + - by apply/allP=>x Dx; apply: contra (H _ [::] Dx); rewrite /= =>->. + apply/preacyclicP=>x y Dx Dy By; apply/eqP/(contraLR _ By)=>{By} Nxy. + by apply/(bireach_cycleP _ Nxy); case=>/= xs Hx; apply/negP/H/Dx. +case/andP=>/preacyclicP Ng /allP Ne x xs Dx /=. +rewrite rcons_path; apply/negP=>/andP []. +case: xs=>[_|y xs /= /andP [Exy Px]]; first by apply/negP/Ne. +have Dy : y \in nodes g by rewrite (edgeD Exy). +have : y \notin bireach g x. +- by apply: contraL Exy=>/(Ng x y Dx Dy) <-; apply: Ne Dx. +apply: contraNnot=>Ex; apply: (bireach_cycle (xs:=x::y::xs))=>/=. +- by rewrite Exy rcons_path Px Ex. +- by rewrite inE eqxx. +by rewrite !inE eqxx orbT. +Qed. + +Lemma acyclic_adj g x : + acyclic g -> + x \notin adj g x. +Proof. +case/andP=>_ /allP H. +have [Dx|Nx] := boolP (x \in nodes g); last by rewrite adjND. +by apply: contra (H _ Dx)=>Lx; rewrite edge_adj Dx Lx. +Qed. + +Lemma acyclic_children g x : + acyclic g -> + x \notin children g x. +Proof. by move/(acyclic_adj x); apply/contra/children_adj. Qed. + +End AcyclicityLemmas. + +(**********) +(* Cycles *) +(**********) + +(* x is a cycle if x is reachable from x *) +(* by a path of size at least 1; *) +(* alternatively, if x is reachable from some successor of x *) + +Definition cycles {V : link} {A} (g : partial_graph V A) : seq node := + nodes (kfilt g (fun x => x \in flatten (map (reach g) (adj g x)))). + +Section CyclesLemmas. +Context {V : link} {A : Type}. +Implicit Type g : partial_graph V A. + +Lemma cycles_undef : cycles (undef : partial_graph V A) = [::]. +Proof. by rewrite /cycles pfundef dom_undef. Qed. + +Lemma cycles0 : cycles (Unit : partial_graph V A) = [::]. +Proof. by rewrite /cycles pfunit dom0. Qed. + +Lemma cyclesD {g} : {subset cycles g <= nodes g}. +Proof. by move=>x; rewrite nodes_kfilt=>/andP []. Qed. + +Lemma cyclesE g x : + (x \in cycles g) = + (x \in nodes g) && (x \in flatten (map (reach g) (adj g x))). +Proof. exact: nodes_kfilt. Qed. + +(* characteristic properties of cycles *) +(* these are overlapping; use as varants by context *) + +Lemma cyclesP g (x : node) : + reflect (exists2 y : node, y \in adj g x & x \in reach g y) + (x \in cycles g). +Proof. +rewrite cyclesE; apply/(iffP idP)=>[|[y Ay Rx]]. +- by case/andP=>Dx /flatten_mapP [y Ay Ry]; exists y. +by rewrite (reachD Rx); apply/flatten_mapP; exists y. +Qed. + +Lemma cyclesPD g (x : node) : + reflect (x \in nodes g /\ + exists2 y, y \in adj g x & x \in reach g y) + (x \in cycles g). +Proof. by apply: (iffP idP)=>[/[dup]/cyclesD ->|[_]]/cyclesP. Qed. + +Lemma cyclesPC g (x : node) : + reflect (exists xs, cycle (edge g) (x :: xs)) + (x \in cycles g). +Proof. +apply/(iffP (cyclesP _ _))=>/=. +- case=>y Ay /reachP [Dy][xs][P H]; exists (belast y xs). + by rewrite H -lastI /= -H edge_adj Ay Dy P. +case; case=>[|y ys] /=. +- by rewrite edge_adj andbT=>/andP [Dx Ax]; exists x=>//; rewrite reach0. +rewrite rcons_path edge_adj -andbA=>/and4P [Dy Ay P X]. +exists y=>//; apply/reachP; split=>//; exists (rcons ys x). +by rewrite rcons_path last_rcons P X. +Qed. + +Lemma cyclesPCI g x xs : + cycle (edge g) (x :: xs) -> + x \in cycles g. +Proof. by move=>C; apply/cyclesPC; exists xs. Qed. + +Lemma cyclesPCU g (x : node) : + reflect (exists2 xs, cycle (edge g) (x :: xs) & uniq (x :: xs)) + (x \in cycles g). +Proof. +apply/(iffP (cyclesPC _ _))=>-[xs] /=; last by exists xs. +rewrite rcons_path=>/andP [/shortenP [xs' P U S] E]. +by exists xs'=>//; rewrite rcons_path P E. +Qed. + +(* this one seems most useful, so given short name *) +Lemma cyclesX g (x : node) : + reflect (exists2 xs, cycle (edge g) xs & x \in xs) + (x \in cycles g). +Proof. +apply/(iffP (cyclesPC _ _))=>-[xs]. +- by exists (x :: xs)=>//; rewrite inE eqxx. +by move/[swap]=>X /(cycle_head_uniq X) [ys][]; exists ys. +Qed. + +Lemma cyclesXI g (x : node) xs : + x \in xs -> + cycle (edge g) xs -> + x \in cycles g. +Proof. by move=>X C; apply/cyclesX; exists xs. Qed. + +Lemma cyclesXU g (x : node) : + reflect (exists xs, [/\ cycle (edge g) xs, x \in xs & uniq xs]) + (x \in cycles g). +Proof. +apply/(iffP idP)=>[/cyclesPCU|][xs]. +- by exists (x :: xs); rewrite inE eqxx. +by case=>*; apply/cyclesX; exists xs. +Qed. + +(* subset properties of cycles *) + +Lemma cycle_cycles_sub {g xs} : + cycle (edge g) xs -> + {subset xs <= cycles g}. +Proof. by move=>C x /cyclesXI/(_ C). Qed. + +Lemma cyclesUn {g1 g2} : + [pcm g1 <= g2] -> + valid g2 -> + {subset cycles g1 <= cycles g2}. +Proof. +case=>g -> W x /cyclesPD [Dx][y Ay Ry]; apply/cyclesP. +by exists y; rewrite ?adjUnL ?Dx ?reachUnL ?ifT. +Qed. + +Lemma cyclesUnL {g1 g2} : + valid (g1 \+ g2) -> + {subset cycles g1 <= cycles (g1 \+ g2)}. +Proof. by apply: cyclesUn. Qed. + +Lemma cyclesUnR {g1 g2} : + valid (g1 \+ g2) -> + {subset cycles g2 <= cycles (g1 \+ g2)}. +Proof. by apply: cyclesUn. Qed. + +Lemma cyclesF {g} {x : node} : + {subset cycles (free g x) <= cycles g}. +Proof. +case: (normalP g)=>[->|W]; first by rewrite free_undef. +by apply: cyclesUn (pleq_free _ _) _. +Qed. + +Lemma cyclesNF {g} {x : node} : + x \notin cycles g -> + {subset cycles g <= cycles (free g x)}. +Proof. +move=>Nx y /cyclesX [xs C Y]; apply/cyclesX; exists xs=>//. +by apply/cycle_edge_free/C/(contra _ Nx)/cycle_cycles_sub. +Qed. + +(* cycles monotonicity *) + +Lemma cycles_kfilt_sub {g} p : + {subset cycles (kfilt g p) <= cycles g}. +Proof. +case: (normalP g)=>[->|W y H]; first by rewrite pfundef. +by rewrite (kfiltC g p) cyclesUnL // -kfiltC. +Qed. + +Lemma cycles_kfilt_mono {g} (p1 p2 : pred node) : + {subset p1 <= p2} -> + {subset cycles (kfilt g p1) <= cycles (kfilt g p2)}. +Proof. +case: (normalP g)=>[->|W S]; first by rewrite !pfundef. +rewrite (kfilt_predD g S); apply: cyclesUn=>//. +by rewrite valid_umfiltkUn // => z _ /= ->. +Qed. + +Lemma cycles_kfilt_eq g (p1 p2 : pred node) : + p1 =i p2 -> + cycles (kfilt g p1) =i cycles (kfilt g p2). +Proof. +by move=>S y; apply/idP/idP; apply/cycles_kfilt_mono=>z; rewrite S. +Qed. + +(* cycles and loops *) + +Lemma loops_cycles_sub {g} : {subset loops g <= cycles g}. +Proof. +move=>x; rewrite loopsE=>/andP [Dx Ax]; apply/cyclesP. +by exists x=>//; rewrite reach0. +Qed. + +(* the other direction holds in special case of preacylic graphs *) +Lemma preacyclic_sub {g} : + preacyclic g -> + {subset cycles g <= loops g}. +Proof. +move/preacyclicP=>/= H x /cyclesPCU [[|y xs]] // /[dup] C /=. +- by rewrite loops_cycleE. +rewrite edge_adj -andbA=>/and3P [Dy Ay _]. +by rewrite (H x y) ?(cycle_nodes C,bireach_cycle C,inE,eqxx,orbT). +Qed. + +Lemma cycles_loops_sub {g1 g2} : + [pcm g1 <= g2] -> + valid g2 -> + {subset cycles g2 <= loops g2} -> + {subset cycles g1 <= loops g1}. +Proof. +case=>g -> W H x /[dup]/(cyclesUnL W)/H; rewrite loopsUn //. +by case/orP=>// /(allP (disj_loopsR W)) /[swap]/cyclesD ->. +Qed. + +Lemma cycles_loops_subL {g1 g2} : + valid (g1 \+ g2) -> + {subset cycles (g1 \+ g2) <= loops (g1 \+ g2)} -> + {subset cycles g1 <= loops g1}. +Proof. by apply: cycles_loops_sub. Qed. + +Lemma cycles_loops_subR {g1 g2} : + valid (g1 \+ g2) -> + {subset cycles (g1 \+ g2) <= loops (g1 \+ g2)} -> + {subset cycles g2 <= loops g2}. +Proof. by apply: cycles_loops_sub. Qed. + +Lemma bireach_cycles {g x y} : + x != y -> + y \in bireach g x -> + y \in cycles g. +Proof. +move=>Nxy /(bireach_cycleP _ Nxy) [xs Y C]. +by apply/cyclesXI/C; rewrite inE Y orbT. +Qed. + +End CyclesLemmas. + + +(**********) +(* Closed *) +(**********) + +(* predicate testing that no edges are dangling *) + +Definition closed {V : link} {A} (g : partial_graph V A) := + all [mem nodes0 g] (sinks g). + +Section Closed. +Context {V : link} {A : Type}. +Implicit Type g : partial_graph V A. + +Lemma closedP g : reflect {subset sinks g <= nodes0 g} (closed g). +Proof. exact: allP. Qed. + +Lemma closed_undef : closed (undef : partial_graph V A). +Proof. by []. Qed. + +Lemma closed_unit : closed (Unit : partial_graph V A). +Proof. by []. Qed. + +Lemma closed_erase g : closed (erase g) = closed g. +Proof. by rewrite /closed sinks_erase nodes_erase. Qed. + +End Closed. + +Section ClosedLemmas. +Context {V : link} {A : Type}. +Implicit Type g : partial_graph V A. + +Lemma In_closed x v a g : + (x, (v, a)) \In g -> + reflect ({subset links a <= nodes0 g} /\ + {subset sinks (free g x) <= nodes0 g}) + (closed g). +Proof. +move=>H; move: (In_eta H) (In_valid H)=>E W; rewrite E in W. +case: closedP=>X; constructor. +- by split=>/= z Z; move: (X z); rewrite {1}E sinksPtUn + ?(validX W) //= mem_cat Z ?orbT; apply. +case=>H1 H2; apply: X=>z. +rewrite {1}E sinksPtUn ?(validX W) //= mem_cat. +by case/orP=>[/H1|/H2]. +Qed. + +Lemma closed_links x v a g : + (x, (v, a)) \In g -> + closed g -> + {subset links a <= nodes0 g}. +Proof. by move=>H /(In_closed H) []. Qed. + +Lemma closed_sinks x g : + x \in nodes g -> + closed g -> + {subset sinks (free g x) <= nodes0 g}. +Proof. by case/In_domX=>-[a v] H /(In_closed H) []. Qed. + +Lemma In_closedPtUn x v a g : + x \in nodes g -> + closed g -> + reflect {subset links a <= nodes0 g} + (closed (pts x (v, a) \+ free g x)). +Proof. +move=>D C; case X: (closed _); constructor; case/In_domX: D=>-[v' a'] H; +move: (In_eta H) (In_valid H)=>E W; rewrite E in W; +have K : (x, (v, a)) \In pts x (v, a) \+ free g x + by apply/InPtUnL/(validX W). +- rewrite E -(domPtUnE2 x (v, a)); apply: closed_links K X. +move/negP: X=>X Y; apply: X; apply/(In_closed K); +rewrite -(domPtUnE2 x (v', a')) -E freePtUn ?(validX W) //. +by split=>//; apply: closed_sinks (In_dom H) C. +Qed. + +Lemma closedUn g1 g2 : + closed g1 -> + closed g2 -> + closed (g1 \+ g2). +Proof. +case: (normalP (g1 \+ g2))=>[->|W]; first by rewrite closed_undef. +move/closedP=>S1 /closedP S2; apply/closedP=>/= x. +rewrite sinksUnE // inE domUnE //= => /orP [/S1|/S2]; +by rewrite inE; case/orP=>-> //; rewrite !orbT. +Qed. + +Lemma closed_ext g1 g2 : + closed g1 -> + disjoint (sinks g1) (filter [predC nodes g1] (nodes g2)). +Proof. +move/closedP=>S; apply/disj_filt_subL=>x /S; rewrite !inE negb_and negbK. +by case/orP=>[/eqP|] -> //; rewrite !mem_dom0. +Qed. + +(* if g1 is closed, there's no edges crossing into g2 *) +Lemma closed_edgeE g1 g2 x y : + valid (g1 \+ g2) -> + closed g1 -> + x \in nodes g1 -> + edge (g1 \+ g2) x y = edge g1 x y. +Proof. +move=>W /closedP S Dx; rewrite !edge_adj adjUnL // Dx domUnE //. +apply/andb_id2r=>/adj_sinks_sub/S; rewrite inE orbC. +by case: (y \in nodes g1)=>//= /eqP ->; rewrite cond_dom. +Qed. + +Lemma closed_edge g1 g2 x y : + closed g1 -> + x \in nodes g1 -> + y \in nodes g2 -> + ~ (edge (g1 \+ g2) x y). +Proof. +case: (normalP (g1 \+ g2))=>[->|W C]; first by rewrite edge_undef. +by move/(closed_edgeE _ W C)=>-> Dy /edgeD [_] /(dom_inNLX W). +Qed. + +Lemma closed_pathL g1 g2 x xs : + closed g1 -> + x \in nodes g1 -> + path (edge (g1 \+ g2)) x xs -> + path (edge g1) x xs. +Proof. +case: (normalP (g1 \+ g2))=>[->|W]; first by case: xs. +elim: xs x=>[|y xs IH] //= x C Dx /andP []. +by rewrite closed_edgeE // => E P; rewrite E /= IH // (edgeD E). +Qed. + +Lemma closed_pathR g1 g2 x xs : + closed g2 -> + x \in nodes g2 -> + path (edge (g1 \+ g2)) x xs -> + path (edge g2) x xs. +Proof. by rewrite joinC; apply: closed_pathL. Qed. + +Lemma reach_closedUn g1 g2 x : + [pcm g1 <= g2] -> + closed g1 -> + x \in nodes g1 -> + {subset reach g2 x <= reach g1 x}. +Proof. +case=>g ->; case: (normalP (g1 \+ g))=>[->|W] C D y. +- by rewrite reach_undef. +case/reachP=>_ [xs][P L]; apply/reachP; split=>//=. +by exists xs; split=>//; apply: closed_pathL P. +Qed. + +Lemma reach_closedL g1 g2 x : + closed g1 -> + x \in nodes g1 -> + {subset reach (g1 \+ g2) x <= reach g1 x}. +Proof. by apply: reach_closedUn. Qed. + +Lemma reach_closedR g1 g2 x : + closed g2 -> + x \in nodes g2 -> + {subset reach (g1 \+ g2) x <= reach g2 x}. +Proof. by apply: reach_closedUn. Qed. + +Lemma bireach_closedL g1 g2 x y : + closed g1 -> + x \in nodes g1 -> + y \in nodes g1 -> + x \in bireach (g1 \+ g2) y -> + x \in bireach g1 y. +Proof. +case: (normalP (g1 \+ g2))=>[->|W C Dx Dy]. +- by rewrite /bireach mem_filter reach_undef. +by rewrite !mem_filter=>/andP [/(reach_closedL C Dx)] -> /(reach_closedL C Dy). +Qed. + +Lemma bireach_closedR g1 g2 x y : + closed g2 -> + x \in nodes g2 -> + y \in nodes g2 -> + x \in bireach (g1 \+ g2) y -> + x \in bireach g2 y. +Proof. by rewrite joinC; apply: bireach_closedL. Qed. + +Lemma closed_preacyclicUn g1 g2 : + closed g1 -> + closed g2 -> + preacyclic g1 -> + preacyclic g2 -> + preacyclic (g1 \+ g2). +Proof. +case: (normalP (g1 \+ g2))=>[->|W C1 C2]. +- by rewrite preacyclic_undef. +move/preacyclicP=>P1 /preacyclicP P2; apply/preacyclicP=>x y. +rewrite !domUnE //; case/orP=>Dx /orP [] Dy. +- by move/(bireach_closedL C1 Dy Dx)/(P1 _ _ Dx Dy). +- rewrite mem_filter=>/andP [_] /(reach_closedL C1 Dx). + by case/reachD=>_ /(dom_inNRX W Dy). +- rewrite mem_filter=>/andP [/(reach_closedL C1 Dy)]. + by case/reachD=>_ /(dom_inNRX W Dx). +by move/(bireach_closedR C2 Dy Dx)/(P2 _ _ Dx Dy). +Qed. + +Lemma closed_freeN g x : + closed g -> + x \notin sinks (free g x) -> + closed (free g x). +Proof. +move/closedP=>C NSx; apply/closedP=>y. +case: (y =P x)=>[->|/eqP N /sinks_free_sub/C]; first by rewrite (negbTE NSx). +by rewrite !inE domF N. +Qed. + +End ClosedLemmas. + +Arguments In_closedPtUn {V A x v a g}. + +(* reach and closed *) + +Section ReachClosed. +Context {V : link} {A : Type}. +Implicit Type g : partial_graph V A. + +Lemma closed_reach g x : + closed g -> + closed (kfilt g [in reach g x]). +Proof. +move/closedP=>H; apply/closedP=>y /sinksPA [z]. +rewrite inE nodes_kfilt adj_kfilt; case: ifP=>// Rz Ay. +have /H : y \in sinks g by apply/sinksPA; exists z. +rewrite inE; case/orP=>[->//|Dy]; rewrite Dy /=. +by rewrite (reach_edgeI Rz) ?orbT // edge_adj Dy Ay. +Qed. + +Lemma closed_reachUn g1 g2 x : + closed (g1 \+ g2) -> + nodes g1 =i reach (g1 \+ g2) x -> + closed g1. +Proof. +case: (normalP (g1 \+ g2))=>[-> _|W C N]. +- rewrite reach_undef=>N. + by apply/closedP=>y /sinksP [z]; rewrite N. +have E : g1 = kfilt (g1 \+ g2) [in reach (g1 \+ g2) x]. +- by rewrite -(kfilt_eq _ N) kfiltUn_nodes. +by rewrite E closed_reach. +Qed. + +(* the next two lemmas aren't about closed *) +(* but are always used together with closed_reachUn *) + +Lemma nodes_reachUn g1 g2 x : + nodes g1 =i reach (g1 \+ g2) x -> + nodes g1 =i reach g1 x. +Proof. +case: (normalP (g1 \+ g2))=>[->|W N]. +- rewrite reach_undef=>N y. + by apply/idP/reachP=>[|[]]; rewrite N. +have E : g1 = kfilt (g1 \+ g2) [in reach (g1 \+ g2) x]. +- by rewrite -(kfilt_eq _ N) kfiltUn_nodes. +by move=>y; rewrite {2}E reach_reach -N. +Qed. + +Lemma nodes_reachUnL g1 g2 x : + nodes g1 =i reach (g1 \+ g2) x -> + x \in nodes (g1 \+ g2) -> + x \in nodes g1. +Proof. by move=>N Dx; rewrite N reach0. Qed. + +(* common usage *) +Lemma closed_reachUnX g1 g2 x : + closed (g1 \+ g2) -> + x \in nodes (g1 \+ g2) -> + nodes g1 =i reach (g1 \+ g2) x -> + [/\ closed g1, x \in nodes g1 & + nodes g1 =i reach g1 x]. +Proof. +move=>C Dx N; split. +- by apply: closed_reachUn C N. +- by apply: nodes_reachUnL N Dx. +by apply: nodes_reachUn N. +Qed. + +End ReachClosed. + +(**********************) +(* Dangls and dangls0 *) +(**********************) + +(* sinks of dangling edges in g *) +(* two different variants : *) +(* dangls = sings g \ nodes0 g explicitly excludes null *) +(* dangls0 = sinks g \ nodes g may include null if sinks includes null *) + +Definition dangls {V : link} A (g : partial_graph V A) := + filter [predC nodes0 g] (sinks g). + +Definition dangls0 {V : link} {A} (g : partial_graph V A) := + filter [predC nodes g] (sinks g). + +Section DanglsLemmas. +Context {V : link} {A : Type}. +Implicit Types g : partial_graph V A. + +Lemma dangls0E g : dangls g = filter (predC1 null) (dangls0 g). +Proof. by rewrite -filter_predI; apply: eq_filter=>x; rewrite inE negb_or. Qed. + +Lemma dangls_mem g x : + (x \in dangls g) = (x \notin nodes0 g) && (x \in sinks g). +Proof. by rewrite mem_filter. Qed. + +Lemma dangls0_mem g x : + (x \in dangls0 g) = (x \notin nodes g) && (x \in sinks g). +Proof. by rewrite mem_filter. Qed. + +Lemma dangls_dangls0_sub {g} : {subset dangls g <= dangls0 g}. +Proof. by move=>x; rewrite !mem_filter /= inE negb_or -andbA=>/andP []. Qed. + +Lemma dangls0_nodesD {g} : disjoint (dangls0 g) (nodes g). +Proof. by apply/allP=>x D; rewrite mem_filter /= D. Qed. + +Lemma dangls_nodes0D {g} : disjoint (dangls g) (nodes0 g). +Proof. by apply/allP=>x D; rewrite mem_filter /= D. Qed. + +Lemma dangls0_loops_disj {g} : disjoint (dangls0 g) (loops g). +Proof. by apply/disjoint_subL/dangls0_nodesD/omf_subdom. Qed. + +Lemma danglsUn g1 g2 x : + valid (g1 \+ g2) -> + (x \in dangls (g1 \+ g2)) = + (x \in filter [predC nodes g2] (dangls g1)) || + (x \in filter [predC nodes g1] (dangls g2)). +Proof. +move=>W; rewrite /dangls -!filter_predI !mem_filter /=. +rewrite [in RHS]inE negb_or andbCA andbA -negb_or (andbC (x \notin nodes0 g2)). +by rewrite -andb_orr -negb_or -sinksUnE // -nodesUn0R. +Qed. + +Lemma dangls0Un g1 g2 x : + valid (g1 \+ g2) -> + (x \in dangls0 (g1 \+ g2)) = + (x \in filter [predC nodes g2] (dangls0 g1)) || + (x \in filter [predC nodes g1] (dangls0 g2)). +Proof. +move=>W; rewrite /dangls0 -!filter_predI !mem_filter /=. +rewrite (andbC (x \notin nodes g2)). +by rewrite -andb_orr -negb_or -sinksUnE // -domUnE. +Qed. + +Lemma closed_danglsE g : closed g = nilp (dangls g). +Proof. by rewrite filter_nilp; apply/allP/hasPn=>H x /H; rewrite negbK. Qed. + +Lemma closed_dangls0E g : closed g = all (pred1 null) (dangls0 g). +Proof. by rewrite closed_danglsE dangls0E filter_nilp has_predC negbK. Qed. + +Lemma edge_broken g1 g2 x y : + edge (g1 \+ g2) x y -> + ~~ edge g1 x y -> + x \in nodes g1 -> + [/\ y \in nodes g2, y \in adj g1 x & y \in dangls0 g1]. +Proof. +case: (normalP (g1 \+ g2))=>[->|W /[dup] E + N Dx]; first by rewrite edge_undef. +rewrite edge_adj (edgeD E) /= adjUnL // Dx => Ay1. +have Dy : y \notin nodes g1 by apply: contra N; move/adj_edge; apply. +split=>//; last by rewrite mem_filter /= Dy; apply/sinksPA; exists x. +by case: (edgeD E)=>_; rewrite domUnE // (negbTE Dy). +Qed. + +Lemma path_broken g1 g2 x xs : + x \in nodes g1 -> + path (edge (g1 \+ g2)) x xs -> + path (edge g1) x xs \/ + exists y z, [/\ y \in nodes g1, y \in x :: xs, + z \in nodes g2, z \in xs, + z \in adj g1 y & z \in dangls0 g1]. +Proof. +case: xs=>[|y ys] // Dx P; first by left. +have [] := boolP (path (edge g1) x (y::ys)); first by left. +case/(pathPn null)=>i [/[dup] H1 /(pathP null P i) H4 H2 H3]; right. +case: i H1 H2 H3 H4=>[|i] H1 H2 H3 H4 {P}. +- by exists x, y; rewrite Dx !inE !eqxx; case: (edge_broken H4 H2 Dx). +move/(_ i (ltnSn _)): H3=>/edgeD [_ D2]. +case: (edge_broken H4 H2 D2)=>/= Dn2 An1 Dngl. +exists (nth null [:: x, y & ys] i.+1), (nth null (y :: ys) i.+1). +by split=>//; apply: mem_nth=>//; apply: ltn_trans H1 _. +Qed. + +Lemma cycle_broken g1 g2 x xs : + x \in nodes g1 -> + cycle (edge (g1 \+ g2)) (x :: xs) -> + cycle (edge g1) (x :: xs) \/ + exists y, [/\ y \in xs, y \in nodes g2 & y \in dangls0 g1]. +Proof. +case: (normalP (g1 \+ g2))=>[->|W Dx] /=. +- by rewrite rcons_path edge_undef andbF. +case/(path_broken Dx)=>[P|[y][z][_ _ Dz2 Rz _ Dlz1]]; first by left. +rewrite mem_rcons inE in Rz. +case: eqP Rz Dx Dz2=>[-> _ Dx /(dom_inNLX W Dx)//|/eqP N X Dx Dz2]. +by right; exists z. +Qed. + +End DanglsLemmas. + +(**********) +(* Summit *) +(**********) + +(* summit g x = locus of nodes where a path from x *) +(* exits the graph g, or loops back on itself *) + +(* n - fuel to run; ghost arg to be instantiated to size (nodes g) *) +Fixpoint summit' {V : link} {A} (n : nat) (g : partial_graph V A) x := + if n is n'.+1 then + if x \in nodes g then + \big[cat/[::]]_(y <- adj g x) summit' n' (free g x) y + else [:: x] + else [:: x]. + +Definition summit {V : link} {A} (g : partial_graph V A) := + @summit' V A (size (nodes g)) g. + +Section SummitLemmas. +Context {V : link} {A : Type}. +Implicit Type g : partial_graph V A. + +(* characteristic property of summit *) +Lemma summitP g (x y : node) : + y \in summit g x <-> + exists xs, [/\ path (edge g) x xs, uniq (x :: xs), + if x \in nodes g then y \in adj g (last x xs) else y == x & + y \notin nodes g \/ y \in x :: xs]. +Proof. +rewrite /summit; move: {-1}(size (nodes g)) (erefl (size (nodes g)))=>size. +elim: size g y x=>[|n IH] g /= y x S. +- rewrite inE (size0nil S); split=>[|[xs][P] /andP [X U]] /eqP ->{y} //. + by exists [::]; split=>//=; left. +case: ifP=>Dx; last first. +- rewrite inE; split=>[|[xs][P] /andP [X U]] /eqP ->{y} //. + by exists [::]; rewrite Dx; split=>//=; left. +have {}S : size (nodes (free g x)) = n by rewrite size_domF // S. +split=>[|[xs][P] /andP [N U] Ay H]. +- case/big_cat_memE=>z Az /IH [] //= xs [P] /andP [N U]. + rewrite !domF adjF inE negb_and negbK => H. + case: (z =P x) H Az P N U=>[->{z}|/eqP Nz] /=. + - move/eqP=>->{y}; case: xs=>[|z zs] /=. + - by exists [::]; split=>//; rewrite inE; right. + by rewrite edgeFE eqxx andbF. + case: ifPn=>Dz; last by move/eqP=>->{y}; exists [::]; split=>//; left. + case: ifPn=>// Lx Ay Az P Nxs U H; exists (z :: xs); split=>//=; rewrite ?inE. + - by rewrite edge_adj Dz Az (sub_path free_edge_sub P). + - rewrite negb_or eq_sym Nz Nxs U !andbT /=. + by apply/negP=>/(path_nodes P); rewrite domF eqxx. + by case: H=>/orP [] ->; [right|left|right|right]; rewrite ?orbT. +apply/big_cat_memE; case: xs H P N U Ay=>[|z zs] /=; rewrite !inE ?negb_or=>H. +- exists y=>//; apply/IH=>//; exists [::]. + split=>//; last by rewrite inE; right. + by rewrite domF; case: H=>[/negbTE|] -> //=; rewrite andbF. +case/andP=>E P /andP [Nxz Nxzs] /andP [Nzzs Uz] Ay. +exists z; first by apply: edgeA. +apply/IH=>//=; exists zs; split. +- by rewrite path_edge_free // inE negb_or Nxz Nxzs. +- by rewrite Nzzs Uz. +- rewrite domF eq_sym Nxz (edgeD E) adjF /=. + by case: (x =P last z zs) Nxz Nxzs=>// /last_mem/orP [] ->. +rewrite domF negb_and negbK inE. +by case: H=>[|/or3P []] ->; [left|left|right|right]; rewrite ?orbT. +Qed. + +Lemma summit_notin g x : + x \notin nodes g -> + summit g x = [:: x]. +Proof. by rewrite /summit; case: (size (nodes g))=>//= n /negbTE ->. Qed. + +Lemma summit_undef x : + summit (undef : partial_graph V A) x = [:: x]. +Proof. by rewrite /summit dom_undef. Qed. + +Lemma summit_unit x : + summit (Unit : partial_graph V A) x = [:: x]. +Proof. by rewrite /summit dom0. Qed. + +Lemma summitPt2 v x xs y : + summit (pts x (v, xs) : partial_graph V A) y = + if (x != 0) && (y == x) then links xs else [:: y]. +Proof. +rewrite /summit domPtK; case: ifPn=>//= N. +rewrite domPtK adjPt2 N inE; case: eqP=>// _. +by elim: (links xs)=>[|z zs IH]; rewrite ?big_nil ?big_cons ?IH. +Qed. + +Lemma summitPt v x xs : + summit (pts x (v, xs) : partial_graph V A) x = + if x != 0 then links xs else [:: x]. +Proof. by rewrite summitPt2 eqxx andbT. Qed. + +Lemma summit_dangl g x y : + y \in adj g x -> + y \notin nodes g -> + y \in summit g x. +Proof. +by move=>Ay Dy; apply/summitP; exists [::]; rewrite (adjD Ay); split=>//; left. +Qed. + +Lemma summit_cycles g x : + x \in cycles g -> + x \in summit g x. +Proof. +case/cyclesPCU=>xs /=; rewrite rcons_path=>/andP [P E] U. +apply/summitP; exists xs; rewrite (edgeD E) (edgeA E) inE eqxx. +by split=>//; right. +Qed. + +Lemma summit_leaves g x : + x \in leaves g -> + {subset summit g x <= [:: null]}. +Proof. +case/leavesP=>Dx /= H y /summitP [xs][]; rewrite Dx !inE. +case: xs=>[_ _ /H|z zs] //= /andP []/[dup]/edgeA/H /eqP -> /edgeD [_]. +by rewrite mem_dom0. +Qed. + +End SummitLemmas. + +(***********) +(* Summits *) +(***********) + +(* collecting the summits of all the nodes in g *) + +Definition summits {V : link} {A} (g : partial_graph V A) : seq node := + flatten (map (summit g) (nodes g)). + +Section SummitsLemmas. +Context {V : link} {A : Type}. +Implicit Type g : partial_graph V A. + +Lemma summit_summits_sub g x : + x \in nodes g -> + {subset summit g x <= summits g}. +Proof. by move=>Dx y Sy; apply/flatten_mapP; exists x. Qed. + +Lemma summits_undef : + summits (undef : partial_graph V A) = [::]. +Proof. by rewrite /summits dom_undef. Qed. + +Lemma summits_unit : + summits (Unit : partial_graph V A) = [::]. +Proof. by rewrite /summits dom0. Qed. + +Lemma summitsPt v x xs : + summits (pts x (v, xs) : partial_graph V A) = + if x != 0 then links xs else [::]. +Proof. +by rewrite /summits domPtK; case: ifP=>//= N; rewrite cats0 summitPt N. +Qed. + +Lemma cycles_summits_sub {g} : {subset cycles g <= summits g}. +Proof. +move=>x /cyclesPD [Dx][y Ay] /reachX [Dy][xs][P L U]. +apply/flatten_mapP; exists x=>//; apply/summitP; exists (belast y xs). +case: xs P U L Ay=>[_ _ -> /= Ay|z zs]. +- by rewrite Dy inE eqxx; split=>//; right. +rewrite {1}lastI rcons_path=>/andP [P1 /edgeA P2] U L Ay. +rewrite lastI -L rcons_uniq in U; split=>//=. +- by rewrite adj_edge. +- by rewrite Dx L. +by rewrite inE eqxx; right. +Qed. + +Lemma dangls0_summits_sub {g} : {subset dangls0 g <= summits g}. +Proof. +move=>x; rewrite mem_filter inE=>/andP [Dnx /sinksP [y Dy Ay]]. +apply/flatten_mapP; exists y=>//; apply/summitP; exists [::]. +by rewrite Dy; split=>//; left. +Qed. + +(* characteristic property: summits = cycles + dangls0 *) + +Lemma summits_cycles_dangls0E g x : + (x \in summits g) = + (x \in cycles g) || (x \in dangls0 g). +Proof. +apply/idP/orP; last by case=>[/cycles_summits_sub|/dangls0_summits_sub]. +case/flatten_mapP=>y Dy /summitP [ys][P _]; rewrite Dy inE=>L. +have S : {subset y :: ys <= nodes g} by apply/subset_consLI/(path_nodes P). +case=>X; [right|left; apply/cyclesP]. +- rewrite mem_filter /= X; apply/sinksP. + by exists (last y ys)=>//; apply/S/mem_last. +have El : edge g (last y ys) x by apply/adj_edge/L/S. +case/orP: X P L El=>[/eqP ->|X] P L El. +- exists (head y ys); first by case: ys P L {S El}=>// z zs /andP [/edgeA]. + apply/reachP; split; first by apply/S/head_mem. + exists (behead (rcons ys y)); split; last first. + - by case: ys {P L S El}=>//= z zs; rewrite last_rcons. + suff : path (edge g) y (rcons ys y) by rewrite headI=>/andP []. + by rewrite rcons_path P. +case/splitPr: {S} X P El L=>p1 p2; rewrite cat_path last_cat. +case/andP=>_ /[dup] Px /= /andP [_ P2] El L; exists (head x p2). +- by case: p2 P2 L {Px El}=>//= z zs /andP [/edgeA]. +apply/reachP; split; first by apply/(path_nodes Px)/(head_mem x p2). +exists (behead (rcons p2 x)). +split; last by case: p2 {Px P2 El L}=>//= z xs; rewrite last_rcons. +suff : path (edge g) x (rcons p2 x) by rewrite headI=>/andP []. +by rewrite rcons_path P2 El. +Qed. + +Lemma loops_summits_sub {g} : {subset loops g <= summits g}. +Proof. by move=>x /loops_cycles_sub/cycles_summits_sub. Qed. + +Lemma in_nodes_summitsE g x : + x \in nodes g -> + (x \in summits g) = (x \in cycles g). +Proof. +by rewrite summits_cycles_dangls0E orbC=>/(allP dangls0_nodesD)/negbTE ->. +Qed. + +Lemma notin_nodes_summitsE g x : + x \notin nodes g -> + (x \in summits g) = (x \in dangls0 g). +Proof. +by rewrite summits_cycles_dangls0E=>/negP Nx; apply/orb_idl=>/cyclesD. +Qed. + +Lemma closed_summits_sub g : + closed g -> + {subset summits g <= null :: cycles g}. +Proof. +rewrite closed_dangls0E=>D x; rewrite summits_cycles_dangls0E inE. +by case/orP=>[|/(allP D)/=] -> //; rewrite orbT. +Qed. + +Lemma summits_closed0 g : + reflect {subset summits g <= nodes0 g} + (closed g). +Proof. +apply: (iffP idP)=>[|S]. +- move/closed_summits_sub=>S x /S; rewrite !inE. + by case/orP=>[->//|/cyclesD ->]; rewrite orbT. +apply/closedP=>x /sinksP [y Ny Ay]; apply/wlog_neg=>Dx. +rewrite S ?dangls0_summits_sub // dangls0_mem (adj_sinks_sub Ay) andbT. +by apply: contra Dx=>Dx; rewrite inE Dx orbT. +Qed. + +Lemma summitsUn {g1 g2 x} : + valid (g1 \+ g2) -> + preacyclic (g1 \+ g2) -> + (x \in summits (g1 \+ g2)) = + (x \in filter [predC nodes g2] (summits g1)) || + (x \in filter [predC nodes g1] (summits g2)). +Proof. +move=>W /preacyclic_sub P; rewrite summits_cycles_dangls0E. +rewrite (subset_eq P loops_cycles_sub) loopsUn // dangls0Un //= -!orbA. +rewrite (orbCA (x \in loops g2)) -(filter_disjC (disj_loopsL W)). +rewrite -(filter_disjC (disj_loopsR W)) orbA -!mem_cat -!filter_cat 2!mem_cat. +rewrite !mem_filter /= !mem_cat. +rewrite (subset_eq loops_cycles_sub (cycles_loops_subL W P)). +rewrite (subset_eq loops_cycles_sub (cycles_loops_subR W P)). +by rewrite !summits_cycles_dangls0E. +Qed. + +(* node cannot be a cycle in two disjoint graphs *) +(* if a summit is not a cycle it must be dangl *) + +Lemma summitsEq_subL g1 g2 : + valid (g1 \+ g2) -> + summits g1 =i summits g2 -> + {subset cycles g1 <= dangls0 g2}. +Proof. +move=>W C x /[dup] /cyclesD Dx /cycles_summits_sub; rewrite C. +by move: (dom_inNL W Dx)=>Dnx Cx; rewrite -notin_nodes_summitsE. +Qed. + +Lemma summitsEq_subR g1 g2 : + valid (g1 \+ g2) -> + summits g1 =i summits g2 -> + {subset cycles g2 <= dangls0 g1}. +Proof. by rewrite joinC=>W C; apply: summitsEq_subL. Qed. + +End SummitsLemmas. + + +(****************) +(****************) +(* Unary graphs *) +(****************) +(****************) + +(* unary graphs have singleton list for linkage *) + +Definition single_links (x : node) := [:: x]. +Definition single_mk (s : seq node) := + if s is [:: a] then Some a else None. +Arguments single_links x /. +Arguments single_mk s /. +Lemma single_is_link : link_axiom single_links single_mk. +Proof. by split; case=>// a []. Qed. +HB.instance Definition _ := isLink.Build node single_is_link. +Abbreviation unary_graph A := (partial_graph node A). +Notation "x &1-> v" := (ptsT (unary_graph _) x v) (at level 30). + +(* graphs with fixed arity have special names for children *) +(* for unary graphs, we call the child nxt *) + +(* nxt is immediate node after x in graph g *) +(* if x \notin g, the default is to return x *) +(* it's possible to make other defaults (e.g., null) *) +(* but other choices complicate somewhat *) +(* the characteristic property given below *) + +Definition nxt A (g : unary_graph A) (x : node) : node := + head x (adj g x). + +Section UnaryLemmas. +Context {A : Type}. +Implicit Types (g : unary_graph A) (x y z : node) (v : A). + +Lemma nxt_notin g x : + x \notin nodes g -> + nxt g x = x. +Proof. by rewrite /nxt=>/adjND ->. Qed. + +Lemma adj_nxt g x : + x \in nodes g -> + adj g x = [:: nxt g x]. +Proof. by rewrite /nxt=>/In_graphX [v][xs][_] ->. Qed. + +Lemma inj_edge g x y1 y2 : + edge g x y1 -> + edge g x y2 -> + y1 = y2. +Proof. +move/[dup]/edgeD=>[Dx _]; rewrite !edge_adj adj_nxt // !inE. +by case/andP=>_ /eqP <- /andP [_] /eqP. +Qed. + +Lemma In_nxt g x v y : + (x, (v, y)) \In g -> + y = nxt g x. +Proof. by rewrite /nxt=>/In_graph ->. Qed. + +(* opposite direction *) +Lemma In_graph1X g x : + x \in nodes g -> + exists v y, (x, (v, y)) \In g /\ nxt g x = y. +Proof. move/In_domX=>[[v] y] G; exists v, y; split=>//; apply/esym/(In_nxt G). Qed. + +Lemma nxt_in g x : + nxt g x \in nodes g -> + x \in nodes g. +Proof. by apply: contraTT=>/[dup]/nxt_notin ->. Qed. + +Lemma nxt_pts v x y : + x != 0 -> + nxt (pts x (v, y) : unary_graph A) x = y. +Proof. by move=>N; rewrite /nxt /adj //findPt ifT. Qed. + +Lemma nxt_ptsUn g x y v : + valid (pts x (v, y) \+ g) -> + nxt (pts x (v, y) \+ g) x = y. +Proof. by move=>W; apply/esym; move: (In_nxt (InPtUnL W)). Qed. + +Lemma leaves1E g x : + (x \in leaves g) = + (x \in nodes g) && (nxt g x == null). +Proof. by rewrite leavesE; apply/andb_id2l=>?; rewrite adj_nxt ?all_seq1. Qed. + +Lemma nxt_notleaves g x : + x \in nodes g -> + (x \notin leaves g) = (nxt g x != null). +Proof. by rewrite leaves1E negb_and=>->. Qed. + +Lemma nxt_in_sinks g x: + x \in nodes g -> + nxt g x \in sinks g. +Proof. by move=>Dx; apply/sinksPA; exists x; rewrite adj_nxt ?inE. Qed. + +Lemma nxt_closed g x : + x \in nodes g -> + closed g -> + nxt g x \in nodes0 g. +Proof. by move/nxt_in_sinks=>X /closedP; apply. Qed. + +Lemma nxt_leaves_closed g x : + x \in nodes g -> + x \notin leaves g -> + closed g -> + nxt g x \in nodes g. +Proof. +move=>Dx; rewrite nxt_notleaves // => N /(nxt_closed Dx). +by rewrite inE (negbTE N). +Qed. + +Lemma loops1E g x : + (x \in loops g) = + (x \in nodes (kfilt g (fun x => x == nxt g x))). +Proof. +rewrite !nodes_kfilt -!topredE /=; apply/andP/andP; case=>Dx; +by rewrite (adj_nxt Dx) inE. +Qed. + +Lemma cycles1E g x : + (x \in cycles g) = + (x \in reach g (nxt g x)). +Proof. +rewrite cyclesE; apply/andP; case: ifP=>C; last first. +- by case=>Dx; rewrite adj_nxt //= cats0 C. +by case/reachP: (C)=>/[dup]/nxt_in D N _; rewrite adj_nxt //= cats0. +Qed. + +Lemma nxt_free_notin g x y : + x != y -> + nxt (free g y) x = nxt g x. +Proof. by move=>N; rewrite /nxt adjF eq_sym (negbTE N). Qed. + +Lemma cycle1_nxt g x xs : + cycle (edge g) xs -> + x \in xs -> + nxt g x \in xs. +Proof. +case: xs=>//= y ys /[dup]/path_nodes S P /[dup] X; rewrite -!mem_rcons=>/S Dx. +case/(path_next X): P=>z [Rz]; rewrite edge_adj adj_nxt // inE. +by case/andP=>Dz /eqP <-. +Qed. + +Lemma cycle1_path_sub g xs y ys : + cycle (edge g) xs -> + y \in xs -> + path (edge g) y ys -> + {subset ys <= xs}. +Proof. +case: xs=>// x xs C; elim: ys y=>//= y' ys IH y /[dup] Y. +rewrite -mem_rcons=>/[dup] Ry /(path_nodes C) Dy /andP []. +rewrite edge_adj adj_nxt // inE => /andP [Dy'] /eqP N'. +move/(cycle1_nxt C): Y; rewrite -N' => Ngy Pys. +by apply: subset_consLI Ngy (IH y' Ngy Pys). +Qed. + +Lemma cycle1_reach_sub g x xs : + cycle (edge g) xs -> + x \in xs -> + {subset reach g x <= xs}. +Proof. +case: xs=>// y ys C In z; case: (x =P z)=>[<-|/eqP Neq] //. +case/reachP=>Dx [xs'][P L]; apply: (cycle1_path_sub C In P). +by move: (mem_last x xs'); rewrite -L inE eq_sym (negbTE Neq). +Qed. + +Lemma reach_cycles1_sub g x : + x \in cycles g -> + {subset reach g x <= cycles g}. +Proof. +case/cyclesX=>xs C /(cycle1_reach_sub C)=>S y /S Y. +by apply: cyclesXI Y C. +Qed. + +Lemma cycles1_nxt g x : + x \in cycles g -> + nxt g x \in cycles g. +Proof. by case/cyclesX=>xs C /(cycle1_nxt C)/(cycle_cycles_sub C). Qed. + +Lemma nxt_notin_cycles g x : + nxt g x \notin nodes g -> + x \notin cycles g. +Proof. by apply: contra=>/cycles1_nxt/cyclesD. Qed. + +Lemma loops1_reach g x : + x \in loops g -> + reach g x =i [:: x]. +Proof. +rewrite loops1E nodes_kfilt=>/andP [Dx /eqP Nxt] y. +rewrite reachEAX Dx !inE adj_nxt //= big_cons big_nil -Nxt. +by rewrite reachDN ?orbF // domF eqxx. +Qed. + +Lemma loops1_reachE g x : + x \in loops g -> + reach g x = [:: x]. +Proof. by move=>L; apply/undup_uniq_eq1/loops1_reach/L/uniq_reach. Qed. + +Lemma In_loops1P g x : + reflect (exists v, (x, (v, x)) \In g) + (x \in loops g). +Proof. +apply: (iffP (In_loopsP _ _))=>[[v][a][/[swap]]|[v H]]. +- by rewrite inE=>/eqP ->; exists v. +by exists v, x; rewrite inE. +Qed. + +Lemma In_loops1 g x v : + (x, (v, x)) \In g -> + x \in loops g. +Proof. by move=>H; apply/In_loops1P; exists v. Qed. + +Lemma In_loops1N g x y v : + x != y -> + (x, (v, y)) \In g -> + x \notin loops g. +Proof. +move=>N I; apply/negP=>/In_loops1P[w]/(In_fun I) [_] E. +by rewrite E eqxx in N. +Qed. + +Lemma loops1NPt x y z v : + x \in loops (pts y (v, z)) -> + x = y /\ y = z. +Proof. by case/In_loops1P=>w /InPt [][-> _]. Qed. + +Lemma loops1Pt x y z v : + y != 0 -> + (x \in loops (pts y (v, z))) = (x == y) && (y == z) . +Proof. +move=>N; apply/In_loops1P/andP; first by case=>w/InPt [][-> _ /eqP]. +by case=>/eqP -> /eqP <-; exists v; apply/In_condPt. +Qed. + +Lemma In_loops1NE x y v : + x != y -> + loops (pts x (v, y)) =i [::]. +Proof. by move/eqP=>N z; apply/In_loops1P=>-[w] /InPt [][->]. Qed. + +(* other direction proved above for partial graphs *) +(* but this direction only holds for unary graphs *) + +Lemma sub_preacyclic g : + {subset cycles g <= loops g} -> + preacyclic g. +Proof. +move=>S; apply/preacyclicP=>x y Dx Dy. +case: (x =P y)=>// /eqP Nxy /(bireach_cycleP _ Nxy) [xs] Y C. +have E : reach g x = [:: x]. +- by apply/undup_uniq_eq1/loops1_reach/S/cyclesPCI/C/uniq_reach. +suff : y \in reach g x by rewrite E inE eq_sym (negbTE Nxy). +have : (y \in bireach g x) by apply/bireach_cycleP=>//; exists xs. +by rewrite mem_filter => /andP []. +Qed. + +Lemma sub_preacyclicE g : + preacyclic g = all [mem loops g] (cycles g). +Proof. by apply/idP/allP; [apply/preacyclic_sub|apply/sub_preacyclic]. Qed. + +(* only one direction holds *) +Lemma preacyclicUn g1 g2 : + valid (g1 \+ g2) -> + preacyclic (g1 \+ g2) -> + preacyclic g1 && preacyclic g2. +Proof. +move=>W /preacyclic_sub P; apply/andP; split; apply/sub_preacyclic; +by [apply: (cycles_loops_subL W)|apply: (cycles_loops_subR W)]. +Qed. + +(* this lemma doesn't genearlize to n-ary or partial graphs *) +Lemma closed_leaves_dangls0E g : + closed g -> + nilp (leaves g) -> + nilp (dangls0 g). +Proof. +rewrite closed_dangls0E=>/allP /= S /nilP L; rewrite nilp_hasPn. +apply/hasPn=>x /[dup] Dgx; rewrite mem_filter=>/andP [/= Dx /sinksP [y Dy]]. +rewrite adj_nxt // inE /eqP => N; suff {L} : y \in leaves g by rewrite L. +by rewrite leaves1E Dy -(eqP N); apply: S Dgx. +Qed. + +Lemma preacyclic_mutation g x y z v : + valid (pts x (v, y) \+ g) -> + z \notin nodes (pts x (v, y) \+ g) -> + preacyclic (pts x (v, y) \+ g) -> + preacyclic (pts x (v, z) \+ g). +Proof. +move=>W Nz /preacyclic_sub /[dup] /(cycles_loops_subL W) Sl. +move=>/(cycles_loops_subR W) Sr; apply/sub_preacyclic=>w C. +have V : valid (pts x (v,z) \+ g) by rewrite (validPtUnE (v, y)). +have NxE : nxt (pts x (v, z) \+ g) x = z by rewrite nxt_ptsUn. +have NdE : nodes (pts x (v, y) \+ g) =i nodes (pts x (v, z) \+ g). +- by move=>r; rewrite !nodesPtUn. +have /cyclesNF : x \notin cycles (pts x (v, z) \+ g). +- by rewrite nxt_notin_cycles // NxE -NdE Nz. +by rewrite (freePtUn V) (loopsUn _ V) orbC=>/(_ _ C)/Sr=>->. +Qed. + +Lemma path1_uniq g x y xs ys : + uniq (y :: xs) -> + uniq (y :: ys) -> + path (edge g) x (rcons xs y) -> + path (edge g) x (rcons ys y) -> + xs = ys. +Proof. +elim: xs ys x y=>[|z zs IH] ys x y U1 U2 /= /andP [E1 P1] P2. +- case: ys E1 P2 U2=>//= z zs; rewrite inE negb_or -andbA. + by move=>E1 /andP [] /(inj_edge E1) ->; rewrite eqxx. +case: ys U2 P2=>[|u us] U2 /= /andP [E2 P2]. +- by rewrite (inj_edge E1 E2) /= inE eqxx in U1. +rewrite (inj_edge E1 E2) in P1 *. +by rewrite (IH _ _ _ _ _ P1 P2) // ?(uniqX U1, uniqX U2). +Qed. + +Lemma cycle1_uniq g x xs ys : + uniq (x :: xs) -> + uniq (x :: ys) -> + cycle (edge g) (x :: xs) -> + cycle (edge g) (x :: ys) -> + x :: xs = x :: ys. +Proof. by move=>U1 U2 P1 /(path1_uniq U1 U2 P1)=>->. Qed. + +(* doesn't generalize to n-ary or partial graphs *) +Lemma cycle1_reachE g x xs : + cycle (edge g) xs -> + x \in xs -> + reach g x =i xs. +Proof. +move=>C X y; apply/idP/idP; first by move/(cycle1_reach_sub C X). +move: (cycle_nodes C X)=>Dx; case/splitPr: X C=>p1 p2 /[swap]. +rewrite mem_cat inE; case/or3P; last 2 first. +- by move/eqP=>->; rewrite reach0. +- case/splitPr=>p3 p4; rewrite -(cat1s x) -(cat1s y) cycle_catC catA /=. + rewrite -catA /= -cat_rcons rcons_cat cat_path; case/andP=>P _. + by apply/reachP; split=>//; exists (rcons p3 y); rewrite last_rcons. +case/splitPr=>p3 p4; rewrite cycle_catC -(cat1s y) !catA /=. +rewrite rcons_cat cat_path cats1; case/andP=>/= P _. +by apply/reachP; split=>//; exists (rcons (p2 ++ p3) y); rewrite last_rcons. +Qed. + +(* doesn't generalize to n-ary or partial graphs *) +Lemma cycle1_mem_eq g x xs ys : + cycle (edge g) xs -> + cycle (edge g) ys -> + x \in xs -> + x \in ys -> + xs =i ys. +Proof. +by move=>Cx Cy X Y y; rewrite -(cycle1_reachE Cx X) -(cycle1_reachE Cy Y). +Qed. + +Lemma cycle_head_mem g xs x: + cycle (edge g) xs -> + x \in xs -> + exists ys, [/\ cycle (edge g) (x :: ys), + uniq (x :: ys) & xs =i (x :: ys)]. +Proof. +move=>C X; case: (cycle_head_uniq X C)=>ys [Cy Uy]; exists ys; split=>// y. +by rewrite -(cycle1_reachE C X) -(cycle1_reachE (x:=x) Cy) // inE eqxx. +Qed. + +(* this lemma applies to unary graphs only *) +(* as proof depends on nodes being only in a single cycle *) +Lemma cycle1_brokenL2 g1 g2 x xs : + x \in nodes g1 -> + cycle (edge (g1 \+ g2)) (x :: xs) -> + {subset xs <= [predC cycles g2]}. +Proof. +case: (normalP (g1 \+ g2))=>[-> _ /=|W]. +- by rewrite rcons_path edge_undef andbF. +move=>Dx C y X; apply/cyclesXU=>-[ys][Cy Y _]. +have : y \in x :: xs by rewrite inE X orbT. +case/(cycle_head_mem C)=>zs [{}C U Eqs]. +have {}X : x \in y :: zs by rewrite -Eqs inE eqxx. +case: (cycle_head_mem Cy Y)=>us [Cu Uu Uus]. +rewrite (cycle1_uniq U Uu C (sub_path (subrel_edgeR W) Cu)) in X. +by apply/dom_inNRX/Dx/(cycle_nodes Cu)/X/W. +Qed. + +Lemma cycle_brokenL g1 g2 x xs : + x \in nodes g1 -> + cycle (edge (g1 \+ g2)) (x :: xs) -> + cycle (edge g1) (x :: xs) \/ + exists y, [/\ y \in xs, y \in nodes g2, + y \in dangls0 g1 & y \notin cycles g2]. +Proof. +case: (normalP (g1 \+ g2))=>[->|W] /=. +- by rewrite rcons_path edge_undef andbF. +move=>Dx1 /[dup] P /(path_broken Dx1) [P1|[y][z][Dy1 Ys Dz2 Rz Az1 Dlz1]]; +first by [left]; rewrite mem_rcons inE in Rz; right; exists z. +case: eqP Rz Dz2 (dom_inNL W Dx1)=>[-> _ ->//|/=_ Rz Dz2 _]. +by split=>//; apply: (cycle1_brokenL2 Dx1 P). +Qed. + +Lemma cycle_brokenR g1 g2 x xs : + x \in nodes g2 -> + cycle (edge (g1 \+ g2)) (x :: xs) -> + cycle (edge g2) (x :: xs) \/ + exists y, [/\ y \in xs, y \in nodes g1, + y \in dangls0 g2 & y \notin cycles g1]. +Proof. by rewrite joinC; apply: cycle_brokenL. Qed. + +End UnaryLemmas. + +(***********) +(* Summit1 *) +(***********) + +(* specializing summit to unary graphs *) + +Definition summit1 {A} (g : unary_graph A) x := head null (summit g x). + +Section Summit1Lemmas. +Context {A : Type}. +Implicit Type g : unary_graph A. + +Lemma summit1_size g x : size (summit g x) = 1. +Proof. +rewrite /summit; move: {-1}(size (nodes g)) (erefl (size (nodes g)))=>size. +elim: size g x=>[|n IH] g /= x // E; case: ifP=>// Dx. +by rewrite size_big_cat adj_nxt //= big_cons big_nil addn0 IH // size_domF // E. +Qed. + +Lemma summit1E g x : summit g x = [:: summit1 g x]. +Proof. by rewrite /summit1; case: (summit g x) (summit1_size g x)=>[|z []]. Qed. + +Lemma summit1EX g x y : + y = summit1 g x <-> summit g x = [:: y]. +Proof. by rewrite /summit1; split=>-> //; apply: summit1E. Qed. + +Lemma summit1EY g x y : + y \in summit g x <-> y = summit1 g x. +Proof. by rewrite summit1EX summit1E inE; split=>[/eqP|[]] ->. Qed. + +Lemma summit1P g x y : + y = summit1 g x <-> + exists xs, [/\ path (edge g) x xs, uniq (x :: xs), + y = nxt g (last x xs) & + y \notin nodes g \/ y \in x :: xs]. +Proof. +split=>[/summit1EX S|[xs][P U /eqP L H]]; last first. +- suff : y \in summit g x by rewrite summit1E inE=>/eqP. + apply/summitP; exists xs; split=>//; case: ifPn (path_nodes0 P) L=>Dx. + - by rewrite adj_nxt ?inE ?(subset_consLI _ (path_nodes P) (mem_last x xs)). + by rewrite orbF nilpE=>/eqP ->; rewrite nxt_notin. +have : y \in summit g x by rewrite S inE. +case/summitP=>xs [P U Ax H]; exists xs; split=>//; apply/eqP. +case: ifPn Ax (path_nodes0 P)=>[Dx|Dx /eqP ->]; last first. +- by rewrite orbF nilpE=>/eqP ->; rewrite nxt_notin. +by rewrite adj_nxt ?inE ?(subset_consLI _ (path_nodes P) (mem_last x xs)). +Qed. + +Lemma summit1X g x : + exists xs, [/\ path (edge g) x xs, uniq (x :: xs), + summit1 g x = nxt g (last x xs) & + summit1 g x \notin nodes g \/ summit1 g x \in x :: xs]. +Proof. by apply/summit1P. Qed. + +Lemma summit1Pt v x y: + x != 0 -> + summit1 (pts x (v, y) : unary_graph A) x = y. +Proof. by move=>N; rewrite /summit1 summitPt N. Qed. + +Lemma summit1_notin g x : + x \notin nodes g -> + summit1 g x = x. +Proof. by rewrite /summit1; move/summit_notin=>->. Qed. + +Lemma summit1_dangl g x : + x \in nodes g -> + nxt g x \notin nodes g -> + summit1 g x = nxt g x. +Proof. by move=>??; apply/esym/summit1P; exists [::]; split=>//; left. Qed. + +Lemma summit1_leaves g x : + x \in leaves g -> + summit1 g x = null. +Proof. +rewrite leaves1E=>/andP [Dx /eqP/[dup] N <-]; apply: (summit1_dangl Dx). +by rewrite N cond_dom. +Qed. + +Lemma summit1_loops g x : + x \in loops g -> + summit1 g x = x. +Proof. +rewrite loops1E nodes_kfilt=>/andP [Dx] /eqP N. +by apply/esym/summit1P; exists [::]; split=>//; right; rewrite inE. +Qed. + +End Summit1Lemmas. + +(************) +(* Summits1 *) +(************) + +(* specializing summits to unary graphs *) + +Section Summits1Lemmas. +Context {A : Type}. +Implicit Type g : unary_graph A. + +Lemma summits1E g : summits g = map (summit1 g) (nodes g). +Proof. +rewrite /summits/summit1; elim: (nodes g)=>[|x xs IH] //=. +by rewrite IH; case: (summit g x) (summit1_size g x)=>// z []. +Qed. + +Lemma summit1_in_summits g x : + x \in nodes g -> + summit1 g x \in summits g. +Proof. by move=>Dx; rewrite summits1E; apply/mapP; exists x. Qed. + +(* doesn't generalize to n-ary *) +(* because summits can be null even if there's no leaves *) +Lemma closed_leaves_summits1_sub g : + closed g -> + nilp (leaves g) -> + {subset summits g <= cycles g}. +Proof. +move=>S L x; rewrite summits_cycles_dangls0E=>/orP [] //. +by rewrite (nilP (closed_leaves_dangls0E S L)). +Qed. + +(* doesn't hold for n-ary graphs *) +Lemma summits1_nullX g : + null \in summits g -> + exists x, x \in leaves g. +Proof. +rewrite summits1E=>/mapP [x Dx] /summit1P [xs][P U L _]. +exists (last x xs); rewrite leaves1E -L andbT. +by apply/subset_consLI/mem_last/path_nodes/P/Dx. +Qed. + +Lemma leaves1_nilE g : + (null \notin summits g) = + (leaves g == [::]). +Proof. +apply/idP/idP=>[Nc|/eqP L]; last by apply/negP=>/summits1_nullX [x]; rewrite L. +apply: contraR Nc; case/has_nilP/hasP=>x /[dup]/leavesD Dx /summit1_leaves C. +by move: C (summit1_in_summits Dx)=>->. +Qed. + +Lemma summit1_nxt g x y: + preacyclic g -> + (y == summit1 g (nxt g x)) = (y == summit1 g x). +Proof. +move/preacyclic_sub=>P; case: (nxt g x =P x)=>[->//|/eqP N]. +have Dx: x \in nodes g by apply: contraR N=>/nxt_notin/eqP. +apply/eqP/eqP; last first. +- move/[dup]=>Ctr /summit1P [[|z zs]]. + - by case=>??-> [D|]; [apply/esym/summit1_notin|rewrite inE (negbTE N)]. + case=>/= /andP [+ Pth] /and3P [U1 U2 U3] L H. + rewrite edge_adj adj_nxt // inE=>/andP [_ /eqP Nxtz]. + apply/summit1P; exists zs; rewrite -Nxtz; split=>//; first by apply/andP. + case: H Ctr=>[->|]; first by left. + rewrite inE=>/orP [/eqP -> Ctr|->]; last by right. + have: x \in loops g. + - by rewrite P // -in_nodes_summitsE // Ctr summit1_in_summits. + by rewrite loops1E nodes_kfilt -!topredE /= eq_sym (negbTE N) andbF. +case/summit1P=>xs [Pth /= U L H]. +have [NxtD|NxtD] := boolP (nxt g x \in nodes g); last first. +- rewrite (summit1_dangl Dx NxtD). + by case/orP: (path_nodes0 Pth) NxtD L=>[/nilP -> /nxt_notin|] ->. +apply/summit1P; exists (nxt g x :: xs); split=>//=; last 1 first. +- by rewrite inE; case: H=>[->|->]; [left|right]; rewrite ?orbT. +- by rewrite edge_adj adj_nxt // NxtD inE eqxx Pth. +rewrite inE negb_or eq_sym N U andbT /=; apply/negP=>X. +suff : x \in loops g. +- by rewrite loops1E nodes_kfilt Dx -topredE /= eq_sym (negbTE N). +apply/P; rewrite cycles1E; apply/reachP; split=>//. +case/splitPr: X Pth=>p1 p2; rewrite -(cat1s x) catA cat_path /= cats1. +by case/andP; exists (rcons p1 x); rewrite last_rcons. +Qed. + +Lemma summits1Eq_subL g1 g2 : + valid (g1 \+ g2) -> + summits g1 =i summits g2 -> + {subset cycles g1 <= dangls0 g2}. +Proof. +move=>V C x /[dup]/cyclesD Dx /cycles_summits_sub; rewrite C. +by rewrite -notin_nodes_summitsE // (dom_inNL V Dx). +Qed. + +Lemma summits1Eq_subR g1 g2 : + valid (g1 \+ g2) -> + summits g1 =i summits g2 -> + {subset cycles g2 <= dangls0 g1}. +Proof. by rewrite joinC=>V C; apply: summits1Eq_subL. Qed. + +Lemma summits1Eq_cyclesUn g1 g2 x : + summits g1 =i summits g2 -> + x \in cycles (g1 \+ g2) -> + (x \in cycles g1) || (x \in cycles g2). +Proof. +case: (normalP (g1 \+ g2))=>[->|W]; first by rewrite cycles_undef. +move=>E /[dup] /cyclesPC [xs C] /cyclesD; rewrite domUnE //. +case/orP=>Dx. +- case/(cycle_brokenL Dx): C=>[/cyclesPCI ->//|[y][X Dy2 Dly1 Cny2]]. + move/dangls0_summits_sub: Dly1; rewrite E summits_cycles_dangls0E. + by rewrite (negbTE Cny2) (negbTE (disjointR dangls0_nodesD _ Dy2)). +case/(cycle_brokenR Dx): C=>[/cyclesPCI ->|[y][X Dy1 Dly2 Cny1]]. +- by rewrite orbT. +move/dangls0_summits_sub: Dly2; rewrite -E summits_cycles_dangls0E. +by rewrite (negbTE Cny1) (negbTE (disjointR dangls0_nodesD _ Dy1)). +Qed. + +Lemma summits1EqUnL g1 g2 : + valid (g1 \+ g2) -> + summits g1 =i summits g2 -> + summits (g1 \+ g2) =i summits g1. +Proof. +move=>V C x; rewrite !summits_cycles_dangls0E; apply/idP/idP; last first. +- case/orP=>[/(cyclesUnL V) ->//|Dl1]. + have [Dx2|Dnx2] := boolP (x \in nodes g2); last first. + - by rewrite dangls0Un // 2!mem_filter /= Dl1 Dnx2 orbT. + move/dangls0_summits_sub: Dl1; rewrite C in_nodes_summitsE //. + by move/(cyclesUnR V)=>->. +case/orP. +- move/[dup]=>Cx /cyclesD; rewrite domUnE // => Dx. + case/orP: (summits1Eq_cyclesUn C Cx)=>[->//|]. + case/orP: Dx=>Dx; first by move/cyclesD/(dom_inNLX V Dx). + by move/(summits1Eq_subR V C)=>->; rewrite orbT. +move/[dup]=>/(disjointL dangls0_nodesD) Dnx. +rewrite dangls0Un // 2!mem_filter /=. +case/orP=>[/andP [_ ->]|]; first by rewrite orbT. +by case/andP=>_ /dangls0_summits_sub; rewrite -C summits_cycles_dangls0E. +Qed. + +End Summits1Lemmas. + + +(***************) +(* Partitioned *) +(***************) + +(* when summits are loops (no dangls) *) +(* the graph is divided into disjoint equivalence classes of nodes *) +(* determined by the loop into which any given node summits *) +(* this concept is used in union-find *) + +Definition partitioned1 {A} (g : unary_graph A) := + {subset summits g <= loops g}. + +Section PartitionedLemmas. +Context {A : Type}. +Implicit Type g : unary_graph A. + +Lemma part_closed g : + partitioned1 g -> + closed g. +Proof. +by move=>P; apply/summits_closed0=>x /P/loopsD Dx; rewrite inE Dx orbT. +Qed. + +Lemma part_leaves g : + partitioned1 g -> + nilp (leaves g). +Proof. +by rewrite nilpE -leaves1_nilE=>S; apply/negP=>/S/loopsD; rewrite mem_dom0. +Qed. + +Lemma part_preacyclic g : + partitioned1 g -> + preacyclic g. +Proof. by move=>S; apply/sub_preacyclic=>x /cycles_summits_sub/S. Qed. + +Lemma part_char g : + partitioned1 g -> + [/\ closed g, preacyclic g & nilp (leaves g)]. +Proof. +by move=>P; split; [apply/part_closed|apply/part_preacyclic|apply/part_leaves]. +Qed. + +Lemma part_summits1E g : + partitioned1 g -> + summits g =i loops g. +Proof. by move=>P x; apply/idP/idP; [apply/P|apply/loops_summits_sub]. Qed. + +Lemma part_loop_eta g x : + partitioned1 g -> + x \in summits g -> + exists v, g = pts x (v, x) \+ free g x. +Proof. by move=>P /P/In_loops1P [v] In; exists v; apply: graph_eta. Qed. + +Lemma loops_eta g x : + x \in loops g -> + exists v, g = pts x (v, x) \+ free g x. +Proof. by move/In_loops1P=> [v] In; exists v; apply: graph_eta. Qed. + +Lemma partUn g1 g2 : + valid (g1 \+ g2)-> + partitioned1 g1 -> + partitioned1 g2 -> + partitioned1 (g1 \+ g2). +Proof. +move=>V /part_char [C1 P1 L1] /part_char [C2 P2 L2]. +move: (preacyclic_sub (P1)) (preacyclic_sub (P2))=>S1 S2. +move: (closed_preacyclicUn C1 C2 P1 P2)=>P /= x. +rewrite summitsUn // !mem_filter //=. +case/orP=>/andP [Dnx]. +- by rewrite loopsUn // => /(closed_leaves_summits1_sub C1 L1)/S1 ->. +by rewrite loopsUn // orbC => /(closed_leaves_summits1_sub C2 L2)/S2 ->. +Qed. + +Lemma part_summits1_free g x : + x \in loops g -> + {subset summits (free g x) <= summits g}. +Proof. +rewrite {1 3}(kfiltC g (pred1 x))=>/[dup] Ls /loopsD/[dup] Dx /dom_valid V y. +rewrite !summits1E=>/mapP [z]; rewrite -kfiltC1=>Dz Ez; apply/mapP; exists z. +- by rewrite domUnE // Dz orbT. +case/summit1P: Ez=>xs [P //= /andP [U1 U2] L H]; apply/summit1P. +have P' : path (edge (kfilt g (pred1 x) \+ kfilt g (predC (pred1 x)))) z xs. +- by rewrite -{1}kfiltC; apply/sub_path/P/edge_kfilt_sub. +move/path_nodes: P=>Sb; move: (mem_last z xs) (subset_consLI Dz Sb)=>M S. +have Lzl : last z xs \in nodes (kfilt g (predC1 x)) by apply: S. +have Lz : last z xs \in nodes (kfilt g (pred1 x) \+ kfilt g (predC1 x)). +- by rewrite domUnE // S // orbT. +have Ey: y = nxt (kfilt g (pred1 x) \+ kfilt g (predC1 x)) (last z xs). +- by rewrite /nxt adjUnR // ifT. +case: (x =P y)=>[E|/eqP N]; last first. +- exists xs; split=>//=; first by rewrite U1 U2. + case: H=>H; [left|by right]. + by rewrite domUnE // negb_or H nodes_kfilt negb_and inE eq_sym N orbT. +exists (rcons xs x); subst x; split=>//=; last 2 first. +- by move: Ls; rewrite loops1E nodes_kfilt last_rcons=>/andP [_ /eqP]. +- by right; rewrite inE mem_rcons inE eqxx orbT. +- by rewrite rcons_path P' edge_adj Dx adjUnR //= ifT // adj_nxt // inE -L. +rewrite mem_rcons inE negb_or U1 rcons_uniq U2 !andbT; apply/andP; split. +- by case: eqP Dz=>// ->; rewrite kfiltC1 domF eqxx. +by apply/negP=>/Sb; rewrite kfiltC1 domF eqxx. +Qed. + +End PartitionedLemmas. + + +(*********************) +(* Spatial predicate *) +(*********************) + +(* layout for unary graphs *) + +Definition node1_lay {A} x (v : A * node) : heap := + x :-> v.1 \+ x.+1 :-> v.2. + +Lemma dom_node1lay {A} x y (v : A * node) : + x \in dom (node1_lay y v) -> + y <= x. +Proof. +rewrite domPtUn inE=>/andP [_]; case: (y =P x)=>[<-|_] //=. +by rewrite domPt inE /= =>/eqP <-; elim: y. +Qed. + +Lemma node1layK {A} x (v1 v2 : A * node) : + valid (node1_lay x v1) -> + node1_lay x v1 = node1_lay x v2 -> + v1 = v2. +Proof. +case: v1=>a1 n1; case: v2=>a2 n2. +rewrite /node1_lay=>/= V. +by case/(hcancelV V)=><- {}V; move/(hcancelPtV V)=><-. +Qed. + +Lemma node1layV {A} x (v : A * node) : + valid (node1_lay x v) = (x != null). +Proof. +rewrite /node1_lay. +case: (x =P null)=>[->|/eqP N]; first by rewrite validUnAE validPt. +by rewrite !validPtUn !inE N /= -addn1 -{1}(addn0 x) eqn_add2l. +Qed. + +(* layout of unary graph in a heap *) +(* the wrapping conditional is to make graph1_lay *) +(* validity imply validity of g, which frees lemmas *) +(* from dragging excessive validity conditions *) +Definition graph1_lay {A} (g : unary_graph A) : heap := + if valid g then + \big[join/Unit]_(xv <- assocs g) node1_lay xv.1 xv.2 + else undef. + +Lemma graph1lay_sub {A} (g : unary_graph A) : + valid (graph1_lay g) -> + {subset nodes g <= dom (graph1_lay g)}. +Proof. +move=>V x /[dup] Dx /In_domX [v] /In_assocs Ax. +rewrite /graph1_lay (dom_valid Dx) in V *. +rewrite big_domUnE //=; apply: hasPInX Ax _. +by rewrite domPtUn inE node1layV (dom_cond Dx) eqxx. +Qed. + +Lemma graph1layV {A} (g : unary_graph A) : + reflect (valid g /\ + forall x, x \in nodes g -> + x.+1 \notin nodes g) + (valid (graph1_lay g)). +Proof. +have N1 x : x != x.+1 by rewrite -{1}(addn0 x) -addn1 eqn_add2l. +apply: (iffP idP)=>[V|[Vg H]]. +- split=>[|x Dx]; first by rewrite /graph1_lay in V; case: ifP V. + rewrite /graph1_lay/node1_lay big_assocs_dom + (bigD1FE x) (dom_valid Dx) Dx in V. + case: dom_find Dx V=>//= v _ _ _ V. + - rewrite (bigD1FE x.+1) domF eq_sym (negbTE (N1 x)) in V. + by case: dom_find V=>//= v1 _ _; rewrite invalidX. +rewrite /graph1_lay Vg; apply: big_validV2I=>/=. +- exact: Uniq_assocs. +- by case=>x v /In_assocs X; rewrite node1layV (In_cond X). +case=>x vx [y vy] /In_assocs Hx /In_assocs Hy N /=. +have Nxy : x != y by case: eqP Hy N=>// <- /(In_fun Hx) ->. +rewrite validUnAE !node1layV (In_cond Hx) (In_cond Hy) /=. +apply/allP=>/= z. +rewrite !domUn !inE !domPt !inE !validPt2 !N1 !andbT /=. +rewrite (In_cond Hx) (In_cond Hy) /= negb_or. +case/orP=>[/eqP <-|/eqP ->]. +- by rewrite Nxy; case: eqP Hy (H _ (In_dom Hx))=>// -> /In_dom ->. +rewrite !eqSS (eq_sym y) Nxy andbT. +by case: eqP Hx (H _ (In_dom Hy))=>// -> /In_dom ->. +Qed. + +Lemma graph1layVI {A} (g : unary_graph A) : + valid (graph1_lay g) -> + valid g. +Proof. by case/graph1layV. Qed. + +(* key lemma to characterize the pointers in graph1_lay *) +(* must by proved by um_indf, because it relies on *) +(* induction that traverses g in the order of sorting *) +Lemma dom_graph1lay {A} (g : unary_graph A) : + valid (graph1_lay g) -> + dom (graph1_lay g) = + \big[cat/[::]]_(x <- nodes g) [:: x; x.+1]. +Proof. +rewrite /graph1_lay big_assocs_dom. +elim/um_indf: g=>[||/= y w g IH V /(order_path_min trans) Ag] //=. +- by rewrite dom0 !big_nil. +rewrite !(validX V) in IH *. +have L1 z : ord z z.+1 by rewrite /ord /=. +rewrite domPtUnK // !big_cons findPtUn //= => Vg. +set h := (X in _ \+ X) in Vg *. +have Vh : valid h by rewrite (validR Vg). +have E : h = \big[join/Unit]_(x <- nodes g) + if find x g is Some v then node1_lay x v else undef. +- apply: eq_Bigr=>x /mem_seqP Dx _. + rewrite findPtUn2 //; case: (x =P y) Dx=>// ->. + by rewrite (negbTE (validPtUnD V)). +rewrite -E in IH; move: (IH Vh)=>{}IH; rewrite -IH. +have Eg : graph1_lay g = h by rewrite /graph1_lay (validR V) big_assocs_dom. +have Wg : valid (graph1_lay g) by rewrite Eg. +have Y : forall x, x \in nodes g -> y < x by move/allP: Ag; apply. +have Y1 : forall x, x \in nodes g -> y.+1 < x. +- move=>x Dx; rewrite ltnNge leq_eqVlt negb_or -ltnNge ltnS Y // andbT. + case: eqP Dx=>// -> /(graph1lay_sub Wg); rewrite Eg. + by move/(contraL validPtUnD)=>/(_ (idyn w.1)); rewrite (validX Vg). +(* lifting Y, Y1 from nodes g to dom h *) +suff [X X1] : [/\ all (ord y) (dom h) & all (ord y.+1) (dom h)]. +- by rewrite -!joinA !domPtUnK ?(validX Vg) //= L1. +by split; apply/allP=>z; rewrite big_domUn inE (validX Vh) /=; +case/hasP=>x Dx; rewrite findPtUn2 //; +case: (x =P y) Dx (validPtUnD V)=>[<- ->//|_]; +case: (dom_find x g)=>// v /In_find/In_dom /= Dx _ _ _ /dom_node1lay; +apply: leq_trans; [apply: Y|apply: Y1]. +Qed. + +(* morphism-style properties *) + +Lemma graph1lay0 {A} : graph1_lay (Unit : unary_graph A) = Unit. +Proof. by rewrite /graph1_lay assocs0 big_nil. Qed. + +Lemma graph1lay_undef {A} : graph1_lay (undef : unary_graph A) = undef. +Proof. by []. Qed. + +Lemma graph1layPt {A} x (v : A * node) : + graph1_lay (pts x v) = node1_lay x v. +Proof. +rewrite /graph1_lay/node1_lay assocsPt validPt /=. +case: (x =P 0)=>[->|_] /=; first by rewrite pts_condN. +by rewrite big_cons big_nil unitR. +Qed. + +Lemma graph1layUn {A} (g1 g2 : unary_graph A) : + graph1_lay (g1 \+ g2) = graph1_lay g1 \+ graph1_lay g2. +Proof. +case: (normalP (g1 \+ g2))=>[E|V]; last first. +- rewrite /graph1_lay !big_assocs_dom !(validX V) /=. + rewrite (perm_big _ (perm_domUn V)) big_cat /=. + by congr (_ \+ _); apply: eq_Bigr=>x /mem_seqP Dx _; + [rewrite findUnL ?Dx|rewrite findUnR ?Dx]. +rewrite E graph1lay_undef /graph1_lay. +case: ifP=>Vg1; last by rewrite undef_join. +case: ifP=>Vg2; last by rewrite join_undef. +set h1 := (X in X \+ _); set h2 := (X in _ \+ X). +case: (normalP (h1 \+ h2))=>//; case: validUn=>// Vh1 Vh2 Dh _. +have V1 : valid (graph1_lay g1) by rewrite /graph1_lay Vg1 Vh1. +have V2 : valid (graph1_lay g2) by rewrite /graph1_lay Vg2 Vh2. +have : ~~ valid (g1 \+ g2) by rewrite E. +rewrite validUnAE Vg1 Vg2 /=. +case/allPn=>x Dx2 /=; rewrite negbK=>Dx1. +move: (graph1lay_sub V1 Dx1) (graph1lay_sub V2 Dx2). +rewrite /graph1_lay Vg1 Vg2=>Dh1 Dh2. +by move: (Dh x Dh1); rewrite Dh2. +Qed. + +Lemma graph1layPtUn {A} x (v : A * node) (g : unary_graph A) : + graph1_lay (pts x v \+ g) = node1_lay x v \+ graph1_lay g. +Proof. by rewrite graph1layUn graph1layPt. Qed. + +(* graph1lay isn't a PCM morphism formally *) +(* because it doesn't preserve validity *) +(* as valid inputs can map to invalid outputs *) +(* Lemma graph1lay_is_pcm_morphism A : pcm_morph_axiom relT (@graph1_lay A). *) +(* Proof. *) +(* Abort. *) + +(* spatial predicate definition and properties *) + +Definition node1 {A} x (v : A * node) : Pred heap := + eq^~ (node1_lay x v). +Definition graph1 {A} (g : unary_graph A) : Pred heap := + eq^~ (graph1_lay g). + +(* the layout determines the graph *) +(* proof uses dom_graph2lay and um_indf *) +(* to set up induction that depends on node ordering *) +Lemma graph1K {A} (g1 g2 : unary_graph A) h : + valid h -> + h \In graph1 g1 -> + h \In graph1 g2 -> + g1 = g2. +Proof. +move/[swap]=>-> V1; rewrite /graph1=>E. +have V2 : valid (graph1_lay g2) by rewrite -E. +move: (graph1layVI V1) (graph1layVI V2)=>Vg1 Vg2. +have : dom (graph1_lay g1) = dom (graph1_lay g2) by rewrite E. +rewrite !dom_graph1lay //; elim/um_indf: g1 g2 E Vg1 V1 Vg2 V2=> +[||x xs g1 IH V /(order_path_min trans) Ag] g2 E Vg1 V1 Vg2 V2. +- by rewrite big_nil; elim/um_indf: g2 E Vg2 V2. +- rewrite big_nil; elim/um_indf: g2 {E} Vg2 V2=> + [||y ys g2 _ V /(order_path_min trans) Ag2] // Vg2 V2. + by rewrite domPtUnK //= big_cons. +rewrite domPtUnK //= big_cons; elim/um_indf: g2 E V2 Vg2=> +[||y ys g2 IH2 W /(order_path_min trans) Ag2] E V2 Vg2. +- by rewrite big_nil. +- by rewrite big_nil. +rewrite domPtUnK // big_cons; case=>? _; subst y. +rewrite !graph1layPtUn // -!joinA in V1 V2 E. +case/(hcancelV V1): E=>E1 {}V1 /(hcancelV V1) [E2 {}V1] _ /IH -> //. +- by rewrite (validR Vg1). +- by rewrite (validR Vg2). +- by rewrite (validX V2). +by rewrite (prod_eta xs) E1 E2 -prod_eta. +Qed. + +Lemma graph10 {A} : graph1 (Unit : unary_graph A) <~> emp. +Proof. by rewrite /graph1 graph1lay0. Qed. + +Lemma graph1_undef {A} : + graph1 (undef : unary_graph A) <~> eq^~ undef. +Proof. by rewrite /graph1 graph1lay_undef. Qed. + +Lemma graph1Pt {A} x (v : A * node) : + graph1 (pts x v) <~> node1 x v. +Proof. by rewrite /graph1 graph1layPt. Qed. + +Lemma graph1Un {A} (g1 g2 : unary_graph A) : + graph1 (g1 \+ g2) <~> graph1 g1 # graph1 g2. +Proof. +move=>h; split=>[->|[h1][h2][->{h}] ->->]; last by rewrite -graph1layUn. +by exists (graph1_lay g1), (graph1_lay g2); rewrite graph1layUn. +Qed. + +Lemma graph1PtUn {A} x v (g : unary_graph A) : + graph1 (pts x v \+ g) <~> node1 x v # graph1 g. +Proof. by rewrite graph1Un graph1Pt. Qed. + +Lemma In_graph1_eta {A} (g : unary_graph A) x (v : A * node) : + (x, v) \In g -> + graph1 g <~> node1 x v # graph1 (free g x). +Proof. by move/In_eta=>E; rewrite {1}E graph1PtUn. Qed. + +Lemma In_graph1V {A} (g : unary_graph A) h : + h \In graph1 g -> + valid h -> + valid g. +Proof. by move=>->/graph1layVI. Qed. + +Lemma In_graph1V2 {A} (g1 g2 : unary_graph A) h1 h2 : + h1 \In graph1 g1 -> + h2 \In graph1 g2 -> + valid (h1 \+ h2) -> + valid (g1 \+ g2). +Proof. by move=>H1 H2 /In_graph1V; apply; rewrite graph1Un; exists h1, h2. Qed. + + +(*****************) +(*****************) +(* Binary graphs *) +(*****************) +(*****************) + +(* notation for left/right node of x *) +Definition lft A (g : binary_graph A) x := oapp (fst \o snd) null (find x g). +Definition rgh A (g : binary_graph A) x := oapp (snd \o snd) null (find x g). + +(* update left link of binary graph *) +Abbreviation upd2L x l g := (updg x (fun '(a, v) => (a, (l, v.2))) g). +(* update right link of binary graph *) +Abbreviation upd2R x r g := (updg x (fun '(a, v) => (a, (v.1, r))) g). +(* update contents and left link of binary graph *) +Abbreviation upd2CL x a l g := (updg x (fun '(_, v) => (a, (l, v.2))) g). +(* update contents and right link of binary graph *) +Abbreviation upd2CR x a r g := (updg x (fun '(_, v) => (a, (v.1, r))) g). + +Section BinGraphLemmas. +Context {A : Type}. +Implicit Type g : binary_graph A. + +(* structural properties *) + +CoInductive bingraph_spec g x : + bool -> node -> node -> seq node -> Type := +| bingraph_notin of x \notin nodes g : + bingraph_spec g x false null null [::] +| bingraph_in v xs of (x, (v, xs)) \In g : + bingraph_spec g x true xs.1 xs.2 [:: xs.1; xs.2]. + +Lemma In_graph2X g x : + bingraph_spec g x (x \in nodes g) (lft g x) (rgh g x) (adj g x). +Proof. +rewrite /adj/lft/rgh; case: dom_find=>[/In_findN|[k v] /In_find H _]. +- by apply: bingraph_notin. +by apply: bingraph_in H. +Qed. + +Lemma In_graph2 g {x v xs} : + (x, (v, xs)) \In g -> + xs = (lft g x, rgh g x). +Proof. +move/[dup]/In_dom; case: In_graph2X=>// k [l r] H _. +by case/(In_fun H)=>_ <-. +Qed. + +Lemma adj2E g x : + adj g x = + if x \in nodes g then [:: lft g x; rgh g x] else [::]. +Proof. by case: In_graph2X. Qed. + +Lemma In_sinks2 g {x v xs} : + (x, (v, xs)) \In g -> + (xs.1 \in sinks g) * (xs.2 \in sinks g). +Proof. +move/[dup]=>H /In_graph E; split; apply/sinksPA; exists x; +case: In_graph2X E=>//= _ _ /(In_fun H) [_ <-] _; +by rewrite !inE eqxx // orbT. +Qed. + +(* interaction with node update *) + +Lemma lftUg x y f g : + lft (updgf x f g) y = + if find x g is Some v then + if y == x then (f v).2.1 + else lft g y + else null. +Proof. by rewrite /lft findUg; case: (find x g); case: (y =P x). Qed. + +Lemma rghUg x y f g : + rgh (updgf x f g) y = + if find x g is Some v then + if y == x then (f v).2.2 + else rgh g y + else null. +Proof. by rewrite /rgh findUg; case: (find x g); case: (y =P x). Qed. + +(* interaction with union/pts *) + +Lemma lft_undef x : lft (undef : binary_graph A) x = null. +Proof. by []. Qed. + +Lemma rgh_undef x : rgh (undef : binary_graph A) x = null. +Proof. by []. Qed. + +Lemma lft_unit x : lft (Unit : binary_graph A) x = null. +Proof. by []. Qed. + +Lemma rgh_unit x : rgh (Unit : binary_graph A) x = null. +Proof. by []. Qed. + +Lemma lftPt x y v : + lft (pts x v) y = + if valid (ptsT (binary_graph A) x v) && (y == x) then v.2.1 + else null. +Proof. by rewrite /lft findPt2 /= validPt andbC; case: ifP. Qed. + +Lemma rghPt x y v : + rgh (pts x v) y = + if valid (ptsT (binary_graph A) x v) && (y == x) then v.2.2 + else null. +Proof. by rewrite /rgh findPt2 /= validPt andbC; case: ifP. Qed. + +Lemma lftPtUn g x y v : + lft (pts x v \+ g) y = + if valid (pts x v \+ g) then + if y == x then v.2.1 else lft g y + else null. +Proof. +case: (normalP (pts x v \+ _))=>[->//|V]. +by rewrite /lft findPtUn2 //=; case: eqP. +Qed. + +Lemma rghPtUn g x y v : + rgh (pts x v \+ g) y = + if valid (pts x v \+ g) then + if y == x then v.2.2 else rgh g y + else null. +Proof. +case: (normalP (pts x v \+ _))=>[->//|V]. +by rewrite /rgh findPtUn2 //=; case: eqP. +Qed. + +Lemma lftF g x y : + lft (free g x) y = if y == x then null else lft g y. +Proof. by rewrite /lft findF; case: eqP. Qed. + +Lemma rghF g x y : + rgh (free g x) y = if y == x then null else rgh g y. +Proof. by rewrite /rgh findF; case: eqP. Qed. + +(* interaction with other primitives *) + +Lemma lft_erase g x : lft (erase g) x = lft g x. +Proof. by rewrite /lft find_erase; case: (find x g). Qed. + +Lemma rgh_erase g x : rgh (erase g) x = rgh g x. +Proof. by rewrite /rgh find_erase; case: (find x g). Qed. + +Lemma lft_kfilt g p x : + lft (kfilt g p) x = if x \in p then lft g x else null. +Proof. by rewrite /lft find_kfilt; case: ifP. Qed. + +Lemma rgh_kfilt g p x : + rgh (kfilt g p) x = if x \in p then rgh g x else null. +Proof. by rewrite /rgh find_kfilt; case: ifP. Qed. + +End BinGraphLemmas. + +Section BinGraphMap. +Context {A B : Type}. +Implicit Type f : node -> A * (node * node) -> B * (node * node). +Implicit Type g : binary_graph A. + +Lemma lft_graphmap f g x : + lft (graph_map f g) x = + if find x g is Some v then (f x v).2.1 else null. +Proof. by rewrite /lft find_graphmap; case: (find x g). Qed. + +Lemma rgh_graphmap f g x : + rgh (graph_map f g) x = + if find x g is Some v then (f x v).2.2 else null. +Proof. by rewrite /rgh find_graphmap; case: (find x g). Qed. + +End BinGraphMap. + +Section BinGraphCfilt. +Context {A : eqType}. +Implicit Type g : binary_graph A. + +Lemma lft_cfilt g xs x : + lft (cfilt g xs) x = + if find x g is Some v then + if v.1 \in xs then v.2.1 else null + else null. +Proof. by rewrite /lft find_cfilt; case: (find x g)=>//= v; case: ifP. Qed. + +Lemma rgh_cfilt g xs x : + rgh (cfilt g xs) x = + if find x g is Some v then + if v.1 \in xs then v.2.2 else null + else null. +Proof. by rewrite /rgh find_cfilt; case: (find x g)=>//= v; case: ifP. Qed. + +End BinGraphCfilt. + +Section BinGraphClosed. +Context {A : Type}. +Implicit Type g : binary_graph A. + +Lemma In_closed2 x v xl xr g : + (x, (v, (xl, xr))) \In g -> + reflect [/\ xl \in nodes0 g, xr \in nodes0 g & + {subset sinks (free g x) <= nodes0 g}] + (closed g). +Proof. +move=>H; case: (In_closed H). +- by case=>X1 X2; constructor; rewrite !X1 // !inE /= eqxx ?orbT. +move=>X; constructor; case=>Xl Xr S; apply: X. +by split=>// z; rewrite !inE /=; case/orP=>/eqP ->. +Qed. + +Lemma closed2_links x v xl xr g : + (x, (v, (xl, xr))) \In g -> + closed g -> + (xl \in nodes0 g) * (xr \in nodes0 g). +Proof. by move=>H /(In_closed2 H) []. Qed. + +Lemma In_closed2PtUn x v xl xr g : + x \in nodes g -> + closed g -> + closed (pts x (v, (xl, xr)) \+ free g x) = + [&& xl \in nodes0 g & xr \in nodes0 g]. +Proof. +move=>H C; case: (In_closedPtUn H C). +- by move=>S; rewrite !S // !inE /= eqxx ?orbT. +move=>X. apply/esym/negP=>/andP [H1 H2]; elim: X. +by move=>z; rewrite !inE /= =>/orP [] /eqP ->. +Qed. + +End BinGraphClosed. + +Arguments In_closed2PtUn {A x v xl xr g}. + +(**********************) +(**********************) +(* Spatial predicates *) +(**********************) +(**********************) + +(* layout for binary graphs *) + +Definition node2_lay {A} x (v : A * (node * node)) : heap := + x :-> v.1 \+ (x.+1 :-> v.2.1 \+ x.+2 :-> v.2.2). + +Lemma dom_node2lay {A} x y (v : A * (node * node)) : + x \in dom (node2_lay y v) -> + y <= x. +Proof. +rewrite domPtUn inE=>/andP [_]; case: (y =P x)=>[<-|_] //=. +rewrite domPtUn inE=>/andP [_]; case: (y.+1 =P x)=>[<-|_] //=. +by rewrite domPt inE /= =>/eqP <-; elim: y. +Qed. + +Lemma node2layK {A} x (v1 v2 : A * (node * node)) : + valid (node2_lay x v1) -> + node2_lay x v1 = node2_lay x v2 -> + v1 = v2. +Proof. +case: v1=>a1 [l1 r1]; case: v2=>a2 [l2 r2]. +rewrite /node2_lay=>/= V. +by do 2![case/(hcancelV V)=><- {}V]; move/(hcancelPtV V)=><-. +Qed. + +Lemma node2layV {A} x (v : A * (node * node)) : + valid (node2_lay x v) = (x != null). +Proof. +rewrite /node2_lay. +case: (x =P null)=>[->|/eqP N]; first by rewrite validUnAE validPt. +rewrite !validPtUn !inE domPtUn !inE /= validPtUn inE /=. +rewrite negb_and negbK negb_or {}N andb_orr andNb /=. +by rewrite -addn2 -addn1 -{4 5}(addn0 x) !eqn_add2l. +Qed. + +(* layout of binary graph in a heap *) +(* the wrapping conditional is to make graph2_lay *) +(* validity imply validity of g, which frees lemmas *) +(* from dragging excessive validity conditions *) +Definition graph2_lay {A} (g : binary_graph A) : heap := + if valid g then + \big[join/Unit]_(xv <- assocs g) node2_lay xv.1 xv.2 + else undef. + +Lemma graph2lay_sub {A} (g : binary_graph A) : + valid (graph2_lay g) -> + {subset nodes g <= dom (graph2_lay g)}. +Proof. +move=>V x /[dup] Dx /In_domX [v] /In_assocs Ax. +rewrite /graph2_lay (dom_valid Dx) in V *. +rewrite big_domUnE //=; apply: hasPInX Ax _. +by rewrite domPtUn inE node2layV (dom_cond Dx) eqxx. +Qed. + +Lemma graph2layV {A} (g : binary_graph A) : + reflect (valid g /\ + forall x, x \in nodes g -> + x.+1 \notin nodes g /\ + x.+2 \notin nodes g) + (valid (graph2_lay g)). +Proof. +have N1 x : x != x.+1 by rewrite -{1}(addn0 x) -addn1 eqn_add2l. +have N2 x : x != x.+2 by rewrite -{1}(addn0 x) -addn2 eqn_add2l. +apply: (iffP idP)=>[V|[Vg H]]. +- split=>[|x Dx]; first by rewrite /graph2_lay in V; case: ifP V. + rewrite /graph2_lay/node2_lay big_assocs_dom + (bigD1FE x) (dom_valid Dx) Dx in V. + case: dom_find Dx V=>//= v _ _ _; split. + - rewrite (bigD1FE x.+1) domF eq_sym (negbTE (N1 x)) in V. + by case: dom_find V=>//= v1 _ _; rewrite invalidX. + rewrite (bigD1FE x.+2) domF eq_sym (negbTE (N2 x)) in V. + by case: dom_find V=>//= v2 _ _; rewrite invalidX. +rewrite /graph2_lay Vg; apply: big_validV2I=>/=. +- exact: Uniq_assocs. +- by case=>x v /In_assocs X; rewrite node2layV (In_cond X). +case=>x vx [y vy] /In_assocs Hx /In_assocs Hy N /=. +have Nxy : x != y by case: eqP Hy N=>// <- /(In_fun Hx) ->. +rewrite validUnAE !node2layV (In_cond Hx) (In_cond Hy) /=. +apply/allP=>/= z. +rewrite !domUn !inE !domPt !inE !domPt2 !inE /= !N1 /=. +rewrite (In_cond Hx) (In_cond Hy) /=. +case/andP=>Vy Dy; apply/negP=>/andP [Vx]. +case/or3P: Dy=>[/eqP <-|/eqP ->|/eqP ->]. +- rewrite (negbTE Nxy) /= => X. + by case/orP: X Hy (H _ (In_dom Hx))=>/eqP <- /In_dom -> []. +- rewrite !eqSS (eq_sym y) (negbTE Nxy) /= => X. + by case/orP: X Hx Hy (H _ (In_dom Hy)) (H _ (In_dom Hx))=> + /eqP <-; [move/In_dom=>-> _ []|move=>_ /In_dom-> _ []]. +rewrite !eqSS (eq_sym y) (negbTE Nxy) orbF => X. +by case/orP: X Hx Hy (H _ (In_dom Hy)) (H _ (In_dom Hx))=> +/eqP <- /In_dom -> _ []. +Qed. + +Lemma graph2layVI {A} (g : binary_graph A) : + valid (graph2_lay g) -> + valid g. +Proof. by case/graph2layV. Qed. + +(* key lemma to characterize the pointers in graph2_lay *) +(* must by proved by um_indf, because it relies on *) +(* induction that traverses g in the order of sorting *) +Lemma dom_graph2lay {A} (g : binary_graph A) : + valid (graph2_lay g) -> + dom (graph2_lay g) = + \big[cat/[::]]_(x <- nodes g) [:: x; x.+1; x.+2]. +Proof. +rewrite /graph2_lay big_assocs_dom. +elim/um_indf: g=>[||/= y w g IH V /(order_path_min trans) Ag] //=. +- by rewrite dom0 !big_nil. +rewrite !(validX V) in IH *. +have L1 z : ord z z.+1 by rewrite /ord /=. +have L2 z : ord z z.+2 by rewrite /ord /=. +rewrite domPtUnK // !big_cons findPtUn //= => Vg. +set h := (X in _ \+ X) in Vg *. +have Vh : valid h by rewrite (validR Vg). +have E : h = \big[join/Unit]_(x <- nodes g) + if find x g is Some v then node2_lay x v else undef. +- apply: eq_Bigr=>x /mem_seqP Dx _. + rewrite findPtUn2 //; case: (x =P y) Dx=>// ->. + by rewrite (negbTE (validPtUnD V)). +rewrite -E in IH; move: (IH Vh)=>{}IH; rewrite -IH. +have Eg : graph2_lay g = h by rewrite /graph2_lay (validR V) big_assocs_dom. +have Wg : valid (graph2_lay g) by rewrite Eg. +have Y : forall x, x \in nodes g -> y < x by move/allP: Ag; apply. +have Y1 : forall x, x \in nodes g -> y.+1 < x. +- move=>x Dx; rewrite ltnNge leq_eqVlt negb_or -ltnNge ltnS Y // andbT. + case: eqP Dx=>// -> /(graph2lay_sub Wg); rewrite Eg. + by move/(contraL validPtUnD)=>/(_ (idyn w.1)); rewrite (validX Vg). +have Y2 : forall x, x \in nodes g -> y.+2 < x. +- move=>x Dx; rewrite ltnNge leq_eqVlt negb_or -ltnNge ltnS Y1 // andbT. + case: eqP Dx=>// -> /(graph2lay_sub Wg); rewrite Eg. + by move/(contraL validPtUnD)=>/(_ (idyn w.2)); rewrite (validX Vg). +(* lifting Y, Y1, Y2 from nodes g to dom h *) +suff [X X1 X2] : [/\ all (ord y) (dom h), + all (ord y.+1) (dom h) & all (ord y.+2) (dom h)]. +- by rewrite -!joinA !domPtUnK ?(validX Vg) //= ?L1 ?L2. +by split; apply/allP=>z; rewrite big_domUn inE (validX Vh) /=; +case/hasP=>x Dx; rewrite findPtUn2 //; +case: (x =P y) Dx (validPtUnD V)=>[<- ->//|_]; +case: (dom_find x g)=>// v /In_find/In_dom /= Dx _ _ _ /dom_node2lay; +apply: leq_trans; [apply: Y|apply: Y1|apply: Y2]. +Qed. + +(* morphism-style properties *) + +Lemma graph2lay0 {A} : graph2_lay (Unit : binary_graph A) = Unit. +Proof. by rewrite /graph2_lay assocs0 big_nil. Qed. + +Lemma graph2lay_undef {A} : graph2_lay (undef : binary_graph A) = undef. +Proof. by []. Qed. + +Lemma graph2layPt {A} x (v : A * (node * node)) : + graph2_lay (pts x v) = node2_lay x v. +Proof. +rewrite /graph2_lay/node2_lay assocsPt validPt /=. +case: (x =P 0)=>[->|_] /=; first by rewrite pts_condN. +by rewrite big_cons big_nil unitR. +Qed. + +Lemma graph2layUn {A} (g1 g2 : binary_graph A) : + graph2_lay (g1 \+ g2) = graph2_lay g1 \+ graph2_lay g2. +Proof. +case: (normalP (g1 \+ g2))=>[E|V]; last first. +- rewrite /graph2_lay !big_assocs_dom !(validX V) /=. + rewrite (perm_big _ (perm_domUn V)) big_cat /=. + by congr (_ \+ _); apply: eq_Bigr=>x /mem_seqP Dx _; + [rewrite findUnL ?Dx|rewrite findUnR ?Dx]. +rewrite E graph2lay_undef /graph2_lay. +case: ifP=>Vg1; last by rewrite undef_join. +case: ifP=>Vg2; last by rewrite join_undef. +set h1 := (X in X \+ _); set h2 := (X in _ \+ X). +case: (normalP (h1 \+ h2))=>//; case: validUn=>// Vh1 Vh2 Dh _. +have V1 : valid (graph2_lay g1) by rewrite /graph2_lay Vg1 Vh1. +have V2 : valid (graph2_lay g2) by rewrite /graph2_lay Vg2 Vh2. +have : ~~ valid (g1 \+ g2) by rewrite E. +rewrite validUnAE Vg1 Vg2 /=. +case/allPn=>x Dx2 /=; rewrite negbK=>Dx1. +move: (graph2lay_sub V1 Dx1) (graph2lay_sub V2 Dx2). +rewrite /graph2_lay Vg1 Vg2=>Dh1 Dh2. +by move: (Dh x Dh1); rewrite Dh2. +Qed. + +Lemma graph2layPtUn {A} x (v : A * (node * node)) (g : binary_graph A) : + graph2_lay (pts x v \+ g) = node2_lay x v \+ graph2_lay g. +Proof. by rewrite graph2layUn graph2layPt. Qed. + +(* graph2lay isn't a PCM morphism formally *) +(* because it doesn't preserve validity *) +(* as valid inputs can map to invalid outputs *) +Lemma graph2lay_is_pcm_morphism A : pcm_morph_axiom relT (@graph2_lay A). +Proof. +split=>[|x y V _]; first by rewrite /graph2_lay assocs0 big_nil. +rewrite -graph2layUn //; split=>//. +Abort. + +(* spatial predicate definition and properties *) + +Definition node2 {A} x (v : A * (node * node)) : Pred heap := + eq^~ (node2_lay x v). +Definition graph2 {A} (g : binary_graph A) : Pred heap := + eq^~ (graph2_lay g). + +(* the layout determines the graph *) +(* proof uses dom_graph2lay and um_indf *) +(* to set up induction that depends on node ordering *) +Lemma graph2K {A} (g1 g2 : binary_graph A) h : + valid h -> + h \In graph2 g1 -> + h \In graph2 g2 -> + g1 = g2. +Proof. +move/[swap]=>-> V1; rewrite /graph2=>E. +have V2 : valid (graph2_lay g2) by rewrite -E. +move: (graph2layVI V1) (graph2layVI V2)=>Vg1 Vg2. +have : dom (graph2_lay g1) = dom (graph2_lay g2) by rewrite E. +rewrite !dom_graph2lay //; elim/um_indf: g1 g2 E Vg1 V1 Vg2 V2=> +[||x xs g1 IH V /(order_path_min trans) Ag] g2 E Vg1 V1 Vg2 V2. +- by rewrite big_nil; elim/um_indf: g2 E Vg2 V2. +- rewrite big_nil; elim/um_indf: g2 {E} Vg2 V2=> + [||y ys g2 _ V /(order_path_min trans) Ag2] // Vg2 V2. + by rewrite domPtUnK //= big_cons. +rewrite domPtUnK //= big_cons; elim/um_indf: g2 E V2 Vg2=> +[||y ys g2 IH2 W /(order_path_min trans) Ag2] E V2 Vg2. +- by rewrite big_nil. +- by rewrite big_nil. +rewrite domPtUnK // big_cons; case=>? _ _; subst y. +rewrite !graph2layPtUn // -!joinA in V1 V2 E. +case/(hcancelV V1): E=>E1 {}V1 /(hcancelV V1) [E2 {}V1]. +case/(hcancelV V1)=>E3 {}V1 E /IH -> //. +- by rewrite (validR Vg1). +- by rewrite (validR Vg2). +- by rewrite (validX V2). +by rewrite (prod_eta xs) (prod_eta xs.2) E1 E2 E3 -!prod_eta. +Qed. + +Lemma graph20 {A} : graph2 (Unit : binary_graph A) <~> emp. +Proof. by rewrite /graph2 graph2lay0. Qed. + +Lemma graph2_undef {A} : + graph2 (undef : binary_graph A) <~> eq^~ undef. +Proof. by rewrite /graph2 graph2lay_undef. Qed. + +Lemma graph2Pt {A} x (v : A * (node * node)) : + graph2 (pts x v) <~> node2 x v. +Proof. by rewrite /graph2 graph2layPt. Qed. + +Lemma graph2Un {A} (g1 g2 : binary_graph A) : + graph2 (g1 \+ g2) <~> graph2 g1 # graph2 g2. +Proof. +move=>h; split=>[->|[h1][h2][->{h}] ->->]; last by rewrite -graph2layUn. +by exists (graph2_lay g1), (graph2_lay g2); rewrite graph2layUn. +Qed. + +Lemma graph2PtUn {A} x v (g : binary_graph A) : + graph2 (pts x v \+ g) <~> node2 x v # graph2 g. +Proof. by rewrite graph2Un graph2Pt. Qed. + +Lemma In_graph2_eta {A} (g : binary_graph A) x (v : A * (node * node)) : + (x, v) \In g -> + graph2 g <~> node2 x v # graph2 (free g x). +Proof. by move/In_eta=>E; rewrite {1}E graph2PtUn. Qed. + +Lemma In_graph2V {A} (g : binary_graph A) h : + h \In graph2 g -> + valid h -> + valid g. +Proof. by move=>->/graph2layVI. Qed. + +Lemma In_graph2V2 {A} (g1 g2 : binary_graph A) h1 h2 : + h1 \In graph2 g1 -> + h2 \In graph2 g2 -> + valid (h1 \+ h2) -> + valid (g1 \+ g2). +Proof. +by move=>H1 H2 /In_graph2V; apply; rewrite graph2Un; exists h1, h2. +Qed. + diff --git a/examples/schorr.v b/examples/schorr.v new file mode 100644 index 0000000..a7f2991 --- /dev/null +++ b/examples/schorr.v @@ -0,0 +1,278 @@ +(* +Copyright 2025 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. +*) + +From HB Require Import structures. +From Stdlib Require Import ssreflect ssrfun. +From mathcomp Require Import eqtype ssrnat ssrbool seq path bigop. +From pcm Require Import options axioms pred prelude seqperm seqext. +From pcm Require Import pcm unionmap natmap heap auto autouniq autopcm automap. +From htt Require Import options model heapauto graph. + +(****************) +(* Schorr-Waite *) +(****************) + +(* type of markings *) +(* O = unmarked *) +(* L = traversal of left subgraph started *) +(* R = left subgraph finished, traversal of right subgraph started *) +(* X = both subgraphs finished *) +Inductive mark := O | L | R | X. + +(* decidable equality on marks *) +Definition eq_mark c1 c2 : bool := + if (c1, c2) is ((O,O)|(L,L)|(R,R)|(X,X)) then true else false. +Lemma eq_markP : Equality.axiom eq_mark. +Proof. by case; case=>//; constructor. Qed. +HB.instance Definition _ := hasDecEq.Build mark eq_markP. + +Implicit Type g : binary_graph mark. + +Notation "g /LR" := (cfilt g [:: L; R]) (at level 1, format "g /LR"). +Notation "g /O" := (cfilt g [:: O]) (at level 1, format "g /O"). +Notation "g /X" := (cfilt g [:: X]) (at level 1, format "g /X"). +Notation "g /OLR" := (cfilt g [:: O; L; R]) (at level 1, format "g /OLR"). +Abbreviation marked0 g := (nodes0 (cfilt g [:: L; R; X])). + +Definition if_mark (f : node -> node) x '(m, (l, r)) := + (tt, match m with L => (f x, r) | R => (l, f x) | _ => (l, r) end). + +Definition inset a := graph_map (if_mark (prev (null :: a))). +HB.instance Definition _ a := MapFun.on (inset a). +Definition restore a t := graph_map (if_mark (next (rcons a t))). +HB.instance Definition _ a t := MapFun.on (restore a t). + +Lemma eq_ifmark f1 f2 g : + {in nodes g/LR, f1 =1 f2} -> + graph_map (if_mark f1) g = graph_map (if_mark f2) g. +Proof. by rewrite /if_mark -eq_in_graphmap=>+x [[]]//v /nodes_cfilt X=>->. Qed. + +Lemma ifmark_erase f g : + nodes g/LR =i [::] -> + graph_map (if_mark f) g = erase g. +Proof. by rewrite -eq_in_graphmap=>+ k [][][??]/(nodes_cfilt [::L;R])=>->. Qed. + +Lemma inset_rcons a p g : + nodes g/LR =i a -> + inset (rcons a p) g = inset a g. +Proof. by move=>S; apply/eq_ifmark=>x; rewrite S /= prevat_rcons=>->. Qed. + +Lemma restore_rcons a p t g : + nodes g/LR =i a -> + restore (rcons a p) t g = restore a p g. +Proof. by move=>S; apply/eq_ifmark=>x; rewrite S next_rcons=>->. Qed. + +Definition inv' g0 g a t p := + [/\ p = last null a, uniq (null :: a), t \in nodes0 g, + closed g, + inset a g = erase g, + restore a t g = erase g0, + nodes g/LR =i a & + {subset nodes g/O <= + [predU \big[cat/[::]]_(x <- a) (reach g/O (rgh g x)) & reach g/O t]}]. + +Definition inv g0 g t p := exists a, inv' g0 g a t p. + +(*******************************) +(* Schorr-Waite code and proof *) +(*******************************) + +Program Definition push (t p : node) : + STsep {g0} (fun h => exists g, + [/\ graph2 g h, inv g0 g t p & t \notin marked0 g], + [vfun tp h => exists g, h \In graph2 g /\ inv g0 g tp.1 tp.2]) := + Do (tmp <-- read node t.+1; + t.+1 ::= p;; + t ::= L;; + ret (tmp, t)). +Next Obligation. +move=>t p [/= g0][i][g][+ I M]; case: I=>a [Ep U + C I Rx N Ro]. +rewrite (nodes0_cfiltC [::O] M)=>[[]|]///In_dom_umfilt [[[]]]//[tl tr] _ T. +move: (In_eta T) (In_valid T)=>/[dup] E -> V /graph2PtUn [_][h][->-> H]. +do ![step]=>_; set g' := pts t (L, (p, tr)) \+ free g t; exists g'. +split=>[|{h H}]; first by rewrite graph2PtUn; eexists _, h. +have Ta : (t \in a) = false by rewrite -N; apply/negbTE/nodes0_cfiltSN/M. +have S : nodes (free g t)/LR =i a. +- by move=>z; rewrite dom_umfiltF N; case: eqP Ta=>// ->. +exists (rcons a t); rewrite /inv' 3!omfPtUn !(validX V) /= prevat_rcons +next_rcons eqxx Ta last_rcons; split=>//=. +- by rewrite !(uniqX U) -N eq_sym -negb_or -in_cons (nodes00_cfiltSN _ M). +- by rewrite -(domPtUnE2 t (O, (tl, tr))) -E (closed2_links T). +- rewrite (In_closed2PtUn (In_dom T) C) (closed2_links T C) andbT. + by move/last_mem: Ep; rewrite -N; apply: omf_subdom0. +- by rewrite -Ep !omfF /= inset_rcons ?I. +- by rewrite -Rx {2}E mfPtUn restore_rcons. +- by move=>z; rewrite dom_omfPtUn inE (validX V) S mem_rcons. +move=>z; rewrite omfPtUn big_rcons rghPtUn (validX V) eqxx !omfF domF=>/andP +[/negbTE Nzt /Ro]; rewrite !inE mem_cat -orbA /= => /orPr [[Dz]|]. +- rewrite !big_cat_mem_has=>/hasP [x X] Z; apply/or3P/Or31/hasP; exists x=>//. + by rewrite (reach_avoid1 Dz) E !rghPtUn !(validX V) in Z *. +rewrite reachEA (nodes_cfilt _ T) Nzt=>/hasP [x /adj_cfiltS]. +by rewrite (In_graph T) !inE=>/orP [] /eqP ->->; rewrite ?orbT. +Qed. + +Program Definition swing (t p : node) : + STsep {g0} (fun h => exists g, + [/\ h \In graph2 g, inv g0 g t p, t \in marked0 g & (p, L) \In labels g], + [vfun tp h => exists g, h \In graph2 g /\ inv g0 g tp.1 tp.2]) := + Do (tmp1 <-- read node p.+2; + tmp2 <-- read node p.+1; + p.+2 ::= tmp2;; + p.+1 ::= t;; + p ::= R;; + ret (tmp1, p)). +Next Obligation. +move=>t p [/= g0][i][g][+ I M] /In_labelsX -[[pl pr]] P. +move: (In_eta P) (In_valid P)=>/[dup] E -> V /graph2PtUn [_][h][->-> H]. +do ![step]=>_; set g' := (pts p (R, (t, pl)) \+ free g p); exists g'. +split=>[|{h H}]; first by rewrite graph2PtUn; eexists _, h. +case: I=>_ [/(rcons_lastN (In_cond P)) [a ->] U /= Dt C I Rx N Ro]. +have Lp : lft g p = pl by rewrite E /lft findPtUn. +have Na : (p \in a) = false by rewrite (uniqX U). +have Npl : pl = last null a by rewrite -Lp -lft_erase -I + lft_graphmap (In_findE P) /= prevat_rcons eqxx Na. +have S : nodes (free g p)/LR =i a. +- by move=>z; rewrite dom_umfiltF N mem_rcons inE; case: eqP Na=>//= ->->. +exists (rcons a p); rewrite /inv' last_rcons (uniqX U) 3!omfPtUn (validX V) /= +prevat_rcons next_rcons eqxx Na; split=>//=. +- by rewrite -(domPtUnE2 p (L, (pl, pr))) -E (closed2_links P). +- by rewrite (In_closed2PtUn (In_dom P) C) Dt (closed2_links P C). +- by rewrite !omfF /= I -Npl. +- by rewrite -Rx {2}E !mfPtUn /= next_rcons Na eqxx !restore_rcons. +- by move=>z; rewrite dom_omfPtUn inE (validX V) S mem_rcons. +move=>z; rewrite omfPtUn omfF (validX V) domF=>/andP [Nzp /Ro]; rewrite !inE +reachDN ?(nodes0_cfiltN _ M) ?orbF // !big_rcons !mem_cat {1 3 4}E omfPtUn +omfF rghPtUn ?(validX V) eqxx -orbA /= => /orP [Z|->]; last by rewrite ?orbT. +apply/or3P/Or31; congr (z \in _): Z; apply: eq_bigR=>w W _. +by rewrite rghPtUn (validX V) rghF; case: eqP W Na=>// ->->. +Qed. + +Program Definition pop (t p : node) : + STsep {g0} (fun h => exists g, + [/\ h \In graph2 g, inv g0 g t p, t \in marked0 g & (p, R) \In labels g], + [vfun tp h => exists g, h \In graph2 g /\ inv g0 g tp.1 tp.2]) := + Do (tmp <-- read node p.+2; + p.+2 ::= t;; + p ::= X;; + ret (p, tmp)). +Next Obligation. +move=>t p [/= g0][i][g][+ I M] /In_labelsX [[pl pr] P]. +move: (In_eta P) (In_valid P)=>/[dup] E -> V /graph2PtUn [_][h][->-> H]. +do ![step]=>_; set g' := pts p (X, (pl, t)) \+ free g p; exists g'. +split=>[|{h H}]; first by rewrite graph2PtUn; eexists _, h. +case: I=>_ [/(rcons_lastN (In_cond P)) [a ->] U /= Dt C I Rx N Ro]. +have Rp : rgh g p = pr by rewrite E /rgh findPtUn. +have Na : (p \in a) = false by rewrite (uniqX U). +have Npr : pr = last null a by rewrite -Rp -rgh_erase -I + rgh_graphmap (In_findE P) /= prevat_rcons eqxx Na. +have Pr : pr \in nodes0 g/LR. +- by rewrite inE N mem_rcons inE orbCA orbC Npr last_mem. +have S : nodes (free g p)/LR =i a. +- by move=>z; rewrite dom_umfiltF N mem_rcons inE; case: eqP Na=>//->->. +exists a; rewrite /inv' (uniqX U) !omfPtUn nodes0PtUn ?(validX V) ?eqxx //=. +split=>//; first by rewrite (In_closed2PtUn (In_dom P) C) (closed2_links P C). +- by rewrite -(inset_rcons p S) !omfF /= I. +- by rewrite -Rx {2}E mfPtUn /= next_rcons Na eqxx -(restore_rcons p t). +rewrite omfF freeND ?reachDN ?(nodes_cfilt _ P) //= => z /Ro. +rewrite !inE big_rcons mem_cat !reachDN ?orbF ?(nodes0_cfiltN _ M) ?Rp +?(nodes0_cfiltN _ Pr) //=; congr (_ \in _); apply: eq_bigR=>w W _. +by rewrite rghPtUn (validX V) rghF; case: eqP W Na=>// ->->. +Qed. + +Program Definition read_mark (t p : node) : + STsep {g0} (fun h => exists g, h \In graph2 g /\ inv g0 g t p, + [vfun tm h => exists g, [/\ h \In graph2 g, inv g0 g t p & + tm = (t \in marked0 g)]]) := + Do (if t == null then ret true + else v <-- read mark t; + ret (v != O)). +Next Obligation. +move=>t p [g0][i][g][/[swap]]/[dup]-[a][_ _ + _ _ _ _ _]; rewrite inE /=. +case: eqP=>[-> *|/eqP N /In_domX [[v tx]] T I]; first by step; exists g. +move: (In_eta T)=>/[dup] E -> /graph2PtUn [_][h][->-> H]; do ![step]=>_. +exists g; split=>//; first by rewrite E graph2PtUn; eexists _, h. +by rewrite inE (negbTE N) (nodes_cfilt _ T); case: v {E T}. +Qed. + +(* Precondition of loopTp is the loop invariant. *) +(* In the imperative code (in the paper), *) +(* the loop invariant also keeps tm = t \in marked0 g *) +(* but that's unnecessary in functional code. *) +Definition loopTp := forall tp, STsep {g0} + (fun h => exists g, h \In graph2 g /\ inv g0 g tp.1 tp.2, + [vfun (_ : unit) h => exists g, [/\ h \In graph2 g, + erase g0 = erase g & g/X = g]]). + +(* main program *) + +(* specification for connected graphs *) +Program Definition schorr_waite_connect (r : node) : + STsep {g0} (fun h => [/\ h \In graph2 g0, closed g0, + r \in nodes g0 & nodes g0 =i reach g0/O r], + [vfun _ h => exists g, [/\ h \In graph2 g, + erase g0 = erase g & g/X = g]]) := + Do (let loop := ffix (fun (loop : loopTp) '(t, p) => + Do (tm <-- read_mark t p; + if tm && (p == null) then ret tt + else + tp <-- if tm then + pm <-- read mark p; + if pm is R then pop t p : ST _ + else swing t p + else push t p; + loop tp)) + in loop (r, null)). +Next Obligation. +(* proof outline in the paper *) +move=>r loop _ t p [g0][i H]; apply: [stepE g0]=>//= tm {H}i [g][H I ->]. +case: ifPn=>[/andP [T /eqP P]|X]; last first. +- apply: [bnd_vrf g0]=>//; case: ifPn X=>/= T P; last first. + - by apply: [gE g0]=>//; exists g. + by case: (I)=>a [/last_mem Ep ????? Na _]; move: Na Ep P H=><- /orP [->//|] + /In_domX [[pm [pl pr]]] /In_umfiltX [X /[dup] P] /In_eta/[dup] E -> _ + /graph2PtUn [_][h][->-> H]; step; case: pm E X P=>//= E _ /In_labels P; + apply: [gE g0]=>//; exists g; split=>//; rewrite E graph2PtUn; eexists _, h. +(* line 31 implies line 32 in the paper *) +step=>V; exists g; case: I P=>a [-> U _ _ _ <- ++] /last_nochange_nil P. +move/andX: U P=>->-> // Na S; split=>//; first by apply: ifmark_erase. +apply/id_cfiltD/domE/(nodes_cfiltCE [::O;L;R]); first by case. +rewrite cfilt_cons // (dom0E _ Na) ?pfVE ?(In_graph2V H V) // unitR => z. +by apply/negP=>/S; rewrite big_nil=>/reachD1/(nodes0_cfiltNX _ T); apply. +Qed. +Next Obligation. +(* line 1 implies line 2 in the paper *) +move=>r [g0][/= i][H C Rn E]; apply: [gE g0]=>//=; exists g0; split=>//. +have Na : nodes g0/LR =i [::] by move=>z; rewrite (nodes_cfiltX O) E; + apply/andP=>-[/reachD2]; rewrite (nodes_cfiltX O) andbC; case: (odflt _). +exists [::]; rewrite /inv' inE Rn orbT; split=>//; try by apply: ifmark_erase. +by move=>z; rewrite (nodes_cfiltX O) E inE big_nil=>/andP []. +Qed. + +(* framed specification for general graphs *) +Program Definition schorr_waite (r : node) : + STsep {g0} (fun h => + [/\ h \In graph2 g0, closed g0, r \in nodes g0 & g0/O = g0], + [vfun _ h => exists g, [/\ h \In graph2 g, + erase g0 = erase g, g/X \+ g/O = g & nodes g/X =i reach g0 r]]) := + Do (schorr_waite_connect r). +Next Obligation. +move=>r [g0][i][]; set x := [in reach g0 r]; set g1 := kfilt g0 x. +set g2 := kfilt g0 [predC x]=>H C N Eg; apply: vrfV=>/(In_graph2V H) V /=. +rewrite (kfiltC g0 x) graph2Un in H C N; case: H=>h1 [h2][-> H1 H2]. +case/(closed_reachUnX C): N=>[z|{}C N En]; first by rewrite nodes_reach -kfiltC. +apply: [gR g1] @ h1=>[|[u1][k1][U K Ek]|] //=; first by rewrite ckfilt Eg. +by move/(In_graph2V2 U H2)=>W; exists (k1 \+ g2); rewrite !omfUn //= Ek !ckfilt +-[in _/O]Ek -Eg !cfilt_predI !cfilt_nil ?(validX W) // pfunit Eg unitL unitR +-(nodes_erase k1) -K -mfUn dom_mf -kfiltC graph2Un; hhauto; apply: nodes_reach. +Qed. + From d093d8b14c5e9ae8fed1f30fd8c53aa9d644c9ee Mon Sep 17 00:00:00 2001 From: Aleksandar Nanevski Date: Thu, 6 Aug 2026 16:26:11 +0200 Subject: [PATCH 04/17] renaming coq -> rocq --- examples/Makefile | 7 +++++++ 1 file changed, 7 insertions(+) create mode 100644 examples/Makefile diff --git a/examples/Makefile b/examples/Makefile new file mode 100644 index 0000000..103b008 --- /dev/null +++ b/examples/Makefile @@ -0,0 +1,7 @@ +# -*- Makefile -*- + +# setting variables +COQPROJECT?=Make + +# Main Makefile +include ../Makefile.common From 4cc8a844446708685b3430efa6885f916348e642 Mon Sep 17 00:00:00 2001 From: Aleksandar Nanevski Date: Thu, 6 Aug 2026 16:26:26 +0200 Subject: [PATCH 05/17] renaming coq -> rocq --- Makefile.common | 99 +++++++++++++++++++++++++++++++++++++++++++++++ coq-htt-core.opam | 15 +++---- coq-htt.opam | 14 ++++--- htt/Makefile | 7 ++++ 4 files changed, 122 insertions(+), 13 deletions(-) create mode 100644 Makefile.common create mode 100644 htt/Makefile diff --git a/Makefile.common b/Makefile.common new file mode 100644 index 0000000..aea0e16 --- /dev/null +++ b/Makefile.common @@ -0,0 +1,99 @@ +# -*- Makefile -*- + +###################################################################### +# USAGE: # +# The rules this-config::, this-build::, this-distclean::, # +# pre-makefile::, this-clean:: and __always__:: may be extended # +# Additionally, the following variables may be customized: # +SUBDIRS?= +ROCQBIN?=$(dir $(shell which rocq)) +ROCQMAKEFILE?=$(ROCQBIN)rocq_makefile +ROCQDEP?=$(ROCQBIN)rocq dep +ROCQPROJECT?=_RocqProject +ROCQMAKEOPTIONS?= +ROCQMAKEFILEOPTIONS?= +V?= +VERBOSE?=V +###################################################################### + +# local context: ----------------------------------------------------- +.PHONY: all config build clean distclean __always__ +.SUFFIXES: + +H:= $(if $(VERBOSE),,@) # not used yet +TOP = $(dir $(lastword $(MAKEFILE_LIST))) +ROCQMAKE = $(MAKE) -f Makefile.rocq $(ROCQMAKEOPTIONS) +BRANCH_rocq:= $(shell $(ROCQBIN)rocq top -v | head -1 | grep -E '(trunk|master)' \ + | wc -l | sed 's/ *//g') + +# rocq version: +ifneq "$(BRANCH_rocq)" "0" +ROCQVVV:= dev +else +ROCQVVV:=$(shell $(ROCQBIN)rocq top --print-version | cut -d" " -f1) +endif + +ROCQV:= $(shell echo $(ROCQVVV) | cut -d"." -f1) +ROCQVV:= $(shell echo $(ROCQVVV) | cut -d"." -f1-2) + +# all: --------------------------------------------------------------- +all: config build + +# Makefile.rocq: ------------------------------------------------------ +.PHONY: pre-makefile + +Makefile.rocq: pre-makefile $(ROCQPROJECT) Makefile + $(ROCQMAKEFILE) $(ROCQMAKEFILEOPTIONS) -f $(ROCQPROJECT) -o Makefile.rocq + +# Global config, build, clean and distclean -------------------------- +config: sub-config this-config + +build: sub-build this-build + +clean: sub-clean this-clean + +distclean: sub-distclean this-distclean + +# Local config, build, clean and distclean --------------------------- +.PHONY: this-config this-build this-distclean this-clean + +this-config:: __always__ + +this-build:: this-config Makefile.rocq + +$(ROCQMAKE) + +this-distclean:: this-clean + rm -f Makefile.rocq Makefile.rocq.conf Makefile.rocq + +this-clean:: __always__ + @if [ -f Makefile.rocq ]; then $(ROCQMAKE) cleanall; fi + +# Install target ----------------------------------------------------- +.PHONY: install + +install: __always__ Makefile.rocq + $(ROCQMAKE) install +# counting lines of Rocq code ----------------------------------------- +.PHONY: count + +ROCQFILES = $(shell grep '.v$$' $(ROCQPROJECT)) + +count: + @rocq wc $(ROCQFILES) | tail -1 | \ + awk '{printf ("%d (spec=%d+proof=%d)\n", $$1+$$2, $$1, $$2)}' +# Additionally cleaning backup (*~) files ---------------------------- +this-distclean:: + rm -f $(shell find . -name '*~') + +# Make in SUBDIRS ---------------------------------------------------- +ifdef SUBDIRS +sub-%: __always__ + @set -e; for d in $(SUBDIRS); do +$(MAKE) -C $$d $(@:sub-%=%); done +else +sub-%: __always__ + @true +endif + +# Make of individual .vo --------------------------------------------- +%.vo: __always__ Makefile.rocq + +$(ROCQMAKE) $@ diff --git a/coq-htt-core.opam b/coq-htt-core.opam index 6a5ab2d..30cda74 100644 --- a/coq-htt-core.opam +++ b/coq-htt-core.opam @@ -34,13 +34,14 @@ that HTT implements Separation logic as a shallow embedding in Coq.""" build: [make "-C" "htt" "-j%{jobs}%"] install: [make "-C" "htt" "install"] depends: [ - "dune" {>= "3.6"} - "coq" { (>= "9.0" & < "9.2~") | (= "dev") } - "coq-hierarchy-builder" { (>= "1.7.0" & < "1.11~") | (= "dev") } - "coq-mathcomp-ssreflect" { (>= "2.4.0" & < "2.6~") | (= "dev") } - "coq-mathcomp-algebra" - "coq-mathcomp-fingroup" - "coq-fcsl-pcm" { (>= "2.2.0" & < "2.3~") | (= "dev") } + "dune" {>= "3.23"} + "rocq-core" { (>= "9.2" & < "9.3~") | (= "dev") } + "rocq-stdlib" + "rocq-mathcomp-ssreflect" { (>= "2.6.0" & < "2.7~") | (= "dev") } + "rocq-hierarchy-builder" { (>= "1.7.0" & < "1.11~") | (= "dev") } + "rocq-mathcomp-algebra" + "rocq-mathcomp-fingroup" + "coq-fcsl-pcm" { (>= "2.3.0" & < "2.4~") | (= "dev") } ] tags: [ diff --git a/coq-htt.opam b/coq-htt.opam index 5033cae..2317c19 100644 --- a/coq-htt.opam +++ b/coq-htt.opam @@ -31,12 +31,14 @@ that HTT implements Separation logic as a shallow embedding in Coq.""" build: [make "-C" "examples" "-j%{jobs}%"] install: [make "-C" "examples" "install"] depends: [ - "dune" {>= "3.6"} - "coq" { (>= "9.0" & < "9.2~") | (= "dev") } - "coq-mathcomp-ssreflect" { (>= "2.4.0" & < "2.6~") | (= "dev") } - "coq-mathcomp-algebra" - "coq-mathcomp-fingroup" - "coq-fcsl-pcm" { (>= "2.2.0" & < "2.3~") | (= "dev") } + "dune" {>= "3.23"} + "rocq-core" { (>= "9.2" & < "9.3~") | (= "dev") } + "rocq-stdlib" + "rocq-mathcomp-ssreflect" { (>= "2.6.0" & < "2.7~") | (= "dev") } + "rocq-hierarchy-builder" { (>= "1.7.0" & < "1.11~") | (= "dev") } + "rocq-mathcomp-algebra" + "rocq-mathcomp-fingroup" + "coq-fcsl-pcm" { (>= "2.3.0" & < "2.4~") | (= "dev") } "coq-htt-core" {= version} ] diff --git a/htt/Makefile b/htt/Makefile new file mode 100644 index 0000000..103b008 --- /dev/null +++ b/htt/Makefile @@ -0,0 +1,7 @@ +# -*- Makefile -*- + +# setting variables +COQPROJECT?=Make + +# Main Makefile +include ../Makefile.common From 494b6d7a3d56be5c495b969cc3b9d4f76a034fa1 Mon Sep 17 00:00:00 2001 From: Aleksandar Nanevski Date: Thu, 6 Aug 2026 16:40:54 +0200 Subject: [PATCH 06/17] preparing v2.3.0 --- .github/workflows/docker-action.yml | 4 +-- README.md | 20 ++++++----- coq-htt-core.opam | 4 +-- coq-htt.opam | 2 +- meta.yml | 51 +++++++++++++++++++---------- 5 files changed, 51 insertions(+), 30 deletions(-) diff --git a/.github/workflows/docker-action.yml b/.github/workflows/docker-action.yml index 157b274..89c10c2 100644 --- a/.github/workflows/docker-action.yml +++ b/.github/workflows/docker-action.yml @@ -9,6 +9,7 @@ on: pull_request: branches: - '**' + workflow_dispatch: jobs: build: @@ -17,8 +18,7 @@ jobs: strategy: matrix: image: - - 'mathcomp/mathcomp:2.4.0-rocq-prover-9.0' - - 'mathcomp/mathcomp:2.5.0-rocq-prover-9.1' + - 'mathcomp/mathcomp:2.6.0-rocq-prover-9.2' - 'mathcomp/mathcomp-dev:rocq-prover-dev' fail-fast: false steps: diff --git a/README.md b/README.md index 59515d1..9082d94 100644 --- a/README.md +++ b/README.md @@ -10,6 +10,8 @@ Follow the instructions on https://github.com/coq-community/templates to regener [docker-action-link]: https://github.com/imdea-software/htt/actions/workflows/docker-action.yml + + Hoare Type Theory (HTT) is a verification system for reasoning about sequential heap-manipulating programs based on Separation logic. @@ -27,7 +29,7 @@ sequential composition, and the type for monadic unit combines the Hoare rules f program (in a small-footprint variant) and for variable assignment (adapted for functional variables). The connection reconciles dependent types with effects of state and exceptions and establishes Separation logic as a type theory for such effects. In implementation terms, it means -that HTT implements Separation logic as a shallow embedding in Coq. +that HTT implements Separation logic as a shallow embedding in Rocq. ## Meta @@ -37,15 +39,17 @@ that HTT implements Separation logic as a shallow embedding in Coq. - Alexander Gryzlov - Marcos Grandury - License: [Apache-2.0](LICENSE) -- Compatible Coq versions: 9.0 or later +- Compatible Rocq/Coq versions: 9.2 - Additional dependencies: + - Rocq Core compiler engine + - Rocq Standard Library components + - [MathComp ssreflect 2.6 or later](https://math-comp.github.io) - [Hierarchy Builder 1.7.0 or later](https://github.com/math-comp/hierarchy-builder) - - [MathComp ssreflect 2.4 or later](https://math-comp.github.io) - [MathComp algebra](https://math-comp.github.io) - [MathComp fingroup](https://math-comp.github.io) - - [FCSL-PCM 2.2](https://github.com/imdea-software/fcsl-pcm) + - [FCSL-PCM 2.3 or later](https://github.com/imdea-software/fcsl-pcm) - [Dune](https://dune.build) 3.6 or later -- Coq namespace: `htt` +- Rocq/Coq namespace: `htt` - Related publication(s): - [Structuring the verification of heap-manipulating programs](https://software.imdea.org/~aleks/papers/reflect/reflect.pdf) doi:[10.1145/1706299.1706331](https://doi.org/10.1145/1706299.1706331) @@ -129,9 +133,9 @@ The original version of HTT can be found [here](https://software.imdea.org/~alek A semantic model for HTT, with large sigma types. -* [Verifying Graph Algorithms in Separation Logic: A Case for an - Algebraic Approach](https://software.imdea.org/~aleks/icfp25/paper-sub.pdf) +* [Verifying Graph Algorithms in Separation Logic: A Case for an Algebraic Approach](https://software.imdea.org/~aleks/icfp25/paper-sub.pdf) Marcos Grandury, Aleksandar Nanevski and Alexander Gryzlov. ICFP 2025. - The paper on verifying graphs algorithms using PCMs and their morphism. \ No newline at end of file + Development of PCM of graphs and their morphisms. + Concise verification of Schorr-Waite graph algorith, and union-find datastructure. diff --git a/coq-htt-core.opam b/coq-htt-core.opam index 30cda74..9c5acf3 100644 --- a/coq-htt-core.opam +++ b/coq-htt-core.opam @@ -29,14 +29,14 @@ sequential composition, and the type for monadic unit combines the Hoare rules f program (in a small-footprint variant) and for variable assignment (adapted for functional variables). The connection reconciles dependent types with effects of state and exceptions and establishes Separation logic as a type theory for such effects. In implementation terms, it means -that HTT implements Separation logic as a shallow embedding in Coq.""" +that HTT implements Separation logic as a shallow embedding in Rocq.""" build: [make "-C" "htt" "-j%{jobs}%"] install: [make "-C" "htt" "install"] depends: [ "dune" {>= "3.23"} "rocq-core" { (>= "9.2" & < "9.3~") | (= "dev") } - "rocq-stdlib" + "rocq-stdlib" "rocq-mathcomp-ssreflect" { (>= "2.6.0" & < "2.7~") | (= "dev") } "rocq-hierarchy-builder" { (>= "1.7.0" & < "1.11~") | (= "dev") } "rocq-mathcomp-algebra" diff --git a/coq-htt.opam b/coq-htt.opam index 2317c19..6ab38cd 100644 --- a/coq-htt.opam +++ b/coq-htt.opam @@ -26,7 +26,7 @@ sequential composition, and the type for monadic unit combines the Hoare rules f program (in a small-footprint variant) and for variable assignment (adapted for functional variables). The connection reconciles dependent types with effects of state and exceptions and establishes Separation logic as a type theory for such effects. In implementation terms, it means -that HTT implements Separation logic as a shallow embedding in Coq.""" +that HTT implements Separation logic as a shallow embedding in Rcoq.""" build: [make "-C" "examples" "-j%{jobs}%"] install: [make "-C" "examples" "install"] diff --git a/meta.yml b/meta.yml index a069912..4e6fd69 100644 --- a/meta.yml +++ b/meta.yml @@ -27,7 +27,7 @@ description: |- program (in a small-footprint variant) and for variable assignment (adapted for functional variables). The connection reconciles dependent types with effects of state and exceptions and establishes Separation logic as a type theory for such effects. In implementation terms, it means - that HTT implements Separation logic as a shallow embedding in Coq. + that HTT implements Separation logic as a shallow embedding in Rocq. build: |- ## Building and installation instructions @@ -80,42 +80,52 @@ license: file: LICENSE supported_coq_versions: - text: 9.0 or later - opam: '{ (>= "9.0" & < "9.2~") | (= "dev") }' + text: "none" + opam: "" + +supported_rocq_versions: + text: 9.2 or later + opam: '{ (>= "9.2" & < "9.3~") | (= "dev") }' + tested_coq_opam_versions: -- version: '2.4.0-rocq-prover-9.0' - repo: 'mathcomp/mathcomp' -- version: '2.5.0-rocq-prover-9.1' +- version: '2.6.0-rocq-prover-9.2' repo: 'mathcomp/mathcomp' - version: 'rocq-prover-dev' repo: 'mathcomp/mathcomp-dev' - dependencies: - opam: - name: coq-hierarchy-builder - version: '{ (>= "1.7.0" & < "1.11~") | (= "dev") }' + name: rocq-core + version: '{ (>= "9.2" & < "9.3~") | (= "dev") }' + description: "Rocq Core compiler engine" +- opam: + name: rocq-stdlib + version: '{ (>= "9.2" & < "9.3~") | (= "dev") }' + description: "Rocq Standard Library components" +- opam: + name: rocq-mathcomp-ssreflect + version: '{ (>= "2.6.0" & < "2.7~") | (= "dev") }' description: |- - [Hierarchy Builder 1.7.0 or later](https://github.com/math-comp/hierarchy-builder) + [MathComp ssreflect 2.6 or later](https://math-comp.github.io) - opam: - name: coq-mathcomp-ssreflect - version: '{ (>= "2.4.0" & < "2.6~") | (= "dev") }' + name: rocq-hierarchy-builder + version: '{ (>= "1.7.0" & < "1.11~") | (= "dev") }' description: |- - [MathComp ssreflect 2.4 or later](https://math-comp.github.io) + [Hierarchy Builder 1.7.0 or later](https://github.com/math-comp/hierarchy-builder) - opam: - name: coq-mathcomp-algebra + name: rocq-mathcomp-algebra description: |- [MathComp algebra](https://math-comp.github.io) - opam: - name: coq-mathcomp-fingroup + name: rocq-mathcomp-fingroup description: |- [MathComp fingroup](https://math-comp.github.io) - opam: name: coq-fcsl-pcm - version: '{ (>= "2.2.0" & < "2.3~") | (= "dev") }' + version: '{ (>= "2.3.0" & < "2.4~") | (= "dev") }' description: |- - [FCSL-PCM 2.2](https://github.com/imdea-software/fcsl-pcm) + [FCSL-PCM 2.3 or later](https://github.com/imdea-software/fcsl-pcm) namespace: htt @@ -185,3 +195,10 @@ documentation: |- Kasper Svendsen, Lars Birkedal and Aleksandar Nanevski. TLCA 2011. A semantic model for HTT, with large sigma types. + + * [Verifying Graph Algorithms in Separation Logic: A Case for an Algebraic Approach](https://software.imdea.org/~aleks/icfp25/paper-sub.pdf) + + Marcos Grandury, Aleksandar Nanevski and Alexander Gryzlov. ICFP 2025. + + Development of PCM of graphs and their morphisms. + Concise verification of Schorr-Waite graph algorith, and union-find datastructure. \ No newline at end of file From 17ee60097a113cbd7654d1772353e765ce04361f Mon Sep 17 00:00:00 2001 From: Aleksandar Nanevski Date: Thu, 6 Aug 2026 16:41:21 +0200 Subject: [PATCH 07/17] preparing v2.3.0 --- _RocqProject | 35 +++++++++++++++++++++++++++++++++++ 1 file changed, 35 insertions(+) create mode 100644 _RocqProject diff --git a/_RocqProject b/_RocqProject new file mode 100644 index 0000000..7abfe3e --- /dev/null +++ b/_RocqProject @@ -0,0 +1,35 @@ +-Q examples htt +-Q htt htt +-docroot docs # where the documentation should go + +-arg -w -arg -notation-overridden +-arg -w -arg -redundant-canonical-projection +-arg -w -arg -HB.no-new-instance +-arg -w -arg -ambiguous-paths +-arg -w -arg -register-all + +htt/options.v +htt/domain.v +htt/model.v +htt/heapauto.v +examples/gcd.v +examples/counter.v +examples/llist.v +examples/dlist.v +examples/array.v +examples/queue.v +examples/cyclic.v +examples/stack.v +examples/bintree.v +examples/bst.v +examples/kvmaps.v +examples/hashtab.v +examples/bubblesort.v +examples/quicksort.v +examples/congmath.v +examples/congprog.v +examples/tree.v +examples/graph.v +examples/schorr.v +examples/union_find.v + From bcd068fbddc61d178ab26e202732eab00edd3702 Mon Sep 17 00:00:00 2001 From: Aleksandar Nanevski Date: Thu, 6 Aug 2026 16:42:28 +0200 Subject: [PATCH 08/17] minor --- post-generate.sh | 77 ++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 77 insertions(+) create mode 100755 post-generate.sh diff --git a/post-generate.sh b/post-generate.sh new file mode 100755 index 0000000..2b8970a --- /dev/null +++ b/post-generate.sh @@ -0,0 +1,77 @@ +#!/usr/bin/env bash + +# Fix the Rocq dependencies that coq-community/templates cannot currently +# express. Run this after regenerating the repository files from meta.yml. + +set -euo pipefail + +script_dir=$(CDPATH= cd -- "$(dirname -- "$0")" && pwd) +opam_file=${1:-"${script_dir}/coq-htt.opam"} + +if [[ ! -f ${opam_file} ]]; then + echo "error: opam file not found: ${opam_file}" >&2 + exit 1 +fi + +dependency_count() { + local package=$1 + awk -v package="${package}" ' + $0 ~ "^[[:space:]]*\"" package "\"[[:space:]]*($|\\{)" { + count++ + } + END { + print count + 0 + } + ' "${opam_file}" +} + +coq_count=$(dependency_count coq) +rocq_core_count=$(dependency_count rocq-core) +rocq_stdlib_count=$(dependency_count rocq-stdlib) + +if (( coq_count == 0 && rocq_core_count == 1 && rocq_stdlib_count == 1 )); then + echo "Rocq dependencies are already patched in ${opam_file}" + exit 0 +fi + +if (( coq_count != 1 || rocq_core_count != 0 || rocq_stdlib_count != 0 )); then + echo "error: unexpected Rocq dependency layout in ${opam_file}" >&2 + echo " expected one coq dependency and no rocq-core/rocq-stdlib dependencies" >&2 + echo " found coq=${coq_count}, rocq-core=${rocq_core_count}, rocq-stdlib=${rocq_stdlib_count}" >&2 + exit 1 +fi + +temporary_file=$(mktemp "${opam_file}.tmp.XXXXXX") +trap 'rm -f -- "${temporary_file}"' EXIT +cp -p -- "${opam_file}" "${temporary_file}" + +awk ' + /^[[:space:]]*"coq"[[:space:]]*($|\{)/ { + dependency = $0 + sub(/"coq"/, "\"rocq-core\"", dependency) + print dependency + + match($0, /^[[:space:]]*/) + indentation = substr($0, RSTART, RLENGTH) + print indentation "\"rocq-stdlib\"" + patched++ + next + } + { + print + } + END { + if (patched != 1) { + exit 1 + } + } +' "${opam_file}" > "${temporary_file}" + +if command -v opam >/dev/null 2>&1; then + opam lint "${temporary_file}" +fi + +mv -- "${temporary_file}" "${opam_file}" +trap - EXIT + +echo "Patched ${opam_file}: coq -> rocq-core; added rocq-stdlib" From a3ae5ac56176571407fc6b4223f517f5a6fb22b8 Mon Sep 17 00:00:00 2001 From: Aleksandar Nanevski Date: Thu, 6 Aug 2026 16:51:04 +0200 Subject: [PATCH 09/17] preparing v2.3.0 --- dune-project | 3 --- 1 file changed, 3 deletions(-) delete mode 100644 dune-project diff --git a/dune-project b/dune-project deleted file mode 100644 index 4d97b3b..0000000 --- a/dune-project +++ /dev/null @@ -1,3 +0,0 @@ -(lang dune 3.6) -(using coq 0.6) -(name htt) From 32c112c90d15af5e1a2d217b047854d33db18049 Mon Sep 17 00:00:00 2001 From: Aleksandar Nanevski Date: Thu, 6 Aug 2026 16:55:57 +0200 Subject: [PATCH 10/17] removing dependence on dune --- README.md | 3 +-- coq-htt-core.opam | 7 +++---- coq-htt.opam | 1 - meta.yml | 2 +- 4 files changed, 5 insertions(+), 8 deletions(-) diff --git a/README.md b/README.md index 9082d94..43d32da 100644 --- a/README.md +++ b/README.md @@ -39,7 +39,7 @@ that HTT implements Separation logic as a shallow embedding in Rocq. - Alexander Gryzlov - Marcos Grandury - License: [Apache-2.0](LICENSE) -- Compatible Rocq/Coq versions: 9.2 +- Compatible Rocq/Coq versions: none - Additional dependencies: - Rocq Core compiler engine - Rocq Standard Library components @@ -48,7 +48,6 @@ that HTT implements Separation logic as a shallow embedding in Rocq. - [MathComp algebra](https://math-comp.github.io) - [MathComp fingroup](https://math-comp.github.io) - [FCSL-PCM 2.3 or later](https://github.com/imdea-software/fcsl-pcm) - - [Dune](https://dune.build) 3.6 or later - Rocq/Coq namespace: `htt` - Related publication(s): - [Structuring the verification of heap-manipulating programs](https://software.imdea.org/~aleks/papers/reflect/reflect.pdf) doi:[10.1145/1706299.1706331](https://doi.org/10.1145/1706299.1706331) diff --git a/coq-htt-core.opam b/coq-htt-core.opam index 9c5acf3..0acd6af 100644 --- a/coq-htt-core.opam +++ b/coq-htt-core.opam @@ -31,12 +31,11 @@ variables). The connection reconciles dependent types with effects of state and establishes Separation logic as a type theory for such effects. In implementation terms, it means that HTT implements Separation logic as a shallow embedding in Rocq.""" -build: [make "-C" "htt" "-j%{jobs}%"] -install: [make "-C" "htt" "install"] +build: [make "-j%{jobs}%"] +install: [make "install"] depends: [ - "dune" {>= "3.23"} "rocq-core" { (>= "9.2" & < "9.3~") | (= "dev") } - "rocq-stdlib" + "rocq-stdlib" { (>= "9.2" & < "9.3~") | (= "dev") } "rocq-mathcomp-ssreflect" { (>= "2.6.0" & < "2.7~") | (= "dev") } "rocq-hierarchy-builder" { (>= "1.7.0" & < "1.11~") | (= "dev") } "rocq-mathcomp-algebra" diff --git a/coq-htt.opam b/coq-htt.opam index 6ab38cd..24f426f 100644 --- a/coq-htt.opam +++ b/coq-htt.opam @@ -31,7 +31,6 @@ that HTT implements Separation logic as a shallow embedding in Rcoq.""" build: [make "-C" "examples" "-j%{jobs}%"] install: [make "-C" "examples" "install"] depends: [ - "dune" {>= "3.23"} "rocq-core" { (>= "9.2" & < "9.3~") | (= "dev") } "rocq-stdlib" "rocq-mathcomp-ssreflect" { (>= "2.6.0" & < "2.7~") | (= "dev") } diff --git a/meta.yml b/meta.yml index 4e6fd69..f5cb8c9 100644 --- a/meta.yml +++ b/meta.yml @@ -4,7 +4,7 @@ organization: imdea-software opam_name: coq-htt-core community: false action: true -dune: true +dune: false coqdoc: false synopsis: >- From 8df16aa70a6af533121812da566e239d5fc620a2 Mon Sep 17 00:00:00 2001 From: Aleksandar Nanevski Date: Thu, 6 Aug 2026 17:03:34 +0200 Subject: [PATCH 11/17] fixing --- README.md | 3 ++- coq-htt-core.opam | 6 ++++-- dune-project | 3 +++ examples/dune | 9 +++++++++ htt/dune | 11 +++++++++++ meta.yml | 2 +- 6 files changed, 30 insertions(+), 4 deletions(-) create mode 100644 dune-project create mode 100644 examples/dune create mode 100644 htt/dune diff --git a/README.md b/README.md index 43d32da..111a340 100644 --- a/README.md +++ b/README.md @@ -39,7 +39,7 @@ that HTT implements Separation logic as a shallow embedding in Rocq. - Alexander Gryzlov - Marcos Grandury - License: [Apache-2.0](LICENSE) -- Compatible Rocq/Coq versions: none +- Compatible Rocq/Coq versions: 9.2 - Additional dependencies: - Rocq Core compiler engine - Rocq Standard Library components @@ -48,6 +48,7 @@ that HTT implements Separation logic as a shallow embedding in Rocq. - [MathComp algebra](https://math-comp.github.io) - [MathComp fingroup](https://math-comp.github.io) - [FCSL-PCM 2.3 or later](https://github.com/imdea-software/fcsl-pcm) + - [Dune](https://dune.build) 3.6 or later - Rocq/Coq namespace: `htt` - Related publication(s): - [Structuring the verification of heap-manipulating programs](https://software.imdea.org/~aleks/papers/reflect/reflect.pdf) doi:[10.1145/1706299.1706331](https://doi.org/10.1145/1706299.1706331) diff --git a/coq-htt-core.opam b/coq-htt-core.opam index 0acd6af..8fbb57e 100644 --- a/coq-htt-core.opam +++ b/coq-htt-core.opam @@ -31,9 +31,11 @@ variables). The connection reconciles dependent types with effects of state and establishes Separation logic as a type theory for such effects. In implementation terms, it means that HTT implements Separation logic as a shallow embedding in Rocq.""" -build: [make "-j%{jobs}%"] -install: [make "install"] +build: [make "-C" "htt" "-j%{jobs}%"] +install: [make "-C" "htt" "install"] depends: [ + "dune" {>= "3.6"} + "coq" "rocq-core" { (>= "9.2" & < "9.3~") | (= "dev") } "rocq-stdlib" { (>= "9.2" & < "9.3~") | (= "dev") } "rocq-mathcomp-ssreflect" { (>= "2.6.0" & < "2.7~") | (= "dev") } diff --git a/dune-project b/dune-project new file mode 100644 index 0000000..4d97b3b --- /dev/null +++ b/dune-project @@ -0,0 +1,3 @@ +(lang dune 3.6) +(using coq 0.6) +(name htt) diff --git a/examples/dune b/examples/dune new file mode 100644 index 0000000..af8c240 --- /dev/null +++ b/examples/dune @@ -0,0 +1,9 @@ +(coq.theory + (name htt) + (package coq-htt) + (synopsis "Hoare Type Theory with examples") + (flags :standard + -w -notation-overridden + -w -local-declaration + -w -redundant-canonical-projection + -w -projection-no-head-constant)) diff --git a/htt/dune b/htt/dune new file mode 100644 index 0000000..a6eeaa3 --- /dev/null +++ b/htt/dune @@ -0,0 +1,11 @@ +; This file was generated from `meta.yml`, please do not edit manually. + +(coq.theory + (name htt) + (package coq-htt-core) + (synopsis "Hoare Type Theory") + (flags :standard + -w -notation-overridden + -w -local-declaration + -w -redundant-canonical-projection + -w -projection-no-head-constant)) diff --git a/meta.yml b/meta.yml index f5cb8c9..4e6fd69 100644 --- a/meta.yml +++ b/meta.yml @@ -4,7 +4,7 @@ organization: imdea-software opam_name: coq-htt-core community: false action: true -dune: false +dune: true coqdoc: false synopsis: >- From 6199d95ca6424f88eab8c3d7648367de749d4386 Mon Sep 17 00:00:00 2001 From: Aleksandar Nanevski Date: Thu, 6 Aug 2026 17:20:19 +0200 Subject: [PATCH 12/17] fixes --- README.md | 2 +- coq-htt-core.opam | 8 ++++---- meta.yml | 2 +- 3 files changed, 6 insertions(+), 6 deletions(-) diff --git a/README.md b/README.md index 111a340..9082d94 100644 --- a/README.md +++ b/README.md @@ -39,7 +39,7 @@ that HTT implements Separation logic as a shallow embedding in Rocq. - Alexander Gryzlov - Marcos Grandury - License: [Apache-2.0](LICENSE) -- Compatible Rocq/Coq versions: 9.2 +- Compatible Rocq/Coq versions: 9.2 - Additional dependencies: - Rocq Core compiler engine - Rocq Standard Library components diff --git a/coq-htt-core.opam b/coq-htt-core.opam index 8fbb57e..fb0e270 100644 --- a/coq-htt-core.opam +++ b/coq-htt-core.opam @@ -3,7 +3,7 @@ opam-version: "2.0" maintainer: "fcsl@software.imdea.org" -version: "2.2.0" +version: "2.3.0" homepage: "https://github.com/imdea-software/htt" dev-repo: "git+https://github.com/imdea-software/htt.git" @@ -31,13 +31,13 @@ variables). The connection reconciles dependent types with effects of state and establishes Separation logic as a type theory for such effects. In implementation terms, it means that HTT implements Separation logic as a shallow embedding in Rocq.""" -build: [make "-C" "htt" "-j%{jobs}%"] -install: [make "-C" "htt" "install"] +build: [make "-C" "examples" "-j%{jobs}%"] +install: [make "-C" "examples" "install"] depends: [ "dune" {>= "3.6"} "coq" "rocq-core" { (>= "9.2" & < "9.3~") | (= "dev") } - "rocq-stdlib" { (>= "9.2" & < "9.3~") | (= "dev") } + "rocq-stdlib" "rocq-mathcomp-ssreflect" { (>= "2.6.0" & < "2.7~") | (= "dev") } "rocq-hierarchy-builder" { (>= "1.7.0" & < "1.11~") | (= "dev") } "rocq-mathcomp-algebra" diff --git a/meta.yml b/meta.yml index 4e6fd69..ae04578 100644 --- a/meta.yml +++ b/meta.yml @@ -72,7 +72,7 @@ maintainers: opam-file-maintainer: fcsl@software.imdea.org -opam-file-version: 2.2.0 +opam-file-version: 2.3.0 license: fullname: Apache-2.0 From aba1e338b527f1bf03668534db2d7a0fbca85281 Mon Sep 17 00:00:00 2001 From: Aleksandar Nanevski Date: Thu, 6 Aug 2026 17:37:21 +0200 Subject: [PATCH 13/17] fixes --- _CoqProject | 35 +++++++++++++++++++++++++++++++++++ examples/Make | 29 +++++++++++++++++++++++++++++ htt/Make | 14 ++++++++++++++ 3 files changed, 78 insertions(+) create mode 100644 _CoqProject create mode 100644 examples/Make create mode 100644 htt/Make diff --git a/_CoqProject b/_CoqProject new file mode 100644 index 0000000..7abfe3e --- /dev/null +++ b/_CoqProject @@ -0,0 +1,35 @@ +-Q examples htt +-Q htt htt +-docroot docs # where the documentation should go + +-arg -w -arg -notation-overridden +-arg -w -arg -redundant-canonical-projection +-arg -w -arg -HB.no-new-instance +-arg -w -arg -ambiguous-paths +-arg -w -arg -register-all + +htt/options.v +htt/domain.v +htt/model.v +htt/heapauto.v +examples/gcd.v +examples/counter.v +examples/llist.v +examples/dlist.v +examples/array.v +examples/queue.v +examples/cyclic.v +examples/stack.v +examples/bintree.v +examples/bst.v +examples/kvmaps.v +examples/hashtab.v +examples/bubblesort.v +examples/quicksort.v +examples/congmath.v +examples/congprog.v +examples/tree.v +examples/graph.v +examples/schorr.v +examples/union_find.v + diff --git a/examples/Make b/examples/Make new file mode 100644 index 0000000..05db16d --- /dev/null +++ b/examples/Make @@ -0,0 +1,29 @@ +-Q . htt + +-arg -w -arg -notation-overridden +-arg -w -arg -redundant-canonical-projection + +# release-specific arguments +-arg -w -arg -notation-incompatible-prefix # specific to coq8.20.0 +-arg -w -arg -deprecated-from-Coq # specific to coq8.21 +-arg -w -arg -deprecated-dirpath-Coq # specific to coq8.21 + +exploit.v +gcd.v +counter.v +llist.v +dlist.v +array.v +queue.v +cyclic.v +stack.v +bintree.v +bst.v +kvmaps.v +hashtab.v +bubblesort.v +quicksort.v +congmath.v +congprog.v +tree.v +union_find.v diff --git a/htt/Make b/htt/Make new file mode 100644 index 0000000..dca3ca7 --- /dev/null +++ b/htt/Make @@ -0,0 +1,14 @@ +-Q . htt + +-arg -w -arg -notation-overridden +-arg -w -arg -redundant-canonical-projection + +# release-specific arguments +-arg -w -arg -notation-incompatible-prefix # specific to coq8.20.0 +-arg -w -arg -deprecated-from-Coq # specific to coq8.21 +-arg -w -arg -deprecated-dirpath-Coq # specific to coq8.21 + +options.v +domain.v +model.v +heapauto.v From 5d20c9ee4f47f4e379626b85b2444adfab3b904b Mon Sep 17 00:00:00 2001 From: Aleksandar Nanevski Date: Thu, 6 Aug 2026 17:44:03 +0200 Subject: [PATCH 14/17] fixes --- Makefile | 21 +++---------------- Makefile.common | 56 ++++++++++++++++++++++++------------------------- _RocqProject | 35 ------------------------------- examples/Make | 11 +++++----- htt/Make | 8 +++---- 5 files changed, 39 insertions(+), 92 deletions(-) delete mode 100644 _RocqProject diff --git a/Makefile b/Makefile index 55119cb..d5aa0bf 100644 --- a/Makefile +++ b/Makefile @@ -1,19 +1,4 @@ -# KNOWNTARGETS will not be passed along to RocqMakefile -KNOWNTARGETS := RocqMakefile -# KNOWNFILES will not get implicit targets from the final rule, and so depending on them won’t invoke the submake -# Warning: These files get declared as PHONY, so any targets depending on them always get rebuilt -KNOWNFILES := Makefile _RocqProject +# -*- Makefile -*- -.DEFAULT_GOAL := invoke-rocqmakefile - -RocqMakefile: Makefile _RocqProject - $(ROCQBIN)rocq makefile -f _RocqProject -o RocqMakefile - -invoke-rocqmakefile: RocqMakefile - $(MAKE) --no-print-directory -f RocqMakefile $(filter-out $(KNOWNTARGETS),$(MAKECMDGOALS)) - -.PHONY: invoke-rocqmakefile $(KNOWNFILES) - -# This should be the last rule, to handle any targets not declared above -%: invoke-rocqmakefile - @true +# -------------------------------------------------------------------- +include Makefile.common diff --git a/Makefile.common b/Makefile.common index aea0e16..c523410 100644 --- a/Makefile.common +++ b/Makefile.common @@ -6,12 +6,12 @@ # pre-makefile::, this-clean:: and __always__:: may be extended # # Additionally, the following variables may be customized: # SUBDIRS?= -ROCQBIN?=$(dir $(shell which rocq)) -ROCQMAKEFILE?=$(ROCQBIN)rocq_makefile -ROCQDEP?=$(ROCQBIN)rocq dep -ROCQPROJECT?=_RocqProject -ROCQMAKEOPTIONS?= -ROCQMAKEFILEOPTIONS?= +COQBIN?=$(dir $(shell which coqtop)) +COQMAKEFILE?=$(COQBIN)coq_makefile +COQDEP?=$(COQBIN)coqdep +COQPROJECT?=_CoqProject +COQMAKEOPTIONS?= +COQMAKEFILEOPTIONS?= V?= VERBOSE?=V ###################################################################### @@ -22,28 +22,28 @@ VERBOSE?=V H:= $(if $(VERBOSE),,@) # not used yet TOP = $(dir $(lastword $(MAKEFILE_LIST))) -ROCQMAKE = $(MAKE) -f Makefile.rocq $(ROCQMAKEOPTIONS) -BRANCH_rocq:= $(shell $(ROCQBIN)rocq top -v | head -1 | grep -E '(trunk|master)' \ +COQMAKE = $(MAKE) -f Makefile.coq $(COQMAKEOPTIONS) +BRANCH_coq:= $(shell $(COQBIN)coqtop -v | head -1 | grep -E '(trunk|master)' \ | wc -l | sed 's/ *//g') -# rocq version: -ifneq "$(BRANCH_rocq)" "0" -ROCQVVV:= dev +# coq version: +ifneq "$(BRANCH_coq)" "0" +COQVVV:= dev else -ROCQVVV:=$(shell $(ROCQBIN)rocq top --print-version | cut -d" " -f1) +COQVVV:=$(shell $(COQBIN)coqtop --print-version | cut -d" " -f1) endif -ROCQV:= $(shell echo $(ROCQVVV) | cut -d"." -f1) -ROCQVV:= $(shell echo $(ROCQVVV) | cut -d"." -f1-2) +COQV:= $(shell echo $(COQVVV) | cut -d"." -f1) +COQVV:= $(shell echo $(COQVVV) | cut -d"." -f1-2) # all: --------------------------------------------------------------- all: config build -# Makefile.rocq: ------------------------------------------------------ +# Makefile.coq: ------------------------------------------------------ .PHONY: pre-makefile -Makefile.rocq: pre-makefile $(ROCQPROJECT) Makefile - $(ROCQMAKEFILE) $(ROCQMAKEFILEOPTIONS) -f $(ROCQPROJECT) -o Makefile.rocq +Makefile.coq: pre-makefile $(COQPROJECT) Makefile + $(COQMAKEFILE) $(COQMAKEFILEOPTIONS) -f $(COQPROJECT) -o Makefile.coq # Global config, build, clean and distclean -------------------------- config: sub-config this-config @@ -59,27 +59,27 @@ distclean: sub-distclean this-distclean this-config:: __always__ -this-build:: this-config Makefile.rocq - +$(ROCQMAKE) +this-build:: this-config Makefile.coq + +$(COQMAKE) this-distclean:: this-clean - rm -f Makefile.rocq Makefile.rocq.conf Makefile.rocq + rm -f Makefile.coq Makefile.coq.conf Makefile.coq this-clean:: __always__ - @if [ -f Makefile.rocq ]; then $(ROCQMAKE) cleanall; fi + @if [ -f Makefile.coq ]; then $(COQMAKE) cleanall; fi # Install target ----------------------------------------------------- .PHONY: install -install: __always__ Makefile.rocq - $(ROCQMAKE) install -# counting lines of Rocq code ----------------------------------------- +install: __always__ Makefile.coq + $(COQMAKE) install +# counting lines of Coq code ----------------------------------------- .PHONY: count -ROCQFILES = $(shell grep '.v$$' $(ROCQPROJECT)) +COQFILES = $(shell grep '.v$$' $(COQPROJECT)) count: - @rocq wc $(ROCQFILES) | tail -1 | \ + @coqwc $(COQFILES) | tail -1 | \ awk '{printf ("%d (spec=%d+proof=%d)\n", $$1+$$2, $$1, $$2)}' # Additionally cleaning backup (*~) files ---------------------------- this-distclean:: @@ -95,5 +95,5 @@ sub-%: __always__ endif # Make of individual .vo --------------------------------------------- -%.vo: __always__ Makefile.rocq - +$(ROCQMAKE) $@ +%.vo: __always__ Makefile.coq + +$(COQMAKE) $@ diff --git a/_RocqProject b/_RocqProject deleted file mode 100644 index 7abfe3e..0000000 --- a/_RocqProject +++ /dev/null @@ -1,35 +0,0 @@ --Q examples htt --Q htt htt --docroot docs # where the documentation should go - --arg -w -arg -notation-overridden --arg -w -arg -redundant-canonical-projection --arg -w -arg -HB.no-new-instance --arg -w -arg -ambiguous-paths --arg -w -arg -register-all - -htt/options.v -htt/domain.v -htt/model.v -htt/heapauto.v -examples/gcd.v -examples/counter.v -examples/llist.v -examples/dlist.v -examples/array.v -examples/queue.v -examples/cyclic.v -examples/stack.v -examples/bintree.v -examples/bst.v -examples/kvmaps.v -examples/hashtab.v -examples/bubblesort.v -examples/quicksort.v -examples/congmath.v -examples/congprog.v -examples/tree.v -examples/graph.v -examples/schorr.v -examples/union_find.v - diff --git a/examples/Make b/examples/Make index 05db16d..2e300b3 100644 --- a/examples/Make +++ b/examples/Make @@ -2,13 +2,10 @@ -arg -w -arg -notation-overridden -arg -w -arg -redundant-canonical-projection +-arg -w -arg -HB.no-new-instance +-arg -w -arg -ambiguous-paths +-arg -w -arg -register-all -# release-specific arguments --arg -w -arg -notation-incompatible-prefix # specific to coq8.20.0 --arg -w -arg -deprecated-from-Coq # specific to coq8.21 --arg -w -arg -deprecated-dirpath-Coq # specific to coq8.21 - -exploit.v gcd.v counter.v llist.v @@ -26,4 +23,6 @@ quicksort.v congmath.v congprog.v tree.v +graph.v +schorr.v union_find.v diff --git a/htt/Make b/htt/Make index dca3ca7..fb4df47 100644 --- a/htt/Make +++ b/htt/Make @@ -2,11 +2,9 @@ -arg -w -arg -notation-overridden -arg -w -arg -redundant-canonical-projection - -# release-specific arguments --arg -w -arg -notation-incompatible-prefix # specific to coq8.20.0 --arg -w -arg -deprecated-from-Coq # specific to coq8.21 --arg -w -arg -deprecated-dirpath-Coq # specific to coq8.21 +-arg -w -arg -HB.no-new-instance +-arg -w -arg -ambiguous-paths +-arg -w -arg -register-all options.v domain.v From 3dcbc65388af7d6dc5e9421a1ace97d437c9b723 Mon Sep 17 00:00:00 2001 From: Aleksandar Nanevski Date: Thu, 6 Aug 2026 17:50:07 +0200 Subject: [PATCH 15/17] fixes --- coq-htt-core.opam | 5 ++--- coq-htt.opam | 1 + 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/coq-htt-core.opam b/coq-htt-core.opam index fb0e270..d2f90f8 100644 --- a/coq-htt-core.opam +++ b/coq-htt-core.opam @@ -31,11 +31,10 @@ variables). The connection reconciles dependent types with effects of state and establishes Separation logic as a type theory for such effects. In implementation terms, it means that HTT implements Separation logic as a shallow embedding in Rocq.""" -build: [make "-C" "examples" "-j%{jobs}%"] -install: [make "-C" "examples" "install"] +build: [make "-C" "htt" "-j%{jobs}%"] +install: [make "-C" "htt" "install"] depends: [ "dune" {>= "3.6"} - "coq" "rocq-core" { (>= "9.2" & < "9.3~") | (= "dev") } "rocq-stdlib" "rocq-mathcomp-ssreflect" { (>= "2.6.0" & < "2.7~") | (= "dev") } diff --git a/coq-htt.opam b/coq-htt.opam index 24f426f..c255146 100644 --- a/coq-htt.opam +++ b/coq-htt.opam @@ -31,6 +31,7 @@ that HTT implements Separation logic as a shallow embedding in Rcoq.""" build: [make "-C" "examples" "-j%{jobs}%"] install: [make "-C" "examples" "install"] depends: [ + "dune" {>= "3.6"} "rocq-core" { (>= "9.2" & < "9.3~") | (= "dev") } "rocq-stdlib" "rocq-mathcomp-ssreflect" { (>= "2.6.0" & < "2.7~") | (= "dev") } From bef7d5e1fe04d93b63c6114df91dc4e1c3dc6dd4 Mon Sep 17 00:00:00 2001 From: Aleksandar Nanevski Date: Thu, 6 Aug 2026 17:51:48 +0200 Subject: [PATCH 16/17] fixes --- coq-htt.opam | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/coq-htt.opam b/coq-htt.opam index c255146..929a137 100644 --- a/coq-htt.opam +++ b/coq-htt.opam @@ -1,6 +1,6 @@ opam-version: "2.0" maintainer: "fcsl@software.imdea.org" -version: "2.2.0" +version: "2.3.0" homepage: "https://github.com/imdea-software/htt" dev-repo: "git+https://github.com/imdea-software/htt.git" From ad519fad804592c7b5cf1e79aa5d4ead75f3c58c Mon Sep 17 00:00:00 2001 From: Aleksandar Nanevski Date: Thu, 6 Aug 2026 18:55:23 +0200 Subject: [PATCH 17/17] again --- Makefile.common | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/Makefile.common b/Makefile.common index c523410..b1904e7 100644 --- a/Makefile.common +++ b/Makefile.common @@ -6,8 +6,8 @@ # pre-makefile::, this-clean:: and __always__:: may be extended # # Additionally, the following variables may be customized: # SUBDIRS?= -COQBIN?=$(dir $(shell which coqtop)) -COQMAKEFILE?=$(COQBIN)coq_makefile +COQBIN?=$(dir $(shell which rocq)) +COQMAKEFILE?=$(COQBIN)rocq makefile COQDEP?=$(COQBIN)coqdep COQPROJECT?=_CoqProject COQMAKEOPTIONS?= @@ -23,14 +23,14 @@ VERBOSE?=V H:= $(if $(VERBOSE),,@) # not used yet TOP = $(dir $(lastword $(MAKEFILE_LIST))) COQMAKE = $(MAKE) -f Makefile.coq $(COQMAKEOPTIONS) -BRANCH_coq:= $(shell $(COQBIN)coqtop -v | head -1 | grep -E '(trunk|master)' \ +BRANCH_coq:= $(shell $(COQBIN)rocq top -v | head -1 | grep -E '(trunk|master)' \ | wc -l | sed 's/ *//g') # coq version: ifneq "$(BRANCH_coq)" "0" COQVVV:= dev else -COQVVV:=$(shell $(COQBIN)coqtop --print-version | cut -d" " -f1) +COQVVV:=$(shell $(COQBIN)rocq top --print-version | cut -d" " -f1) endif COQV:= $(shell echo $(COQVVV) | cut -d"." -f1)