├── .github └── workflows │ └── docker-action.yml ├── .gitignore ├── .gitmodules ├── Makefile ├── Makefile.common ├── Makefile.coq.local ├── README.md ├── TODO ├── _CoqProject ├── coq-graph-theory-planar.opam ├── coq-graph-theory.opam ├── depend-colors.gv ├── dune-project ├── files.txt ├── meta.yml └── theories ├── core ├── Make ├── Makefile ├── arc.v ├── bij.v ├── bounded.v ├── checkpoint.v ├── coloring.v ├── completeness.v ├── connectivity.v ├── cp_minor.v ├── digraph.v ├── dom.v ├── dune ├── edone.v ├── equiv.v ├── excluded.v ├── extraction_def.v ├── extraction_iso.v ├── extraction_top.v ├── finite_quotient.v ├── finmap_plus.v ├── helly.v ├── mgraph.v ├── mgraph2.v ├── mgraph2_tw2.v ├── minor.v ├── open_confluence.v ├── partition.v ├── preliminaries.v ├── ptt.v ├── pttdom.v ├── reduction.v ├── rewriting.v ├── set_tac.v ├── setoid_bigop.v ├── sgraph.v ├── skeleton.v ├── smerge.v ├── structures.v ├── transfer.v ├── treewidth.v └── wpgt.v └── planar ├── K4plane.v ├── Make ├── Makefile ├── dune ├── embedding.v ├── hcycle.v ├── hmap_ops.v └── wagner.v /.github/workflows/docker-action.yml: -------------------------------------------------------------------------------- 1 | name: Docker CI 2 | 3 | on: 4 | schedule: 5 | - cron: '25 5 * * 5' 6 | push: 7 | branches: 8 | - master 9 | pull_request: 10 | branches: 11 | - '**' 12 | 13 | jobs: 14 | build: 15 | # the OS must be GNU/Linux to be able to use the docker-coq-action 16 | runs-on: ubuntu-latest 17 | strategy: 18 | matrix: 19 | image: 20 | - 'mathcomp/mathcomp-dev:rocq-prover-dev' 21 | - 'mathcomp/mathcomp:2.4.0-rocq-prover-9.0' 22 | - 'mathcomp/mathcomp:2.2.0-coq-8.20' 23 | - 'mathcomp/mathcomp:2.1.0-coq-8.18' 24 | fail-fast: false 25 | steps: 26 | - uses: actions/checkout@v4 27 | - uses: coq-community/docker-coq-action@v1 28 | with: 29 | custom_image: ${{ matrix.image }} 30 | custom_script: | 31 | {{before_install}} 32 | startGroup "Build graph-theory dependencies" 33 | opam pin add -n -y -k path coq-graph-theory . 34 | opam update -y 35 | opam install -y -j $(nproc) coq-graph-theory --deps-only 36 | endGroup 37 | startGroup "Build graph-theory" 38 | opam install -y -v -j $(nproc) coq-graph-theory 39 | opam list 40 | endGroup 41 | startGroup "Build graph-theory-planar dependencies" 42 | opam pin add -n -y -k path coq-graph-theory-planar . 43 | opam update -y 44 | opam install -y -j $(nproc) coq-graph-theory-planar --deps-only 45 | endGroup 46 | startGroup "Build graph-theory-planar" 47 | opam install -y -v -j $(nproc) coq-graph-theory-planar 48 | opam list 49 | endGroup 50 | startGroup "Uninstallation test" 51 | opam remove -y coq-graph-theory-planar 52 | opam remove -y coq-graph-theory 53 | endGroup 54 | 55 | 56 | # See also: 57 | # https://github.com/coq-community/docker-coq-action#readme 58 | # https://github.com/erikmd/docker-coq-github-action-demo 59 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | *.vo 2 | *.vos 3 | *.vok 4 | *.swp 5 | *.v.d 6 | *.glob 7 | *.pdf 8 | *# 9 | *~ 10 | *.crashcoqide 11 | *.aux 12 | *.bbl 13 | *.blg 14 | *.fdb_latexmk 15 | *.log 16 | *.out 17 | *.toc 18 | Makefile.coq 19 | Makefile.coq.conf 20 | .Makefile.coq.d 21 | .lia.cache 22 | -------------------------------------------------------------------------------- /.gitmodules: -------------------------------------------------------------------------------- 1 | [submodule "coq/coqdocjs"] 2 | path = coqdocjs 3 | url = https://github.com/chdoc/coqdocjs.git 4 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | # -*- Makefile -*- 2 | 3 | # -------------------------------------------------------------------- 4 | include Makefile.common 5 | -------------------------------------------------------------------------------- /Makefile.common: -------------------------------------------------------------------------------- 1 | # -*- Makefile -*- 2 | 3 | ###################################################################### 4 | # USAGE: # 5 | # The rules this-config::, this-build::, this-distclean::, # 6 | # pre-makefile::, this-clean:: and __always__:: may be extended # 7 | # Additionally, the following variables may be customized: # 8 | SUBDIRS?= 9 | COQBIN?=$(dir $(shell which coqtop)) 10 | COQMAKEFILE?=$(COQBIN)coq_makefile 11 | COQDEP?=$(COQBIN)coqdep 12 | COQPROJECT?=_CoqProject 13 | COQMAKEOPTIONS?= 14 | COQMAKEFILEOPTIONS?= 15 | V?= 16 | VERBOSE?=V 17 | ###################################################################### 18 | 19 | # local context: ----------------------------------------------------- 20 | .PHONY: all config build clean distclean __always__ 21 | .SUFFIXES: 22 | 23 | H:= $(if $(VERBOSE),,@) # not used yet 24 | TOP = $(dir $(lastword $(MAKEFILE_LIST))) 25 | COQMAKE = $(MAKE) -f Makefile.coq $(COQMAKEOPTIONS) 26 | BRANCH_coq:= $(shell $(COQBIN)coqtop -v | head -1 | grep -E '(trunk|master)' \ 27 | | wc -l | sed 's/ *//g') 28 | 29 | # coq version: 30 | ifneq "$(BRANCH_coq)" "0" 31 | COQVVV:= dev 32 | else 33 | COQVVV:=$(shell $(COQBIN)coqtop --print-version | cut -d" " -f1) 34 | endif 35 | 36 | COQV:= $(shell echo $(COQVVV) | cut -d"." -f1) 37 | COQVV:= $(shell echo $(COQVVV) | cut -d"." -f1-2) 38 | 39 | # all: --------------------------------------------------------------- 40 | all: config build 41 | 42 | # Makefile.coq: ------------------------------------------------------ 43 | .PHONY: pre-makefile 44 | 45 | Makefile.coq: pre-makefile $(COQPROJECT) Makefile 46 | $(COQMAKEFILE) $(COQMAKEFILEOPTIONS) -f $(COQPROJECT) -o Makefile.coq 47 | 48 | # Global config, build, clean and distclean -------------------------- 49 | config: sub-config this-config 50 | 51 | build: sub-build this-build 52 | 53 | clean: sub-clean this-clean 54 | 55 | distclean: sub-distclean this-distclean 56 | 57 | # Local config, build, clean and distclean --------------------------- 58 | .PHONY: this-config this-build this-distclean this-clean 59 | 60 | this-config:: __always__ 61 | 62 | this-build:: this-config Makefile.coq 63 | +$(COQMAKE) 64 | 65 | this-distclean:: this-clean 66 | rm -f Makefile.coq Makefile.coq.conf Makefile.coq 67 | 68 | this-clean:: __always__ 69 | @if [ -f Makefile.coq ]; then $(COQMAKE) cleanall; fi 70 | 71 | # Install target ----------------------------------------------------- 72 | .PHONY: install 73 | 74 | install: __always__ Makefile.coq 75 | $(COQMAKE) install 76 | # counting lines of Coq code ----------------------------------------- 77 | .PHONY: count 78 | 79 | COQFILES = $(shell grep '.v$$' $(COQPROJECT)) 80 | 81 | count: 82 | @coqwc $(COQFILES) | tail -1 | \ 83 | awk '{printf ("%d (spec=%d+proof=%d)\n", $$1+$$2, $$1, $$2)}' 84 | # Additionally cleaning backup (*~) files ---------------------------- 85 | this-distclean:: 86 | rm -f $(shell find . -name '*~') 87 | 88 | # Make in SUBDIRS ---------------------------------------------------- 89 | ifdef SUBDIRS 90 | sub-%: __always__ 91 | @set -e; for d in $(SUBDIRS); do +$(MAKE) -C $$d $(@:sub-%=%); done 92 | else 93 | sub-%: __always__ 94 | @true 95 | endif 96 | 97 | # Make of individual .vo --------------------------------------------- 98 | %.vo: __always__ Makefile.coq 99 | +$(COQMAKE) $@ 100 | -------------------------------------------------------------------------------- /Makefile.coq.local: -------------------------------------------------------------------------------- 1 | GLOBFILES = $(VFILES:.v=.glob) 2 | COQDOCJS_DIR ?= coqdocjs 3 | EXTRA_DIR = $(COQDOCJS_DIR)/extra 4 | HEADER = $(EXTRA_DIR)/header.html 5 | FOOTER = $(EXTRA_DIR)/footer.html 6 | RESOURCES = $(EXTRA_DIR)/resources 7 | 8 | VERSION ?= current 9 | PREFIX = $(COQMF_INSTALLCOQDOCROOT) 10 | 11 | DOCDIR = docs 12 | COQDOCDIR = $(DOCDIR)/coqdoc 13 | 14 | COQDOCHTMLFLAGS = --toc -s --external 'http://math-comp.github.io/htmldoc/' mathcomp --html \ 15 | --with-header $(HEADER) --with-footer $(FOOTER) --index indexpage --parse-comments --toc-depth 2 16 | 17 | coqdoc: $(GLOBFILES) $(VFILES) $(HEADER) $(FOOTER) $(RESOURCES) 18 | $(SHOW)'COQDOC -d $(COQDOCDIR)' 19 | $(HIDE)mkdir -p $(COQDOCDIR) 20 | $(HIDE)$(COQDOC) $(COQDOCHTMLFLAGS) $(COQDOCLIBS) -d $(COQDOCDIR) $(VFILES) 21 | $(SHOW)'COPY extra' 22 | $(HIDE)cp $(RESOURCES)/* $(COQDOCDIR) 23 | .PHONY: coqdoc 24 | 25 | graph: Makefile.coq 26 | $(COQBIN)coqdep $(COQMF_COQLIBS) -dyndep var -c -dumpgraph depend-graph.gv $(COQMF_VFILES) >/dev/null 27 | sed -i "s|theories/||g" depend-graph.gv 28 | sed -i '1d;s/\[label=\"\([^"]*\)\"]/[label="\1";URL=".\/$(VERSION)\/$(PREFIX).\1.html"]/g' depend-graph.gv 29 | cat depend-colors.gv depend-graph.gv | dot -o depend-graph.dot 30 | dot -Tsvg depend-graph.dot -o depend-graph.svg 31 | 32 | clean:: 33 | $(HIDE)rm -rf $(DOCDIR) depend-graph.* 34 | 35 | 36 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | 5 | # Graph Theory 6 | 7 | [![Docker CI][docker-action-shield]][docker-action-link] 8 | [![Chat][chat-shield]][chat-link] 9 | [![Contributing][contributing-shield]][contributing-link] 10 | [![Code of Conduct][conduct-shield]][conduct-link] 11 | [![Zulip][zulip-shield]][zulip-link] 12 | [![DOI][doi-shield]][doi-link] 13 | 14 | [docker-action-shield]: https://github.com/coq-community/graph-theory/actions/workflows/docker-action.yml/badge.svg?branch=master 15 | [docker-action-link]: https://github.com/coq-community/graph-theory/actions/workflows/docker-action.yml 16 | [chat-shield]: https://img.shields.io/badge/Zulip-join_chat-brightgreen.svg 17 | [chat-link]: https://coq.zulipchat.com/#narrow/stream/284683-GraphTheory 18 | 19 | [contributing-shield]: https://img.shields.io/badge/contributions-welcome-%23f7931e.svg 20 | [contributing-link]: https://github.com/coq-community/manifesto/blob/master/CONTRIBUTING.md 21 | 22 | [conduct-shield]: https://img.shields.io/badge/%E2%9D%A4-code%20of%20conduct-%23f15a24.svg 23 | [conduct-link]: https://github.com/coq-community/manifesto/blob/master/CODE_OF_CONDUCT.md 24 | 25 | [zulip-shield]: https://img.shields.io/badge/chat-on%20zulip-%23c1272d.svg 26 | [zulip-link]: https://coq.zulipchat.com/#narrow/stream/237663-coq-community-devs.20.26.20users 27 | 28 | 29 | [doi-shield]: https://zenodo.org/badge/DOI/10.1007/s10817-020-09543-2.svg 30 | [doi-link]: https://doi.org/10.1007/s10817-020-09543-2 31 | 32 | A library of formalized graph theory results, including various 33 | standard results from the literature (e.g., Menger's Theorem, Hall's 34 | Marriage Theorem, the excluded minor characterization of 35 | treewidth-two graphs, and Wagner's Theorem) as well as some more 36 | recent results arising from the study of relation algebra within 37 | the ERC CoVeCe project (e.g., soundness and completeness of an 38 | axiomatization of graph isomorphism). 39 | 40 | ## Meta 41 | 42 | - Author(s): 43 | - Christian Doczkal (initial) 44 | - Damien Pous (initial) 45 | - Daniel Severín (external contributor) 46 | - Coq-community maintainer(s): 47 | - Christian Doczkal ([**@chdoc**](https://github.com/chdoc)) 48 | - Damien Pous ([**@damien-pous**](https://github.com/damien-pous)) 49 | - License: [CeCILL-B](LICENSE) 50 | - Compatible Coq versions: 8.18 or later 51 | - Additional dependencies: 52 | - MathComp's [SSReflect library](https://math-comp.github.io), version 2.1.0 or later 53 | - MathComp's [Algebra library](https://math-comp.github.io) 54 | - MathComp's [finmap library](https://github.com/math-comp/finmap) 55 | - MathComp's [Algebra tactics](https://github.com/math-comp/algebra-tactics) 56 | - [Hierarchy Builder](https://github.com/math-comp/hierarchy-builder), version 1.5.0 or later 57 | - Gonthier's [formal proof](https://github.com/coq-community/fourcolor) of the Four-Color Theorem (optional dependency) 58 | - Coq namespace: `GraphTheory` 59 | - Related publication(s): 60 | - [A Variant of Wagner's Theorem Based on Combinatorial Hypermaps](https://hal.inria.fr/hal-03142192) doi:[10.4230/LIPIcs.ITP.2021.17](https://doi.org/10.4230/LIPIcs.ITP.2021.17) 61 | - [Graph Theory in Coq - Minors, Treewidth, and Isomorphisms](https://hal.archives-ouvertes.fr/hal-02316859) doi:[10.1007/s10817-020-09543-2](https://doi.org/10.1007/s10817-020-09543-2) 62 | - [Completeness of an Axiomatization of Graph Isomorphism via Graph Rewriting in Coq](https://hal.archives-ouvertes.fr/hal-02333553) doi:[10.1145/3372885.3373831](https://doi.org/10.1145/3372885.3373831) 63 | - [A Formal Proof of the Minor-Exclusion Property for Treewidth-Two Graphs](https://hal.archives-ouvertes.fr/hal-01703922) doi:[10.1007/978-3-319-94821-8_11](https://doi.org/10.1007/978-3-319-94821-8_11) 64 | - [Formalization of the Domination Chain with Weighted Parameters (Short Paper)](https://drops.dagstuhl.de/opus/volltexte/2019/11091/) doi:[10.4230/LIPIcs.ITP.2019.36](https://doi.org/10.4230/LIPIcs.ITP.2019.36) 65 | 66 | ## Building and installation instructions 67 | 68 | To manually build and install the whole project, including Wagner's theorem which requires 69 | the Coq proof of the Four-Color Theorem, do: 70 | 71 | ``` shell 72 | git clone https://github.com/coq-community/graph-theory.git 73 | cd graph-theory 74 | make # or make -j 75 | make install 76 | ``` 77 | 78 | However, the easiest way to install released versions of Graph Theory 79 | libraries selectively is via [opam](https://opam.ocaml.org/doc/Install.html): 80 | 81 | ```shell 82 | opam repo add coq-released https://coq.inria.fr/opam/released 83 | opam install coq-graph-theory # core library 84 | opam install coq-graph-theory-planar # planarity results depending on coq-fourcolor 85 | ``` 86 | 87 | ## Documentation 88 | 89 | This project contains: 90 | 91 | - a general purpose Coq library about graph theory: 92 | - directed graphs, simple graphs, multigraphs 93 | - paths, trees, forests, isomorphism, connected components, etc. 94 | - minors and tree decompositions 95 | - Menger's theorem and some of its corollaries (Hall's marriage theorem and König's theorem) 96 | - the excluded-minor characterisation of treewidth at most two graphs (as those excluding K4 as a minor) 97 | - soundness and completeness of an axiomatization of isomorphism of two-pointed treewidth-two (`2p`) multigraphs: 98 | - isomorphisms up to label-equivalence and edge-flipping for multigraphs 99 | - 2p graphs form a 2p algebra and thus also a 2pdom algebra 100 | - every K4-free graph can be represented by a 2p-term 101 | - 2pdom axioms are complete w.r.t. graph isomorphism for connected 2p graphs. 102 | - a proof of Wagner's theorem (planarity of K5 and K3,3 graphs) based on combinatorial hypermaps 103 | - two proofs of the weak perfect graph theorem (WPGT): 104 | - one proof based on Lovasz's replication lemma 105 | - one proof based on a matrix rank argument 106 | 107 | Additional information on the contents of individual files is available at the [project website](https://perso.ens-lyon.fr/damien.pous/covece/graphs/). 108 | -------------------------------------------------------------------------------- /TODO: -------------------------------------------------------------------------------- 1 | - pass on transfer / open_confluence 2 | - documentation + spell-checking 3 | - some light-blue background for text boxes? 4 | 5 | ----- 6 | 7 | - solve rewriting/setoid_rewriting/Type/irewrite... (or at least uniformise) 8 | 9 | - get completeness for 2p algebra axioms by extending the rewrite system 10 | 11 | - use packed classes for getting a more fine-grain presentation of the structures we employ, 12 | without running into efficiency problems 13 | . for multigraphs and 2-pointed multigraphs (which inherit finType) 14 | . for setoids, labels, pttdom, ptt and related structures 15 | 16 | - conservativity proof of 2p over 2pdom 17 | 18 | - simpler term extraction via the rewrite system? (requires expansion) 19 | -------------------------------------------------------------------------------- /_CoqProject: -------------------------------------------------------------------------------- 1 | -arg -w -arg -notation-overridden 2 | -arg -w -arg -redundant-canonical-projection 3 | -arg -w -arg -projection-no-head-constant 4 | -arg -w -arg -duplicate-clear 5 | -arg -w -arg -elpi.add-const-for-axiom-or-sectionvar 6 | -arg -w -arg -ambiguous-paths 7 | 8 | -Q theories GraphTheory 9 | 10 | ## preliminary modules 11 | theories/core/edone.v 12 | theories/core/bounded.v 13 | theories/core/preliminaries.v 14 | theories/core/setoid_bigop.v 15 | theories/core/finmap_plus.v 16 | theories/core/set_tac.v 17 | theories/core/bij.v 18 | theories/core/finite_quotient.v 19 | theories/core/equiv.v 20 | theories/core/arc.v 21 | 22 | ## general purpose graph library (JAR19) 23 | theories/core/digraph.v 24 | theories/core/sgraph.v 25 | theories/core/helly.v 26 | theories/core/connectivity.v 27 | theories/core/treewidth.v 28 | theories/core/minor.v 29 | theories/core/excluded.v 30 | theories/core/checkpoint.v 31 | theories/core/cp_minor.v 32 | theories/core/smerge.v #(ITP 21) 33 | 34 | ## soundness and completeness for 2pdom (CPP20) 35 | theories/core/structures.v 36 | theories/core/mgraph.v 37 | theories/core/pttdom.v 38 | theories/core/mgraph2.v 39 | theories/core/rewriting.v 40 | theories/core/reduction.v 41 | theories/core/open_confluence.v 42 | theories/core/transfer.v 43 | theories/core/completeness.v 44 | 45 | ## extraction for of 2p terms from TW2 graphs (ITP18 / JAR19) 46 | theories/core/ptt.v 47 | theories/core/skeleton.v 48 | theories/core/mgraph2_tw2.v 49 | theories/core/extraction_def.v 50 | theories/core/extraction_iso.v 51 | theories/core/extraction_top.v 52 | 53 | ## Domination Theory 54 | theories/core/dom.v 55 | 56 | ## Graph Coloring 57 | theories/core/partition.v 58 | theories/core/coloring.v 59 | theories/core/wpgt.v 60 | 61 | ## Kuratowski's/Wagner's theorem (ITP 21) 62 | theories/planar/hmap_ops.v 63 | theories/planar/hcycle.v 64 | theories/planar/embedding.v 65 | theories/planar/K4plane.v 66 | theories/planar/wagner.v 67 | -------------------------------------------------------------------------------- /coq-graph-theory-planar.opam: -------------------------------------------------------------------------------- 1 | opam-version: "2.0" 2 | maintainer: "christian.doczkal@mpi-sp.org" 3 | version: "dev" 4 | 5 | homepage: "https://github.com/coq-community/graph-theory" 6 | dev-repo: "git+https://github.com/coq-community/graph-theory.git" 7 | bug-reports: "https://github.com/coq-community/graph-theory/issues" 8 | license: "CECILL-B" 9 | 10 | synopsis: "Graph theory results on planarity in Coq and MathComp" 11 | description: """ 12 | Formal definitions and results on graph planarity in Coq using the Mathematical Components 13 | library, including Wagner's Theorem. Relies on hypermaps and other notions developed 14 | as part of the Coq proof of the Four-Color Theorem.""" 15 | 16 | build: ["dune" "build" "-p" name "-j" jobs] 17 | depends: [ 18 | "dune" {>= "3.5"} 19 | "coq" {>= "8.18"} 20 | "coq-mathcomp-ssreflect" {>= "2.1.0"} 21 | "coq-mathcomp-algebra-tactics" 22 | "coq-graph-theory" {= version} 23 | "coq-fourcolor" 24 | ] 25 | 26 | tags: [ 27 | "category:Computer Science/Graph Theory" 28 | "keyword:graph theory" 29 | "keyword:planarity" 30 | "logpath:GraphTheory.planar" 31 | ] 32 | authors: [ 33 | "Christian Doczkal" 34 | "Damien Pous" 35 | ] 36 | -------------------------------------------------------------------------------- /coq-graph-theory.opam: -------------------------------------------------------------------------------- 1 | opam-version: "2.0" 2 | maintainer: "christian.doczkal@mpi-sp.org" 3 | version: "dev" 4 | 5 | homepage: "https://github.com/coq-community/graph-theory" 6 | dev-repo: "git+https://github.com/coq-community/graph-theory.git" 7 | bug-reports: "https://github.com/coq-community/graph-theory/issues" 8 | license: "CECILL-B" 9 | 10 | synopsis: "General graph theory definitions and results in Coq and MathComp" 11 | description: """ 12 | Formalized general graph theory definitions and results using Coq and 13 | the Mathematical Components library, including various standard results 14 | from the literature (e.g., Menger's Theorem and Hall's Marriage Theorem).""" 15 | 16 | build: ["dune" "build" "-p" name "-j" jobs] 17 | depends: [ 18 | "dune" {>= "3.5"} 19 | "coq" {>= "8.18"} 20 | "coq-mathcomp-ssreflect" {>= "2.1.0"} 21 | "coq-mathcomp-algebra" 22 | "coq-mathcomp-finmap" 23 | "coq-hierarchy-builder" {>= "1.5.0"} 24 | ] 25 | 26 | tags: [ 27 | "category:Computer Science/Graph Theory" 28 | "keyword:graph theory" 29 | "keyword:minors" 30 | "keyword:treewidth" 31 | "keyword:algebra" 32 | "logpath:GraphTheory.core" 33 | ] 34 | authors: [ 35 | "Christian Doczkal" 36 | "Damien Pous" 37 | ] 38 | -------------------------------------------------------------------------------- /depend-colors.gv: -------------------------------------------------------------------------------- 1 | digraph dependencies { 2 | subgraph { # preliminary infrastructure 3 | node [style=filled; color="yellow"]; 4 | "edone"; 5 | "bounded"; 6 | "preliminaries"; 7 | "finmap_plus"; 8 | "set_tac"; 9 | "bij"; 10 | "finite_quotient"; 11 | "equiv"; 12 | "setoid_bigop"; 13 | "partition"; 14 | } 15 | subgraph { # general purpose graph lib 16 | node [style=filled; color="orange"]; 17 | "digraph"; 18 | "sgraph"; 19 | "helly"; 20 | "treewidth"; 21 | "minor"; 22 | "connectivity"; 23 | "excluded"; 24 | "checkpoint"; 25 | "dom"; 26 | "coloring"; 27 | "wpgt"; 28 | } 29 | subgraph { # 2p algebra of multigraphs (JAR19 generalised in CPP20) 30 | node [style=filled; color="magenta3"]; 31 | "ptt"; 32 | "mgraph"; 33 | "mgraph2"; 34 | } 35 | subgraph { # 2p algebra of multigraphs, extraction (JAR19) 36 | node [style=filled; color="red"]; 37 | "skeleton"; 38 | "mgraph2_tw2"; 39 | "cp_minor"; 40 | "extraction_def"; 41 | "extraction_iso"; 42 | "extraction_top"; 43 | } 44 | subgraph { # 2pdom soundness and completeness (CPP20) 45 | node [style=filled; color="blueviolet"]; 46 | "structures"; 47 | "pttdom"; 48 | "rewriting"; 49 | "reduction"; 50 | "open_confluence"; 51 | "transfer"; 52 | "completeness"; 53 | } 54 | subgraph { # Wagner's theorem (ITP21) 55 | node [style=filled; color="green"]; 56 | "hmap_ops"; 57 | "arc"; 58 | "hcycle"; 59 | "smerge"; 60 | "embedding"; 61 | "K4plane"; 62 | "wagner"; 63 | } 64 | subgraph { 65 | rank="same"; 66 | "edone"; 67 | "preliminaries"; 68 | } 69 | subgraph { 70 | rank="same"; 71 | "finmap_plus"; 72 | "finite_quotient"; 73 | } 74 | -------------------------------------------------------------------------------- /dune-project: -------------------------------------------------------------------------------- 1 | (lang dune 3.5) 2 | (using coq 0.6) 3 | (name graph-theory) 4 | -------------------------------------------------------------------------------- /files.txt: -------------------------------------------------------------------------------- 1 | *** preliminary shared modules *** 2 | edone: small extension of the [done] tactic 3 | bounded: fixpoint operator for bounded recursion 4 | preliminaries: miscellaneous basic lemmas missing from the standard libraries 5 | finmap_plus: additions to the mathcomp-finmap library 6 | set_tac: a simple tactic for reasoning about finite sets 7 | bij: computationally relevant bijections between sets 8 | finite_quotient: abstraction layer for mathcomp quotients 9 | equiv: lemmas about equivalence closure 10 | 11 | *** JAR19 submission (general purpose graph library) 12 | digraph: directed graphs, paths 13 | sgraph: simple graphs, trees and forests 14 | helly: Helly property for trees 15 | treewidth: tree decompositions, treewidth 16 | minor: minors, links with treewidth 17 | menger: Menger's theorem and corollaries 18 | separators: separators, proof of TW2 = K4-free via Menger's theorem 19 | checkpoint: checkpoints 20 | 21 | *** JAR19 submission (2p-algebra related part) 22 | ptt: 2p-algebras, initial algebra of terms 23 | skeleton: skeletons of multigraphs 24 | mgraph2_tw2: subalgebra of treewidth at most two multigraphs 25 | cp_minor: links between checkpoints and minors, for extraction 26 | extraction_def: definition of the extraction function in the connected case 27 | extraction_iso: correctness of the extraction function (connected case) 28 | extraction_top: extension to the general case, TW2 = K4-free as a corollary 29 | 30 | mgraph ptt checkpoint separators 31 | mgraph2 / cp_minors 32 | skeleton / 33 | mgraph2_tw2 extraction_def 34 | extraction_iso 35 | extraction_top 36 | 37 | *** CPP20 submission 38 | structures: setoids, bisetoids, monoids 39 | pttdom: 2pdom-algebras, initial algebra of terms, tests 40 | mgraph: labelled multigraphs 41 | mgraph2: pointed multigraphs, 2pdom algebra of such graphs 42 | rewriting: definition of the rewriting system 43 | reduction: rewriting system powerful enough to reach normal forms 44 | open_confluence: open graphs, open local confluence proof 45 | transfer: transfer lemmas between the open and packed representations of 2p-graphs 46 | completeness: wrapping up everything into a completeness proof 47 | 48 | structures 49 | mgraph pttdom 50 | mgraph2 51 | rewriting 52 | reduction open_confluence 53 | transfer 54 | completeness 55 | -------------------------------------------------------------------------------- /meta.yml: -------------------------------------------------------------------------------- 1 | --- 2 | fullname: Graph Theory 3 | shortname: graph-theory 4 | organization: coq-community 5 | community: true 6 | action: true 7 | coqdoc: false 8 | doi: 10.1007/s10817-020-09543-2 9 | 10 | chat: 11 | url: https://coq.zulipchat.com/#narrow/stream/284683-GraphTheory 12 | shield: Zulip 13 | 14 | synopsis: >- 15 | Graph theory definitions and results in Coq and MathComp 16 | 17 | description: |- 18 | A library of formalized graph theory results, including various 19 | standard results from the literature (e.g., Menger's Theorem, Hall's 20 | Marriage Theorem, the excluded minor characterization of 21 | treewidth-two graphs, and Wagner's Theorem) as well as some more 22 | recent results arising from the study of relation algebra within 23 | the ERC CoVeCe project (e.g., soundness and completeness of an 24 | axiomatization of graph isomorphism). 25 | 26 | publications: 27 | - pub_url: https://hal.inria.fr/hal-03142192 28 | pub_title: A Variant of Wagner's Theorem Based on Combinatorial Hypermaps 29 | pub_doi: 10.4230/LIPIcs.ITP.2021.17 30 | - pub_url: https://hal.archives-ouvertes.fr/hal-02316859 31 | pub_title: Graph Theory in Coq - Minors, Treewidth, and Isomorphisms 32 | pub_doi: 10.1007/s10817-020-09543-2 33 | - pub_url: https://hal.archives-ouvertes.fr/hal-02333553 34 | pub_title: Completeness of an Axiomatization of Graph Isomorphism via Graph Rewriting in Coq 35 | pub_doi: 10.1145/3372885.3373831 36 | - pub_url: https://hal.archives-ouvertes.fr/hal-01703922 37 | pub_title: A Formal Proof of the Minor-Exclusion Property for Treewidth-Two Graphs 38 | pub_doi: 10.1007/978-3-319-94821-8_11 39 | - pub_url: https://drops.dagstuhl.de/opus/volltexte/2019/11091/ 40 | pub_title: Formalization of the Domination Chain with Weighted Parameters (Short Paper) 41 | pub_doi: 10.4230/LIPIcs.ITP.2019.36 42 | 43 | authors: 44 | - name: Christian Doczkal 45 | initial: true 46 | - name: Damien Pous 47 | initial: true 48 | 49 | after_authors: |2 50 | - Daniel Severín (external contributor) 51 | 52 | maintainers: 53 | - name: Christian Doczkal 54 | nickname: chdoc 55 | - name: Damien Pous 56 | nickname: damien-pous 57 | 58 | opam-file-maintainer: christian.doczkal@mpi-sp.org 59 | 60 | opam-file-version: dev 61 | 62 | license: 63 | fullname: CeCILL-B 64 | identifier: CECILL-B 65 | 66 | supported_coq_versions: 67 | text: 8.18 or later 68 | opam: '{>= "8.18"}' 69 | 70 | tested_coq_opam_versions: 71 | - version: 'rocq-prover-dev' 72 | repo: 'mathcomp/mathcomp-dev' 73 | - version: '2.2.0-coq-8.20' 74 | repo: 'mathcomp/mathcomp' 75 | - version: '2.2.0-coq-8.19' 76 | repo: 'mathcomp/mathcomp' 77 | - version: '2.2.0-coq-8.18' 78 | repo: 'mathcomp/mathcomp' 79 | - version: '2.1.0-coq-8.18' 80 | repo: 'mathcomp/mathcomp' 81 | 82 | ci_cron_schedule: '25 5 * * 5' 83 | 84 | dependencies: 85 | - opam: 86 | name: coq-mathcomp-ssreflect 87 | version: '{>= "2.1.0"}' 88 | description: MathComp's [SSReflect library](https://math-comp.github.io), version 2.1.0 or later 89 | - opam: 90 | name: coq-mathcomp-algebra 91 | description: MathComp's [Algebra library](https://math-comp.github.io) 92 | - opam: 93 | name: coq-mathcomp-finmap 94 | description: MathComp's [finmap library](https://github.com/math-comp/finmap) 95 | - opam: 96 | name: coq-mathcomp-algebra-tactics 97 | description: MathComp's [Algebra tactics](https://github.com/math-comp/algebra-tactics) 98 | - opam: 99 | name: coq-hierarchy-builder 100 | version: '{>= "1.5.0"}' 101 | description: '[Hierarchy Builder](https://github.com/math-comp/hierarchy-builder), version 1.5.0 or later' 102 | - opam: 103 | name: coq-fourcolor 104 | description: Gonthier's [formal proof](https://github.com/coq-community/fourcolor) of the Four-Color Theorem (optional dependency) 105 | 106 | namespace: GraphTheory 107 | 108 | keywords: 109 | - name: graph theory 110 | - name: minors 111 | - name: treewidth 112 | - name: algebra 113 | 114 | categories: 115 | - name: Computer Science/Graph Theory 116 | 117 | build: |- 118 | ## Building and installation instructions 119 | 120 | To manually build and install the whole project, including Wagner's theorem which requires 121 | the Coq proof of the Four-Color Theorem, do: 122 | 123 | ``` shell 124 | git clone https://github.com/coq-community/graph-theory.git 125 | cd graph-theory 126 | make # or make -j 127 | make install 128 | ``` 129 | 130 | However, the easiest way to install released versions of Graph Theory 131 | libraries selectively is via [opam](https://opam.ocaml.org/doc/Install.html): 132 | 133 | ```shell 134 | opam repo add coq-released https://coq.inria.fr/opam/released 135 | opam install coq-graph-theory # core library 136 | opam install coq-graph-theory-planar # planarity results depending on coq-fourcolor 137 | ``` 138 | 139 | documentation: |- 140 | ## Documentation 141 | 142 | This project contains: 143 | 144 | - a general purpose Coq library about graph theory: 145 | - directed graphs, simple graphs, multigraphs 146 | - paths, trees, forests, isomorphism, connected components, etc. 147 | - minors and tree decompositions 148 | - Menger's theorem and some of its corollaries (Hall's marriage theorem and König's theorem) 149 | - the excluded-minor characterisation of treewidth at most two graphs (as those excluding K4 as a minor) 150 | - soundness and completeness of an axiomatization of isomorphism of two-pointed treewidth-two (`2p`) multigraphs: 151 | - isomorphisms up to label-equivalence and edge-flipping for multigraphs 152 | - 2p graphs form a 2p algebra and thus also a 2pdom algebra 153 | - every K4-free graph can be represented by a 2p-term 154 | - 2pdom axioms are complete w.r.t. graph isomorphism for connected 2p graphs. 155 | - a proof of Wagner's theorem (planarity of K5 and K3,3 graphs) based on combinatorial hypermaps 156 | - two proofs of the weak perfect graph theorem (WPGT): 157 | - one proof based on Lovasz's replication lemma 158 | - one proof based on a matrix rank argument 159 | 160 | Additional information on the contents of individual files is available at the [project website](https://perso.ens-lyon.fr/damien.pous/covece/graphs/). 161 | --- 162 | -------------------------------------------------------------------------------- /theories/core/Make: -------------------------------------------------------------------------------- 1 | -arg -w -arg -notation-overridden 2 | -arg -w -arg -redundant-canonical-projection 3 | -arg -w -arg -projection-no-head-constant 4 | -arg -w -arg -duplicate-clear 5 | -arg -w -arg -elpi.add-const-for-axiom-or-sectionvar 6 | -arg -w -arg -ambiguous-paths 7 | 8 | -Q . GraphTheory.core 9 | 10 | edone.v 11 | bounded.v 12 | preliminaries.v 13 | setoid_bigop.v 14 | finmap_plus.v 15 | set_tac.v 16 | bij.v 17 | finite_quotient.v 18 | equiv.v 19 | arc.v 20 | digraph.v 21 | sgraph.v 22 | helly.v 23 | connectivity.v 24 | treewidth.v 25 | minor.v 26 | excluded.v 27 | checkpoint.v 28 | cp_minor.v 29 | smerge.v #(ITP 21) 30 | structures.v 31 | mgraph.v 32 | pttdom.v 33 | mgraph2.v 34 | rewriting.v 35 | reduction.v 36 | open_confluence.v 37 | transfer.v 38 | completeness.v 39 | ptt.v 40 | skeleton.v 41 | mgraph2_tw2.v 42 | extraction_def.v 43 | extraction_iso.v 44 | extraction_top.v 45 | dom.v 46 | partition.v 47 | coloring.v 48 | wpgt.v 49 | -------------------------------------------------------------------------------- /theories/core/Makefile: -------------------------------------------------------------------------------- 1 | # -*- Makefile -*- 2 | 3 | # setting variables 4 | COQPROJECT?=Make 5 | 6 | # Main Makefile 7 | include ../../Makefile.common 8 | -------------------------------------------------------------------------------- /theories/core/bij.v: -------------------------------------------------------------------------------- 1 | From Coq Require Import Setoid CMorphisms. 2 | From Coq Require Relation_Definitions. 3 | From mathcomp Require Import all_ssreflect. 4 | From GraphTheory Require Import edone preliminaries. 5 | 6 | Set Implicit Arguments. 7 | Unset Strict Implicit. 8 | Unset Printing Implicit Defensive. 9 | 10 | (** * Bijections between Types *) 11 | 12 | Set Primitive Projections. 13 | Record bij (A B: Type): Type := Bij 14 | { bij_fwd:> A -> B; 15 | bij_bwd: B -> A; 16 | bijK: cancel bij_fwd bij_bwd; 17 | bijK': cancel bij_bwd bij_fwd }. 18 | Notation "h '^-1'" := (bij_bwd h). 19 | 20 | (** Facts about Bijections *) 21 | 22 | Lemma bij_bijective A B (f : bij A B) : bijective f. 23 | Proof. case: f => f g can_f can_g. by exists g. Qed. 24 | 25 | Lemma bij_bijective' A B (f : bij A B) : bijective f^-1. 26 | Proof. case: f => f g can_f can_g. by exists f. Qed. 27 | 28 | #[export] 29 | Hint Resolve bij_bijective bij_bijective' : core. 30 | 31 | Lemma bij_injective A B (f: bij A B) : injective f. 32 | Proof. exact: bij_inj. Qed. 33 | 34 | Lemma bij_injective' A B (f: bij A B) : injective f^-1. 35 | Proof. exact: bij_inj. Qed. 36 | 37 | #[export] 38 | Hint Resolve bij_injective bij_injective' : core. 39 | 40 | Lemma card_bij (A B: finType) (f : bij A B) : #|A| = #|B|. 41 | Proof. exact: (bij_card_eq (f := f)). Qed. 42 | Arguments card_bij [A B] f. 43 | 44 | Lemma bij_imset_f (aT rT : finType) (f : bij aT rT) (x : aT) (A : {set aT}): 45 | (f x \in [set f x | x in A]) = (x \in A). 46 | Proof. 47 | apply/imsetP/idP; last by exists x. 48 | case => x0 xA. by move/(@bij_injective _ _ f) ->. 49 | Qed. 50 | 51 | Lemma imset_bijT (aT rT : finType) (i : bij aT rT) : i @: setT = setT. 52 | Proof. by apply/setP => x; rewrite -[x in LHS](bijK' i) bij_imset_f !inE. Qed. 53 | 54 | Lemma bij_imsetC (aT rT : finType) (f : bij aT rT) (A : {set aT}) : 55 | ~: [set f x | x in A] = [set f x | x in ~: A]. 56 | Proof. apply/setP => x. by rewrite -[x](bijK' f) !inE !bij_imset_f inE. Qed. 57 | 58 | Lemma bij_eqLR (aT rT : finType) (f : bij aT rT) x y : 59 | (f x == y) = (x == f^-1 y). 60 | Proof. by rewrite -{1}[y](bijK' f) bij_eq. Qed. 61 | 62 | (** Specific Bijections *) 63 | 64 | Definition bij_id {A}: bij A A := @Bij A A id id (@erefl A) (@erefl A). 65 | 66 | Definition bij_ord {T : finType} : bij T 'I_#|T| := Bij enum_rankK enum_valK. 67 | 68 | Definition bij_sym {A B}: bij A B -> bij B A. 69 | Proof. move=>f. econstructor; apply f. Defined. 70 | 71 | Definition bij_comp {A B C}: bij A B -> bij B C -> bij A C. 72 | Proof. 73 | move=> f g. 74 | econstructor; apply can_comp. apply g. apply f. apply f. apply g. 75 | Defined. 76 | 77 | #[export] 78 | Instance bij_Equivalence: Equivalence bij. 79 | Proof. constructor. exact @bij_id. exact @bij_sym. exact @bij_comp. Defined. 80 | 81 | (* bijections about [sum] *) 82 | 83 | Definition sumf {A B C D} (f: A -> B) (g: C -> D) (x: A+C): B+D := 84 | match x with inl a => inl (f a) | inr c => inr (g c) end. 85 | 86 | #[export] 87 | Instance sum_bij: Proper (bij ==> bij ==> bij) sum. 88 | Proof. 89 | intros A A' f B B' g. 90 | exists (sumf f g) (sumf f^-1 g^-1); abstract (by move=>[a|b] /=; rewrite ?bijK ?bijK'). 91 | Defined. 92 | 93 | Definition sumC {A B} (x: A + B): B + A := match x with inl x => inr x | inr x => inl x end. 94 | Lemma bij_sumC {A B}: bij (A+B) (B+A). 95 | Proof. exists sumC sumC; abstract by repeat case. Defined. 96 | 97 | Definition sumA {A B C} (x: A + (B + C)): (A + B) + C := 98 | match x with inl x => inl (inl x) | inr (inl x) => inl (inr x) | inr (inr x) => inr x end. 99 | Definition sumA' {A B C} (x: (A + B) + C): A + (B + C) := 100 | match x with inr x => inr (inr x) | inl (inr x) => inr (inl x) | inl (inl x) => inl x end. 101 | Lemma bij_sumA {A B C}: bij (A+(B+C)) ((A+B)+C). 102 | Proof. exists sumA sumA'; abstract by repeat case. Defined. 103 | 104 | Lemma sumUx {A}: bij (void + A) A. 105 | Proof. 106 | exists 107 | (fun x => match x with inl x => vfun x | inr a => a end) 108 | (fun x => inr x); 109 | abstract by repeat case. 110 | Defined. 111 | Lemma sumxU {A}: bij (A + void) A. 112 | Proof. etransitivity. apply bij_sumC. apply sumUx. Defined. 113 | 114 | 115 | (* bijections for [option] types *) 116 | 117 | Definition option_bij (A B : Type) (f : bij A B) : bij (option A) (option B). 118 | Proof. 119 | exists (option_map f) (option_map f^-1); abstract (case => //= x; by rewrite ?bijK ?bijK'). 120 | Defined. 121 | 122 | Lemma option_sum_unit {A}: bij (option A) (A+unit). 123 | Proof. 124 | exists 125 | (fun x => match x with Some a => inl a | None => inr tt end) 126 | (fun x => match x with inl a => Some a | inr _ => None end). 127 | all: abstract (repeat case=>//). 128 | Defined. 129 | 130 | (* the definitions below also follow from [option_sum_unit] and the bijections about [sum] *) 131 | Definition option_void: bij (option void) unit. 132 | Proof. exists (fun _ => tt) (fun _ => None); by case. Defined. 133 | 134 | Lemma sum_option_l {A B}: bij ((option A) + B) (option (A + B)). 135 | Proof. 136 | exists 137 | (fun x => match x with inl (Some a) => Some (inl a) | inl None => None | inr b => Some (inr b) end) 138 | (fun x => match x with Some (inl a) => inl (Some a) | None => inl None | Some (inr b) => inr b end). 139 | all: abstract (repeat case=>//). 140 | Defined. 141 | 142 | Lemma sum_option_r {A B}: bij (A + option B) (option (A + B)). 143 | Proof. 144 | etransitivity. apply bij_sumC. 145 | etransitivity. apply sum_option_l. 146 | apply option_bij, bij_sumC. 147 | Defined. 148 | 149 | Definition option2x {A}: option (option A) -> option (option A) := 150 | fun x => match x with Some (Some a) => Some (Some a) | Some None => None | None => Some None end. 151 | Definition option2_swap {A}: bij (option (option A)) (option (option A)). 152 | exists option2x option2x; abstract by repeat case. 153 | Defined. 154 | 155 | 156 | (* bijections for [bool] *) 157 | 158 | Definition bool_swap: bij bool bool. 159 | Proof. exists negb negb; by case. Defined. 160 | 161 | Lemma bool_two: bij bool (unit+unit). 162 | Proof. 163 | exists 164 | (fun b => if b then inr tt else inl tt) 165 | (fun x => match x with inl _ => false | inr _ => true end). 166 | all: abstract by repeat case. 167 | Defined. 168 | 169 | Definition bool_option_unit: bij bool (option unit). 170 | Proof. 171 | exists 172 | (fun b => if b then None else Some tt) 173 | (fun o => if o is None then true else false); 174 | abstract by repeat case. 175 | Defined. 176 | 177 | 178 | (** Moving a single element out of a type *) 179 | 180 | Section BijD1. 181 | Variables (T : finType) (z : T). 182 | 183 | (** We use [x \notin [set z]] rather than [x != z], because the former is 184 | the form that occurs when removing a single edge via [remove_edges] *) 185 | 186 | Definition bijD1_fwd (x : option { x : T | x \notin [set z]}) : T := 187 | if x is Some y then val y else z. 188 | Definition bijD1_bwd (x : T) : option { x : T | x \notin [set z]} := 189 | if @boolP (x \in [set z]) is AltFalse p then Some (Sub x p) else None. 190 | 191 | Lemma can_bijD1_fwd : cancel bijD1_fwd bijD1_bwd. 192 | Proof. 193 | move => [x|] //=; rewrite /bijD1_bwd; case: {-}_ /boolP => [|i] //. 194 | all: rewrite ?(negbTE (valP x)) ?valK' //. 195 | case:notF. by rewrite inE eqxx in i. 196 | Qed. 197 | 198 | Lemma can_bijD1_bwd : cancel bijD1_bwd bijD1_fwd. 199 | Proof. 200 | move => x. by rewrite /bijD1_bwd; case: {-}_ /boolP => [|i] //= /set1P->. 201 | Qed. 202 | 203 | Definition bijD1 := Bij can_bijD1_fwd can_bijD1_bwd. 204 | End BijD1. 205 | 206 | Section BijT. 207 | Variables (T : finType) (P : pred T). 208 | Hypothesis inP : forall x, P x. 209 | Definition subT_bij : bij {x : T | P x} T. 210 | Proof. exists val (fun x => Sub x (inP x)). 211 | abstract (case => x Px; exact: val_inj). 212 | abstract done. 213 | Defined. 214 | End BijT. 215 | 216 | Definition setT_bij (T : finType) : bij {x : T | x \in setT} T := 217 | Eval hnf in subT_bij (@in_setT T). 218 | Arguments setT_bij {T}. 219 | 220 | 221 | (** Useful to obtain bijections with good simplification properties *) 222 | (* not used for now *) 223 | Lemma bij_same A B (f : A -> B) (f_inv : B -> A) (i : bij A B) : 224 | f =1 i -> f_inv =1 i^-1 -> bij A B. 225 | Proof. 226 | move => Hf Hf'. 227 | exists f f_inv; abstract (move => x; by rewrite Hf Hf' ?bijK ?bijK'). 228 | Defined. 229 | Arguments bij_same [A B] f f_inv i _ _. 230 | 231 | 232 | Lemma perm_index_enum (I1 I2 : finType) (f : I1 -> I2) : 233 | bijective f -> perm_eq (index_enum I2) [seq f i | i <- index_enum I1]. 234 | Proof. 235 | move => bij_f. apply: uniq_perm. 236 | - exact: index_enum_uniq. 237 | - rewrite map_inj_uniq. apply: index_enum_uniq. exact: bij_inj. 238 | - case: bij_f => g can_f can_g x. 239 | rewrite -{2}[x]can_g [RHS]mem_map ?mem_index_enum //; exact: can_inj can_f. 240 | Qed. 241 | 242 | Lemma bij_perm_enum (I1 I2 : finType) (f : bij I1 I2) : 243 | perm_eq (index_enum I2) [seq f i | i <- index_enum I1]. 244 | Proof. exact: perm_index_enum. Qed. 245 | -------------------------------------------------------------------------------- /theories/core/bounded.v: -------------------------------------------------------------------------------- 1 | From mathcomp Require Import all_ssreflect. 2 | 3 | Set Implicit Arguments. 4 | Unset Strict Implicit. 5 | Unset Printing Implicit Defensive. 6 | 7 | (** *** A fixpoint operator for bounded recursion *) 8 | 9 | Section Bounded. 10 | Variables (aT rT : Type) (P : aT -> Prop) (x0 : rT). 11 | Variables (measure : aT -> nat) (F : (aT -> rT) -> (aT -> rT)). 12 | 13 | Hypothesis F_wf : 14 | forall f g x, P x -> (forall y, P y -> measure y < measure x -> f y = g y) -> F f x = F g x. 15 | 16 | (** Note: The use of equality here effectively limits this to 17 | functions in one argument *) 18 | Fixpoint F_rec (n : nat) (x : aT) := 19 | if n is n'.+1 then F (F_rec n') x else x0. 20 | 21 | Lemma F_rec_narrow m n x : 22 | P x -> measure x < n -> n <= m -> F_rec m x = F_rec n x. 23 | Proof. 24 | elim: n m x => // => n IHn [//|m] x Px A B /=. 25 | apply: F_wf => // y Py Hy. apply: IHn => //. exact: leq_trans Hy _. 26 | Qed. 27 | 28 | Definition Fix x := F_rec (measure x).+1 x. 29 | 30 | Lemma Fix_eq x : P x -> Fix x = F Fix x. 31 | Proof. 32 | rewrite /Fix /= => Px. apply: F_wf => // y Py Hy. 33 | by rewrite (@F_rec_narrow (measure x) (measure y).+1). 34 | Qed. 35 | 36 | End Bounded. 37 | Arguments Fix_eq [aT rT] P. 38 | 39 | (** Example Instances *) 40 | 41 | Definition const0_rec (F : nat -> nat) n := if n == 0 then 0 else F (n.-1). 42 | 43 | Definition const0 := Fix 1 id const0_rec. 44 | 45 | Lemma const0_eq n : const0 n = if n == 0 then 0 else const0 (n.-1). 46 | Proof. 47 | apply: (Fix_eq xpredT) => // {n} f g n _. 48 | rewrite /const0_rec. case: ifP => // /negbT. 49 | case: n => //= n _ Hfg. exact: Hfg. 50 | Qed. 51 | 52 | (** The following example shows that one can freely combine bounded 53 | recursion with subroutines and big operators *) 54 | 55 | Section Max. 56 | Variable split : nat -> seq nat. 57 | Hypothesis split_lt : forall n m, m \in split n -> m < n. 58 | 59 | Definition foo_rec F n := 60 | if n < 4 then n else \max_(m <- split n) F m. 61 | 62 | Definition foo := Fix 0 id foo_rec. 63 | 64 | Lemma foo_eq n : foo n = if n < 4 then n else \max_(m <- split n) foo m. 65 | Proof. 66 | apply: (Fix_eq xpredT) => // {n} g f n _ H. 67 | rewrite /foo_rec. case: ifP => // _. 68 | apply: eq_big_seq => m /split_lt. exact: H. 69 | Qed. 70 | End Max. -------------------------------------------------------------------------------- /theories/core/completeness.v: -------------------------------------------------------------------------------- 1 | From Coq Require Import Setoid Morphisms Wf_nat. 2 | From mathcomp Require Import all_ssreflect. 3 | From GraphTheory Require Import edone preliminaries bij. 4 | From GraphTheory Require Import setoid_bigop structures mgraph pttdom mgraph2. 5 | From GraphTheory Require Import rewriting reduction open_confluence transfer. 6 | 7 | Set Implicit Arguments. 8 | Unset Strict Implicit. 9 | Unset Printing Implicit Defensive. 10 | Set Bullet Behavior "Strict Subproofs". 11 | 12 | (** * Completeness of the 2pdom axioms *) 13 | 14 | Section s. 15 | Variable A: Type. 16 | Notation term := (pttdom.term A). 17 | Notation nterm := (pttdom.nterm A). 18 | Notation test := (test [the pttdom of term]). 19 | Notation tgraph2 := (graph2 test term). 20 | Notation graph := (graph unit (flat A)). 21 | Notation graph2 := (graph2 unit (flat A)). 22 | Notation step := (@step [the pttdom of term]). 23 | Notation steps := (@steps [the pttdom of term]). 24 | 25 | (* local confluence of the additive, packaged system (Proposition 8.1) *) 26 | Proposition local_confluence G G' H H': 27 | step G G' -> step H H' -> G ≃2p H -> 28 | exists F, steps G' F /\ steps H' F. 29 | Proof. 30 | (* by transferring local confluence of open steps *) 31 | move => GG HH [GH]. 32 | apply ostep_of in GG as [U [[sGU] [UG']]]. 33 | apply ostep_of in HH as [V [[sHV] [VH']]]. 34 | apply oiso_of in GH. 35 | destruct (ostep_iso sGU GH) as [W [sHW UW]]. 36 | destruct (fun HF => local_confluence HF sHV sHW) as [T [sVT sWT]]. by apply GH. 37 | have gT: is_graph T. by eapply osteps_graph, sWT; apply UW. 38 | have gU: is_graph U. by apply UW. 39 | have gV: is_graph V. by apply VH'. 40 | have gW: is_graph W. by apply UW. 41 | apply (steps_of gV gT) in sVT. 42 | apply (steps_of gW gT) in sWT. 43 | exists (pack T); split. 44 | - transitivity (pack W)=>//. apply iso_step. 45 | etransitivity. apply openK. apply iso_of_oiso. 46 | eapply oiso2_trans. apply oiso2_sym. eassumption. assumption. 47 | - transitivity (pack V)=>//. apply iso_step. 48 | etransitivity. apply openK. apply iso_of_oiso. 49 | by apply oiso2_sym. 50 | Qed. 51 | 52 | Definition measure (G: tgraph2) := #|vertex G| + #|edge G|. 53 | 54 | Lemma step_decreases G H: step G H -> measure H < measure G. 55 | Proof. 56 | rewrite /measure. 57 | case; intros=>/=; by rewrite ?card_option ?card_sum ?card_unit ?card_void ?addSnnS ?addnS ?addn0. 58 | Qed. 59 | 60 | Lemma iso_stagnates (G H : tgraph2) : G ≃2p H -> measure H = measure G. 61 | Proof. case. move=>[l _]. by rewrite /measure (card_bij (iso_v l)) (card_bij (iso_e l)). Qed. 62 | 63 | (* confluence, via appropriate variant of Newman's lemma *) 64 | Proposition confluence F: forall G H, steps F G -> steps F H -> exists F', steps G F' /\ steps H F'. 65 | Proof. 66 | induction F as [F_ IH] using (well_founded_induction_type (Wf_nat.well_founded_ltof _ measure)). 67 | move=> G H S. 68 | move: G H S IH => _ H [F G FG|F__ F0 G' G FF0 FG GG] IH FH. 69 | - exists H; split=>//. by rewrite -(inhabits FG: _ ≃2p _). 70 | - move: H FH IH FF0=> _ [F H FH|F F1 H' H FF1 FH HH] IH FF0. 71 | exists G; split=>//. rewrite -(inhabits FH: _ ≃2p _). eauto using cons_step. 72 | destruct (local_confluence FG FH) as [M[GM HM]]. by rewrite -(inhabits FF0: _ ≃2p _). 73 | destruct (fun D => IH G' D _ _ GG GM) as [L[GL ML]]. 74 | rewrite /Wf_nat.ltof -(iso_stagnates (inhabits FF0)). apply /ltP. by apply step_decreases. 75 | have HL: steps H' L by transitivity M. 76 | destruct (fun D => IH H' D _ _ HL HH) as [R[LR HR]]. 77 | rewrite /Wf_nat.ltof -(iso_stagnates (inhabits FF1)). apply /ltP. by apply step_decreases. 78 | exists R. split=>//. by transitivity L. 79 | Qed. 80 | 81 | (* graphs of normal forms are in normal form (i.e., can't reduce) *) 82 | Lemma normal_steps s: forall H : tgraph2 , steps (tgraph_of_nterm s) H -> tgraph_of_nterm s ≃2p H. 83 | Proof. 84 | suff E: forall G H, steps G H -> G ≃2p tgraph_of_nterm s -> G ≃2p H. 85 | by intros; apply E=>//; reflexivity. 86 | destruct 1 as [G H I|G' G H H' I S _]=>//L. 87 | - exfalso. setoid_rewrite (inhabits I: _ ≃2p _) in L. 88 | clear -S L. destruct L as [[L Li Lo]]. generalize (card_bij (iso_e L)). 89 | destruct s; destruct S; simpl in *; (try by rewrite !card_option ?card_sum ?card_unit ?card_void); rewrite /unl in Li, Lo; move=>_. 90 | * generalize (card_bij (iso_v L)). rewrite card_sum !card_unit addnC. 91 | have H: 0 < #|G|. apply /card_gt0P. by exists input. 92 | revert H. case #|G|; discriminate. 93 | * revert Li Lo. 94 | suff E: input=output :>G by congruence. 95 | apply/(card_le1_eqP (A := predT)) => //. 96 | apply iso_v, card_bij in L. rewrite !card_sum !card_unit addnC in L. 97 | by case: L; rewrite ?add0n => ->. 98 | * have E: forall y, L (inr tt) <> L (inl y) by intros y H; generalize (bij_injective (f:=L) H). 99 | case_eq (L (inr tt)); case. 100 | generalize (E input). simpl in *. congruence. 101 | generalize (E output). simpl in *. congruence. 102 | * generalize (endpoint_iso L false None). generalize (endpoint_iso L true None). 103 | have H: L.e None = None by case (L.e None)=>//; repeat case. 104 | rewrite H. case L.d; simpl; congruence. 105 | Qed. 106 | 107 | (* isomorphisms on graphs of normal forms give back equations *) 108 | Lemma normal_iso (s t: nterm): 109 | tgraph_of_nterm s ≃2p tgraph_of_nterm t -> 110 | term_of_nterm s ≡ term_of_nterm t. 111 | Proof. 112 | case s=>[a|a u b]; 113 | case t=>[c|c v d]=>/=; move=> [[h hi ho]]. 114 | - symmetry. by apply (vlabel_iso h tt). 115 | - exfalso. 116 | generalize (bijK' h (inl tt)). generalize (bijK' h (inr tt)). 117 | case (h^-1 (inr tt)). case (h^-1 (inl tt)). congruence. 118 | - exfalso. 119 | generalize (bijK h (inl tt)). generalize (bijK h (inr tt)). 120 | case (h (inr tt)). case (h (inl tt)). congruence. 121 | - generalize (vlabel_iso h (inl tt)). 122 | generalize (vlabel_iso h (inr tt)). 123 | simpl in *. 124 | rewrite hi ho /=. 125 | generalize (elabel_iso h None). 126 | generalize (endpoint_iso h (h.d None) None). 127 | have H: h.e None = None by case (h.e None)=>//; repeat case. rewrite H. 128 | case (iso_d h None)=>/=. by rewrite hi. 129 | intros. symmetry. apply dot_eqv=>//. apply dot_eqv=>//. 130 | Qed. 131 | 132 | (* transferring isomorphisms on letter-labeled graphs to term-labeled graphs *) 133 | Lemma tgraph_graph (u: term): 134 | tgraph_of_term u ≃2 135 | relabel2 (fun _ => 1%CM) (fun x : flat A => pttdom.tm_var x) (graph_of_term u). 136 | Proof. 137 | have ? : 1%CM ≡ (1 ⊗ 1)%CM by move => M; rewrite monU. 138 | induction u=>/=. 139 | - etransitivity. apply (dot_iso2 IHu1 IHu2). symmetry. apply relabel2_dot => //. 140 | - etransitivity. apply (par_iso2 IHu1 IHu2). symmetry. apply relabel2_par=>//. 141 | - etransitivity. apply (cnv_iso2 IHu). symmetry. apply relabel2_cnv=>//. 142 | - etransitivity. apply (dom_iso2 IHu). symmetry. apply relabel2_dom=>//. 143 | - symmetry. apply relabel2_one=>//. 144 | - symmetry. apply relabel2_var=>//. 145 | Qed. 146 | 147 | (* Lemma 5.3 *) 148 | Lemma tgraph_graph_iso (u v: term): 149 | graph_of_term u ≃2p graph_of_term v -> tgraph_of_term u ≃2p tgraph_of_term v. 150 | Proof. 151 | intros [h]. exists. 152 | etransitivity. apply tgraph_graph. 153 | etransitivity. 2: symmetry; apply tgraph_graph. 154 | apply relabel2_iso=>//. 155 | case=>//=??/=->//. 156 | Qed. 157 | 158 | (** main completeness theorem *) 159 | Theorem completeness (u v: term): graph_of_term u ≃2p graph_of_term v -> u ≡ v. 160 | Proof. 161 | move=>/tgraph_graph_iso h. 162 | pose proof (reduce u) as H. 163 | have H' : steps (tgraph_of_term u) (tgraph_of_nterm (nt v)) 164 | by rewrite h; apply reduce. 165 | case (confluence H H')=>F [/normal_steps HF /normal_steps HF']. 166 | rewrite-> (nt_correct u), (nt_correct v). 167 | apply normal_iso. by rewrite HF'. 168 | Qed. 169 | 170 | (** actually an iff since graphs from a 2pdom algebra *) 171 | Theorem soundness_and_completeness (u v: term): graph_of_term u ≃2p graph_of_term v <-> u ≡ v. 172 | Proof. 173 | split => [|uv]; first exact: completeness. 174 | change (graph_of_term u ≡ graph_of_term v). 175 | exact: uv. (* graph_of_term is an evaluation w.r.t. a 2pdom algebra *) 176 | Qed. 177 | 178 | End s. 179 | 180 | -------------------------------------------------------------------------------- /theories/core/cp_minor.v: -------------------------------------------------------------------------------- 1 | From mathcomp Require Import all_ssreflect. 2 | 3 | From GraphTheory Require Import edone preliminaries digraph sgraph minor. 4 | From GraphTheory Require Import checkpoint connectivity excluded set_tac. 5 | 6 | Set Implicit Arguments. 7 | Unset Strict Implicit. 8 | Unset Printing Implicit Defensive. 9 | 10 | Set Bullet Behavior "Strict Subproofs". 11 | 12 | (** * Combined Minor and Checkpoint Properties *) 13 | 14 | (** This file is where we combine the theory of checkpoints and the theory of 15 | minors and prove the lemmas underlying the correctness arguments for the term 16 | extraction function. *) 17 | 18 | Section CheckpointsAndMinors. 19 | Variables (G : sgraph). 20 | Hypothesis (conn_G : connected [set: G]). 21 | 22 | (** ** Collapsing Bags *) 23 | 24 | Lemma collapse_bags (U : {set G}) u0' (inU : u0' \in U) : 25 | let T := U :|: ~: (\bigcup_(x in U) bag U x) in 26 | let G' := sgraph.induced T in 27 | exists phi : G -> G', 28 | [/\ total_minor_map phi, 29 | (forall u : G', val u \in T :\: U -> phi @^-1 u = [set val u]) & 30 | (forall u : G', val u \in U -> phi @^-1 u = bag U (val u))]. 31 | Proof. 32 | move => T G'. 33 | have inT0 : u0' \in T by rewrite !inE inU. 34 | pose u0 : G' := Sub u0' inT0. 35 | pose phi u := if [pick x in U | u \in bag U x] is Some x 36 | then insubd u0 x else insubd u0 u. 37 | exists phi. 38 | have phiU (u : G') : val u \in U -> phi @^-1 u = bag U (val u). 39 | { move => uU. apply/setP => z. rewrite !inE /phi. 40 | case: pickP => [x /andP [X1 X2]|H]. 41 | - rewrite -val_eqE insubdK ?inE ?X1 //. apply/eqP/idP => [<-//|]. 42 | apply: contraTeq => C. 43 | suff S: [disjoint bag U x & bag U (val u)] by rewrite (disjointFr S). 44 | apply: bag_disj => //; exact: CP_extensive. 45 | - move: (H (val u)). rewrite uU /= => ->. 46 | have zU : z \notin U. { move: (H z). by rewrite bag_id andbT => ->. } 47 | have zT : z \in T. 48 | { rewrite !inE (negbTE zU) /=. apply/negP => /bigcupP [x xU xP]. 49 | move: (H x). by rewrite xU xP. } 50 | rewrite -val_eqE insubdK //. by apply: contraNF zU => /eqP->. } 51 | have phiT (u : G') : val u \in T :\: U -> phi @^-1 u = [set val u]. 52 | { move/setDP => [uT uU]. apply/setP => z. rewrite !inE /phi. 53 | case: pickP => [x /andP [xU xP]|H]. 54 | - rewrite -val_eqE insubdK ?inE ?xU // (_ : z == val u = false). 55 | + by apply: contraNF uU => /eqP <-. 56 | + apply: contraTF uT => /eqP ?. subst. 57 | rewrite inE (negbTE uU) /= inE negbK. by apply/bigcupP; exists x. 58 | - have zU : z \notin U. { move: (H z). by rewrite bag_id andbT => ->. } 59 | have zT : z \in T. 60 | { rewrite !inE (negbTE zU) /=. apply/negP => /bigcupP [x xU xP]. 61 | move: (H x). by rewrite xU xP. } 62 | by rewrite -val_eqE insubdK. } 63 | have preim_G' (u : G') : val u \in phi @^-1 u. 64 | { case: (boolP (val u \in U)) => H; first by rewrite phiU // bag_id. 65 | rewrite phiT ?set11 // inE H. exact: valP. } 66 | split => //. 67 | - split. 68 | + move => y. exists (val y). apply/eqP. case: (boolP (val y \in U)) => x_inU. 69 | * by rewrite mem_preim phiU // bag_id. 70 | * rewrite mem_preim phiT inE // x_inU. exact: valP. 71 | + move => y. case: (boolP (val y \in U)) => xU. 72 | * rewrite phiU //. apply: connected_bag => //. exact: CP_extensive. 73 | * rewrite phiT; first exact: connected1. rewrite inE xU. exact: valP. 74 | + move => x y xy. exists (val x); exists (val y). by rewrite !preim_G'. 75 | Qed. 76 | 77 | End CheckpointsAndMinors. 78 | Arguments collapse_bags [G] conn_G U u0' _. 79 | 80 | (** Neighbor Tree Lemma *) 81 | 82 | Definition neighbours (G : sgraph) (x : G) := [set y | x -- y]. 83 | 84 | (** Proposition 21(ii) *) 85 | Definition igraph (G : sgraph) (x y : G) : sgraph := induced (interval x y). 86 | Definition istart (G : sgraph) (x y : G) : igraph x y := Sub x (intervalL x y). 87 | Definition iend (G : sgraph) (x y : G) : igraph x y := Sub y (intervalR x y). 88 | 89 | Arguments add_edge : clear implicits. 90 | Arguments igraph : clear implicits. 91 | Arguments istart {G x y}. 92 | Arguments iend {G x y}. 93 | 94 | (* TOTHINK: This lemma can have a more general statement. 95 | * add_edge preserves sg_iso when the nodes are applied to the actual iso. *) 96 | Lemma add_edge_induced_iso (G : sgraph) (S T : {set G}) 97 | (u v : induced S) (x y : induced T) : 98 | S = T -> val u = val x -> val v = val y -> 99 | diso (add_edge (induced S) u v) (add_edge (induced T) x y). 100 | Proof. 101 | move=> eq_ST eq_ux eq_vy. 102 | have SofT z : z \in T -> z \in S by rewrite eq_ST. 103 | have TofS z : z \in S -> z \in T by rewrite eq_ST. 104 | set g : induced T -> induced S := fun z => Sub (val z) (SofT (val z) (valP z)). 105 | set f : induced S -> induced T := fun z => Sub (val z) (TofS (val z) (valP z)). 106 | apply (@Diso'' (add_edge (induced S) _ _) (add_edge (induced T) _ _) f g); rewrite {}/f {}/g. 107 | - move => ?. exact: val_inj. 108 | - move => ?. exact: val_inj. 109 | - move => a b; rewrite /edge_rel /= /edge_rel /=. 110 | rewrite -!(inj_eq val_inj) /=. by rewrite eq_ux eq_vy. 111 | - move => a b. rewrite /edge_rel /= /edge_rel /=. 112 | rewrite -!(inj_eq val_inj) /=. by rewrite eq_ux eq_vy. 113 | Qed. 114 | 115 | (** ** K4-freenes of Intervals *) 116 | 117 | Lemma igraph_K4F (G : sgraph) (i o x y : G) : 118 | connected [set: G] -> 119 | x \in cp i o -> y \in cp i o -> x != y -> 120 | K4_free (add_edge G i o) -> 121 | K4_free (add_edge (igraph G x y) istart iend). 122 | Proof. 123 | set H := add_edge G i o. 124 | set I := add_edge _ _ _. 125 | move=> G_conn x_cpio y_cpio xNy; apply: minor_K4_free. 126 | have iNo : i != o. 127 | { apply: contra_neq xNy => x_y. move: x_cpio y_cpio. 128 | by rewrite -{}x_y cpxx !inE =>/eqP->/eqP->. } 129 | 130 | have conn_io : connect sedge i o := connectedTE G_conn i o. 131 | wlog x_le_y : x y @I x_cpio y_cpio xNy / cpo conn_io x y. 132 | { move=> Hyp. case/orP: (cpo_total conn_io x y); first exact: Hyp. 133 | move=> ?; suff : minor (add_edge (igraph G y x) istart iend) I. 134 | { by apply: minor_trans; apply: Hyp; rewrite // 1?sg_sym 1?eq_sym. } 135 | apply: strict_is_minor; apply: iso_strict_minor. 136 | setoid_rewrite add_edge_sym. 137 | by apply: add_edge_induced_iso; first exact: interval_sym. } 138 | 139 | pose U2 := [set x; y]. 140 | (* As a consequence, i (resp. o) is the the bag of x (resp. y) with 141 | * respect to {x, y}. *) 142 | have [i_Px o_Py] : i \in bag U2 x /\ o \in bag U2 y. 143 | { split; apply/bagP=> z; rewrite CP_set2 (cpo_cp x_cpio y_cpio x_le_y); 144 | move=> /andP[z_cpio] /andP[x_le_z z_le_y]. 145 | + rewrite (cpo_cp (mem_cpl i o) z_cpio); 146 | repeat (apply/andP; split) => //; exact: cpo_min. 147 | + have o_cpio : o \in cp i o by rewrite cp_sym mem_cpl. 148 | rewrite cp_sym (cpo_cp z_cpio o_cpio); 149 | repeat (apply/andP; split) => //; exact: cpo_max. } 150 | 151 | case: (collapse_bags G_conn U2 x _); first by rewrite !inE eqxx. 152 | set T := U2 :|: _. have {T}-> : T = interval x y. 153 | { rewrite {}/T {-3}/U2 /interval bigcup_setU !bigcup_set1. 154 | congr ([set x; y] :|: _). 155 | rewrite -setTD (sinterval_bag_cover G_conn xNy). 156 | rewrite setUAC setDUl setDv set0U; apply/setDidPl. 157 | rewrite disjoint_sym disjoints_subset subUset -!disjoints_subset. 158 | by rewrite {2}sinterval_sym !interval_bag_disj //; 159 | apply: CP_extensive; rewrite !inE eqxx. } 160 | rewrite -[induced _]/(igraph G x y). set Gxy := igraph G x y in I *. 161 | 162 | move=> phi [[phi_surj preim_phi_conn phi_edge] preim_phi preim_phixy]. 163 | apply: strict_is_minor. exists phi; split; first exact: phi_surj. 164 | + move=> u; have u_I : val u \in interval x y := valP u. 165 | case: (boolP (val u \in U2)) => u_xy. 166 | - rewrite preim_phixy //. apply: add_edge_connected. 167 | apply: (@connected_bag G G_conn (val u) U2). 168 | exact: CP_extensive. 169 | - rewrite preim_phi; first exact: connected1. 170 | by rewrite inE u_xy u_I. 171 | + move=> u v /orP[]. 172 | - move/phi_edge => [u'] [v'] [? ? uv']. 173 | by exists u'; exists v'; split; rewrite /edge_rel //= uv'. 174 | - wlog [-> -> _] : u v / u = istart /\ v = iend. 175 | { case/(_ istart iend); [ by split | by rewrite /= !eqxx xNy | ]. 176 | move=> u' [v'] [? ? ?]. have ? : v' -- u' by rewrite sg_sym. 177 | case/orP=> /andP[_]/andP[/eqP->/eqP->]; 178 | [ by exists u'; exists v' | by exists v'; exists u' ]. } 179 | rewrite 2?preim_phixy ?inE ?eqxx // ![val _]/=. 180 | by exists i; exists o; split; rewrite /edge_rel //= iNo !eqxx. 181 | Qed. 182 | 183 | Lemma igraph_K4F_add_node (G : sgraph) (U : {set G}) : 184 | connected [set: G] -> forall x y, x \in CP U -> y \in CP U -> x != y -> 185 | K4_free (add_node G U) -> K4_free (add_edge (igraph G x y) istart iend). 186 | Proof. 187 | set H := add_node G U => G_conn x y x_cp y_cp xy H_K4F. 188 | set I := add_edge _ _ _. 189 | 190 | case: (CP_base x_cp y_cp) => [i] [o] [i_U o_U]. 191 | rewrite subUset !sub1set =>/andP[x_cpio y_cpio]. 192 | suff : K4_free (add_edge G i o) by exact: igraph_K4F => //. 193 | set K := add_edge G i o. 194 | apply: minor_K4_free H_K4F. apply: strict_is_minor. 195 | 196 | set phi : H -> K := odflt i. 197 | have preim_phi u : 198 | phi @^-1 u = Some u |: if u == i then [set None] else set0. 199 | { by apply/setP=> v; case: ifP => u_i; rewrite -mem_preim !inE ?orbF; 200 | case: v => [v|] //=; rewrite eq_sym. } 201 | have preim_phixx u : Some u \in phi @^-1 u by rewrite -mem_preim. 202 | 203 | exists phi; split. 204 | + by move=> /= u; exists (Some u). 205 | + move=> /= u; rewrite preim_phi. 206 | case: ifP => [/eqP{u}->|_]; first exact: connected2. 207 | by rewrite setU0; exact: connected1. 208 | + move=> u v /orP[]; first by [ exists (Some u); exists (Some v); split ]. 209 | move=> /orP[]/andP[_]/andP[/eqP->/eqP->]; 210 | [ exists None; exists (Some o) | exists (Some o); exists None ]; 211 | by split; rewrite // -mem_preim. 212 | Qed. 213 | 214 | (** ** Parallel Split Lemma *) 215 | 216 | Lemma sepatates_cp (G : sgraph) (x y z : G) : separates x y [set z] -> z \in cp x y :\: [set x; y]. 217 | Proof. 218 | case. rewrite !inE ![z == _]eq_sym => /negbTE-> /negbTE-> /= H. 219 | apply/cpP => p. by case: (H p) => z' Hz /set1P <-. 220 | Qed. 221 | 222 | (** TOTHINK: Make this the definition of the link relation? Is the 223 | link relation realiy needed in the first place ? *) 224 | Lemma link_rel_sep2 (G : sgraph) (x y : G) : 225 | connected [set: G] -> ~~ x -- y -> link_rel x y -> 226 | x != y /\ forall S, separates x y S -> 2 <= #|S|. 227 | Proof. 228 | move => con_G xNy /andP [xDy cp_sub]. split => // S sep_xy. 229 | case E : #|S| => [|[|//]]. 230 | - move/cards0_eq : E => E. subst S. move/connectedTE : con_G => /(_ x y). 231 | apply: contraTT => _. exact/separates0P. 232 | - move/eqP/cards1P : E => [z Hz]. subst. move/sepatates_cp in sep_xy. by set_tac. 233 | Qed. 234 | 235 | 236 | Lemma set_pred0 (T : finType) : @set0 T =i pred0. 237 | Proof. move => z. by rewrite !inE. Qed. 238 | #[export] 239 | Hint Resolve set_pred0 : core. 240 | 241 | Lemma irred_in_sinterval (G : sgraph) (i o : G) (p : Path i o) : 242 | irred p -> {subset interior p <= sinterval i o}. 243 | Proof. 244 | move => Ip u. rewrite 5!inE negb_or -andbA => /and3P [U1 U2 U3]. 245 | case/(isplitP Ip) : U3 => {p Ip} p1 p2 Ip1 Ip2 I. apply/sintervalP2. split. 246 | - exists (prev p1); rewrite ?irred_rev // inE. apply: contraNN U2 => in_p. by rewrite [o]I. 247 | - exists p2 => //. apply: contraNN U1 => in_p. by rewrite [i]I. 248 | Qed. 249 | 250 | Open Scope implicit_scope. 251 | 252 | Lemma ssplit_K4_nontrivial (G : sgraph) (i o : G) : 253 | ~~ i -- o -> link_rel i o -> K4_free (add_edge G i o) -> 254 | (* bag [set i;o] i = [set i] -> *) 255 | connected [set: G] -> disconnected (sinterval i o). 256 | Proof. 257 | move => io1 L K4F conn_G. case: (link_rel_sep2 conn_G io1 L) => io2 io3 {L}. 258 | case: (theta io1 io2 io3) => p indep_p. 259 | case: (theta_vertices p io2 io1) => x in_p. 260 | apply/disconnectedE => conn_io. 261 | have in_io j : x j \in sinterval i o. 262 | { apply: irred_in_sinterval (in_p _). exact: valP. } 263 | case: (path_in_connected conn_io (in_io ord0) (in_io ord1)) => q' Iq /subsetP sub_io. 264 | case: (split_at_first (A := mem (interior (p ord1))) (p := q') (k := x ord1)). 265 | all: try by [exact: in_p|]. 266 | move => x2 [q1'] [q2] [E Q1 Q2]. 267 | have Iq1 : irred q1'. move: Iq. rewrite E. by case/irred_catE. 268 | apply: K4F. 269 | case: (add_edge_Path i o (p ord0)) => p0 N0. 270 | case: (add_edge_Path i o (p ord1)) => p1 N1. 271 | case: (add_edge_Path i o q1') => q Nq. 272 | have io : i -- o :> add_edge G i o by rewrite /edge_rel/= io2 !eqxx. 273 | pose p2 := edgep io. 274 | apply (@K4_of_paths (add_edge G i o)) with i o (x ord0) x2 p0 p1 p2 q => //. 275 | - rewrite (independent_nodes N0 N1). exact: indep_p. 276 | - by rewrite /independent interior_edgep disjoint_sym eq_disjoint0. 277 | - by rewrite /independent interior_edgep disjoint_sym eq_disjoint0. 278 | - by rewrite (interior_eq_nodes N0). 279 | - by rewrite (interior_eq_nodes N1). 280 | - rewrite (irred_eq_nodes N0). exact: valP. 281 | - rewrite (irred_eq_nodes N1). exact: valP. 282 | - exact: irred_edge. 283 | - by rewrite (irred_eq_nodes Nq). 284 | - apply/disjointP => z. rewrite (mem_eq_nodes Nq) => z_q1'. case/set2P => [?|?]; subst. 285 | + move: (sub_io i). by rewrite sinterval_bounds !inE z_q1' => /(_ isT). 286 | + move: (sub_io o). by rewrite sinterval_bounds !inE z_q1' => /(_ isT). 287 | - move => z. rewrite (interior_edgep) inE /= in_set0 orbF (mem_eq_nodes Nq). 288 | rewrite (interior_eq_nodes N1). exact: Q2. 289 | Qed. 290 | 291 | Close Scope implicit_scope. 292 | -------------------------------------------------------------------------------- /theories/core/dune: -------------------------------------------------------------------------------- 1 | (coq.theory 2 | (name GraphTheory.core) 3 | (package coq-graph-theory) 4 | (synopsis "Graph theory definitions and results in Coq and MathComp") 5 | (flags :standard 6 | -w -notation-overridden 7 | -w -redundant-canonical-projection 8 | -w -projection-no-head-constant 9 | -w -duplicate-clear 10 | -w -elpi.add-const-for-axiom-or-sectionvar 11 | -w -ambiguous-paths)) 12 | -------------------------------------------------------------------------------- /theories/core/edone.v: -------------------------------------------------------------------------------- 1 | (* (c) Copyright Christian Doczkal, Saarland University *) 2 | (* Distributed under the terms of the CeCILL-B license *) 3 | 4 | (** * A slightly more powerful done tactic 5 | 6 | We replace the default implementation of [done] by one that 7 | - tries setoid reflexivity 8 | - uses [eassumption] rather than [assumption] 9 | - applies the right hand side simplifications for Boolean operations 10 | *) 11 | 12 | From Coq Require Import Setoid Morphisms. 13 | From mathcomp Require Import ssreflect ssrbool. 14 | 15 | Ltac done := trivial; hnf in |- *; intros; 16 | ( 17 | solve [ 18 | (do ! 19 | [ reflexivity 20 | | solve [ trivial | apply : sym_equal; trivial ] 21 | | discriminate 22 | | contradiction 23 | | split 24 | | apply/andP;split 25 | | rewrite ?andbT ?andbF ?orbT ?orbF ] 26 | ) 27 | | match goal with 28 | | H:~ _ |- _ => solve [ case H; trivial ] 29 | end 30 | ] 31 | ). 32 | -------------------------------------------------------------------------------- /theories/core/equiv.v: -------------------------------------------------------------------------------- 1 | From Coq Require Import RelationClasses Setoid Morphisms List. 2 | From mathcomp Require Import all_ssreflect. 3 | From GraphTheory Require Import preliminaries bij finite_quotient. 4 | 5 | Set Implicit Arguments. 6 | Unset Strict Implicit. 7 | Unset Printing Implicit Defensive. 8 | 9 | Set Bullet Behavior "Strict Subproofs". 10 | 11 | 12 | 13 | Lemma equiv_of_class (T : finType) (e : rel T) : equiv_class_of (equiv_of e). 14 | Proof. constructor; auto using equiv_of_refl, equiv_of_sym, equiv_of_trans. Qed. 15 | 16 | Canonical equiv_of_equivalence (T : finType) (e : rel T) := EquivRelPack (equiv_of_class e). 17 | 18 | Lemma equiv_ofE (T1 T2 : finType) (e1 : rel T1) (e2 : equiv_rel T2) (f : T1 -> T2) x y : 19 | (forall u v : T1, e1 u v -> e2 (f u) (f v)) -> equiv_of e1 x y -> e2 (f x) (f y). 20 | Proof. 21 | move => H. case/connectP => p. elim: p x => /= [x _ -> //|z p IH x /andP [xz] pth_p lst_p]. 22 | apply: equiv_trans (IH _ pth_p lst_p). 23 | case/orP : xz; [exact: H|rewrite equiv_sym; exact: H]. 24 | Qed. 25 | 26 | Lemma equiv_of_transfer (T1 T2 : finType) (e1 : rel T1) (e2 : rel T2) (f : T1 -> T2) x y : 27 | (forall u v : T1, e1 u v -> equiv_of e2 (f u) (f v)) -> 28 | equiv_of e1 x y -> equiv_of e2 (f x) (f y). 29 | Proof. exact: equiv_ofE. Qed. 30 | 31 | Definition pairs A := seq (A*A). 32 | Definition map_pairs A B (f: A -> B): pairs A -> pairs B := map (fun x => (f x.1,f x.2)). 33 | 34 | 35 | Definition rel_of_pairs (A : eqType) (l : pairs A) : rel A := [rel x y | (x,y) \in l]. 36 | Definition eqv_clot (T : finType) (l : pairs T) : equiv_rel T := 37 | (* equiv_of_equivalence (rel_of_pairs l). *) 38 | locked [equiv_rel of equiv_of (rel_of_pairs l)]. 39 | 40 | Lemma eqv_clotE (T : finType) (l : pairs T) x y : 41 | eqv_clot l x y = equiv_of (rel_of_pairs l) x y. 42 | Proof. by rewrite /eqv_clot -lock. Qed. 43 | 44 | (* move to equiv.v *) 45 | Lemma eqv_clot_pair (A : finType) (h : pairs A) x y : (x, y) \in h -> eqv_clot h x y. 46 | Proof. move => H. rewrite eqv_clotE. exact: sub_equiv_of. Qed. 47 | 48 | Lemma rel_of_pairs_mono (T : finType) (l l' : pairs T) : 49 | {subset l <= l'} -> subrel (rel_of_pairs l) (rel_of_pairs l'). 50 | Proof. move => sub_l x y. exact: sub_l. Qed. 51 | 52 | Lemma eqv_clot_subset (T : finType) (l1 l2 : pairs T) : 53 | {subset l1 <= l2} -> subrel (eqv_clot l1) (eqv_clot l2). 54 | Proof. 55 | move => H x y. rewrite !eqv_clotE. apply: equiv_of_transfer => u v. 56 | move => R. apply: sub_equiv_of. exact: rel_of_pairs_mono R. 57 | Qed. 58 | Arguments eqv_clot_subset [T] l1 [l2]. 59 | 60 | Lemma subset_catL (T : eqType) (h k : seq T) : {subset h <= h ++ k}. 61 | Proof. move => x H. by rewrite mem_cat H. Qed. 62 | Lemma subset_catR (T : eqType) (h k : seq T) : {subset k <= h ++ k}. 63 | Proof. move => x H. by rewrite mem_cat H orbT. Qed. 64 | #[export] 65 | Hint Resolve subset_catL subset_catR : core. 66 | Lemma subset_tl (T : eqType) z (l : seq T) : {subset l <= z :: l}. 67 | Proof. move => x y. exact: mem_tail. Qed. 68 | #[export] 69 | Hint Resolve subset_tl : core. 70 | 71 | (* this should be eqv_clot_map, the other lemma should use the _inj suffix *) 72 | Lemma eqv_clot_map' (aT rT : finType) (f : aT -> rT) (l : pairs aT) x y : 73 | eqv_clot l x y -> eqv_clot (map_pairs f l) (f x) (f y). 74 | Proof. 75 | rewrite eqv_clotE /=. apply: equiv_ofE => {x y} x y H. 76 | apply: eqv_clot_pair. by apply/mapP; exists (x,y). 77 | Qed. 78 | 79 | Lemma eqv_clot_iso (A B: finType) (h: bij A B) (l: pairs A): 80 | map_equiv h^-1 (eqv_clot l) =2 eqv_clot (map_pairs h l). 81 | Proof. 82 | move => x y. rewrite /map_equiv/map_equiv_rel/=. apply/idP/idP. 83 | - move/(eqv_clot_map' h). by rewrite !bijK'. 84 | - move/(eqv_clot_map' h^-1). rewrite /map_pairs -map_comp map_id_in //. 85 | move => {x y} x y /=. by rewrite !bijK -surjective_pairing. 86 | Qed. 87 | 88 | (* TOTHINK: eliminate? *) 89 | Lemma equiv_of_sub (T : finType) (e1 e2 : rel T) : 90 | subrel e1 e2 -> reflexive e2 -> symmetric e2 -> transitive e2 -> subrel (equiv_of e1) e2. 91 | Proof. 92 | move => sub2 refl2 sym2 trans2 x y. case/connectP => p. 93 | elim: p x => [x _ -> //|a p IHp x] /= /andP [/orP H] pth lst. 94 | apply: trans2 _ (IHp _ pth lst). case: H; last rewrite sym2; exact: sub2. 95 | Qed. 96 | 97 | Lemma equiv_of_sub' (T : finType) (e1 : rel T) (e2 : equiv_rel T) : 98 | subrel e1 e2 -> subrel (equiv_of e1) e2. 99 | Proof. move => sub. apply: equiv_of_sub => //; auto using equiv_sym, equiv_trans. Qed. 100 | 101 | (* TODO: preliminaries *) 102 | Lemma eq_equiv (T : finType) (e : equiv_rel T) x y : x = y -> e x y. 103 | Proof. by move->. Qed. 104 | 105 | Lemma eqv_clot_trans (T: finType) (z x y: T) (l: pairs T): 106 | eqv_clot l x z -> eqv_clot l z y -> eqv_clot l x y. 107 | Proof. exact: equiv_trans. Qed. 108 | 109 | #[export] 110 | Instance equiv_rel_Equivalence T (e : equiv_rel T) : Equivalence [eta e]. 111 | Proof. split => // [x y|x y z]; by [rewrite equiv_sym | apply: equiv_trans]. Qed. 112 | 113 | Lemma eqv_clot_hd (T: finType) (x y: T) (l: pairs T): eqv_clot ((x,y)::l) x y. 114 | Proof. apply: eqv_clot_pair. exact: mem_head. Qed. 115 | 116 | Lemma eqv_clot_hd' (T: finType) (x y: T) (l: pairs T): eqv_clot ((x,y)::l) y x. 117 | Proof. symmetry. apply eqv_clot_hd. Qed. 118 | 119 | Lemma eqv_clot_tl (T: finType) (x y: T) z (l: pairs T): 120 | eqv_clot l x y -> 121 | eqv_clot (z::l) x y. 122 | Proof. exact: eqv_clot_subset. Qed. 123 | 124 | Lemma ForallE (T : eqType) (P : T -> Prop) (s : list T) : 125 | List.Forall P s <-> (forall x, x \in s -> P x). 126 | Proof. 127 | split. 128 | - elim => //= {s} x s Px _ H. exact/all_cons. 129 | - elim: s => // x s IH /all_cons [Px Ps]. by constructor; auto. 130 | Qed. 131 | 132 | Lemma eqv_clot_subrel (T: finType) (h k: pairs T): 133 | List.Forall (fun p => eqv_clot k p.1 p.2) h -> 134 | subrel (eqv_clot h) (eqv_clot k). 135 | Proof. rewrite ForallE=>H x y. rewrite eqv_clotE. apply equiv_of_sub'=> u v. exact (H (u,v)). Qed. 136 | 137 | (* Better formulation ? *) 138 | Lemma eqv_clot_eq (T: finType) (h k: pairs T): 139 | List.Forall (fun p => eqv_clot k p.1 p.2) h -> 140 | List.Forall (fun p => eqv_clot h p.1 p.2) k -> 141 | eqv_clot h =2 eqv_clot k. 142 | Proof. move=> A B x y. by apply/idP/idP; apply eqv_clot_subrel. Qed. 143 | 144 | Lemma kernel_eqv_clot {A: finType} {B:eqType} (l: pairs A) (f: A -> B): 145 | List.Forall (fun p => f p.1 = f p.2) l -> 146 | (forall x y, f x = f y -> eqv_clot l x y) -> 147 | (forall x y, reflect (kernel f x y) (eqv_clot l x y)). 148 | Proof. 149 | move => /ForallE H1 H2 x y. apply: (iffP idP); last exact: H2. 150 | move => E. apply/kernelP. 151 | suff: subrel (eqv_clot l) (EquivRelPack (kernel_equivalence f)) by apply. 152 | rewrite /eqv_clot -lock. apply equiv_of_sub'. 153 | by move => {E x y} x y /= /H1/eqP. 154 | Qed. 155 | 156 | Lemma eq_equiv_class (T : eqType) : equiv_class_of (@eq_op T). 157 | Proof. split => //. exact: eq_op_trans. Qed. 158 | Canonical eqv_equiv (T : eqType) := EquivRelPack (@eq_equiv_class T). 159 | 160 | Lemma eqv_clot_nothing (T : finType) (h : pairs T) : 161 | List.Forall (fun p => p.1 = p.2) h -> eqv_clot h =2 eq_op. 162 | Proof. 163 | move => /ForallE H x y. rewrite eqv_clotE /= in H *. 164 | apply/idP/idP; last by move/eqP->. 165 | by apply: equiv_ofE => /= u v /H /= ->. 166 | Qed. 167 | 168 | Lemma eqv_clot_nothing' (T : finType) (h : pairs T) : 169 | List.Forall (fun p => p.1 = p.2) h -> forall x y, eqv_clot h x y -> x=y. 170 | Proof. 171 | intro H. apply eqv_clot_nothing in H. 172 | intros x y. rewrite H. apply /eqP. 173 | Qed. 174 | 175 | 176 | (* TODO: move to preliminaries *) 177 | Section eqv_inj. 178 | Variables (T1 T2 : finType) (e1 : rel T1) (e2 : rel T2) (f : T1 -> T2). 179 | Hypothesis eq_e : forall u v, e1 u v = e2 (f u) (f v). 180 | Hypothesis eq2E : forall u' v', e2 u' v' -> exists u v, u' = f u /\ v' = f v. 181 | Hypothesis f_inj : injective f. 182 | 183 | Lemma equiv_of_ff x y : equiv_of e2 (f x) (f y) = equiv_of e1 x y. 184 | Proof. 185 | apply/idP/idP. 186 | - case/connectP => p. elim: p x => /= [|u' p IH] x. 187 | + by move => _ /f_inj ->. 188 | + case/andP => A B C. case/orP : A => A. 189 | * move/eq2E : (A) => [?] [v] [_ ?]. subst. 190 | apply: connect_trans (connect1 _) (IH _ B C). by rewrite /= !eq_e A. 191 | * move/eq2E : (A) => [v] [?] [? _]. subst. 192 | apply: connect_trans (connect1 _) (IH _ B C). by rewrite /= !eq_e A orbT. 193 | - apply: equiv_of_transfer => {x y} u v H. apply: sub_equiv_of. by rewrite -eq_e. 194 | Qed. 195 | 196 | Lemma equiv_of_nn x y : x \notin codom f -> equiv_of e2 x y -> x = y. 197 | Proof. 198 | move => xf. case/connectP => p. elim: p x xf => /=; auto. 199 | move => z p _ x xf /andP[E _] _. apply: contraNeq xf => _. 200 | case/orP : E => /eq2E [?] [?] [? ?]; subst; exact: codom_f. 201 | Qed. 202 | 203 | Lemma equiv_of_fn x y : y \notin codom f -> equiv_of e2 (f x) y = false. 204 | Proof. 205 | move => yf. apply: contraNF (yf). rewrite equiv_sym/=. 206 | move/equiv_of_nn -> => //. exact: codom_f. 207 | Qed. 208 | End eqv_inj. 209 | 210 | Lemma rel_of_pairs_map_eq (H G : eqType) (l : pairs G) (f : G -> H) : 211 | injective f -> 212 | forall u v, rel_of_pairs l u v = rel_of_pairs (map_pairs f l) (f u) (f v). 213 | Proof. 214 | move => f_inj u v. rewrite /rel_of_pairs/= /map_pairs. 215 | apply/idP/mapP => [uv_l|[[u' v'] uv_l]]; first by exists (u,v). 216 | case. by do 2 move/f_inj ->. 217 | Qed. 218 | 219 | Lemma rel_of_pairs_mapE (H G : eqType) (l : pairs G) (f : G -> H) (u' v' : H) : 220 | rel_of_pairs (map_pairs f l) u' v' -> exists u v : G, u' = f u /\ v' = f v. 221 | Proof. 222 | rewrite /rel_of_pairs/= /map_pairs. case/mapP => [[u v]] /= ? [? ?]. by exists u; exists v. 223 | Qed. 224 | 225 | Lemma eqv_clot_map (H G : finType) (x y : G) (l : pairs G) (f : G -> H) : 226 | injective f -> 227 | eqv_clot (map_pairs f l) (f x) (f y) = eqv_clot l x y. 228 | Proof. 229 | move => inj_f. rewrite /eqv_clot -!lock /=. apply: equiv_of_ff => //. 230 | exact: rel_of_pairs_map_eq. 231 | exact: rel_of_pairs_mapE. 232 | Qed. 233 | 234 | Lemma eqv_clot_mapF (H G : finType) (x : G) (y : H) (l : pairs G) (f : G -> H) : 235 | injective f -> y \notin codom f -> 236 | eqv_clot (map_pairs f l) (f x) y = false. 237 | Proof. 238 | move => inj_f. rewrite /eqv_clot -!lock /=. apply: equiv_of_fn => //. 239 | exact: rel_of_pairs_mapE. 240 | Qed. 241 | 242 | Lemma eqv_clot_map_eq (H G : finType) (x y : H) (l : pairs G) (f : G -> H) : 243 | x \notin codom f -> 244 | eqv_clot (map_pairs f l) x y = (x == y). 245 | Proof. 246 | move => cd_x. apply/idP/eqP; last by move => ->. 247 | rewrite /eqv_clot -!lock /=. apply: equiv_of_nn cd_x => //. 248 | exact: rel_of_pairs_mapE. 249 | Qed. 250 | 251 | Lemma eqv_clot_cat (A: finType) (h k: pairs A): 252 | equiv_comp (eqv_clot (map_pairs (pi (eqv_clot h)) k)) =2 eqv_clot (h++k). 253 | Proof. 254 | move => x y. symmetry. rewrite /equiv_comp map_equivE/= !eqv_clotE /=. 255 | set e1 := rel_of_pairs _. set e2 := rel_of_pairs _. apply/idP/idP. 256 | - apply: equiv_of_transfer => {x y} u v. 257 | rewrite /e1/rel_of_pairs/= mem_cat. case/orP => H. 258 | + apply: eq_equiv. apply/eqquotP. rewrite eqv_clotE. exact: sub_equiv_of. 259 | + apply: sub_equiv_of. apply/mapP. by exists (u,v). 260 | - suff S (u v : quot (eqv_clot h)): 261 | equiv_of e2 u v -> equiv_of e1 (repr u) (repr v). 262 | { move/S => H. 263 | apply: equiv_trans (equiv_trans _ _). 2: exact: H. 264 | rewrite /= -eqv_clotE. exact: (eqv_clot_subset h) (piK' _ _). 265 | rewrite /= -eqv_clotE equiv_sym. exact: (eqv_clot_subset h) (piK' _ _). } 266 | apply: equiv_of_transfer => {u v} u v /mapP [[u0 v0] H0] [-> ->]. 267 | apply: equiv_trans (equiv_trans _ _). 268 | 2:{ rewrite /= -eqv_clotE. apply: (eqv_clot_subset k) _. done. 269 | rewrite eqv_clotE. apply: sub_equiv_of. exact: H0. } 270 | rewrite equiv_sym. all: rewrite /= -eqv_clotE; exact: (eqv_clot_subset h) (piK' _ _). 271 | Qed. 272 | 273 | (* Inversion lemmas for a single pair *) 274 | 275 | Lemma eqv_clot1E (T : finType) (u v x y : T) : 276 | eqv_clot [:: (u, v)] x y -> [\/ x = y, x = u /\ y = v | x = v /\ y = u]. 277 | Proof. 278 | rewrite eqv_clotE. case/connectP => p. elim: p x => //=. 279 | - firstorder. 280 | - move => a p IHp x /andP[]. rewrite /rel_of_pairs/= !inE !xpair_eqE => A pth lst. 281 | move: (IHp _ pth lst). case/orP : A => /andP [] /eqP ? /eqP ?; subst; firstorder. 282 | Qed. 283 | 284 | Lemma eqv_clot_injL (T1 T2 : finType) (x y : T1) o i : 285 | inl T2 x = inl y %[mod eqv_clot [:: (inl o,inr i)]] -> x = y. 286 | Proof. move/eqquotP. by case/eqv_clot1E => [[]|[//]|[//]]. Qed. 287 | 288 | Lemma eqv_clot_injR (T1 T2 : finType) (x y : T2) o i : 289 | inr T1 x = inr y %[mod eqv_clot [:: (inl o,inr i)]] -> x = y. 290 | Proof. move/eqquotP. by case/eqv_clot1E => [[]|[//]|[//]]. Qed. 291 | 292 | Lemma eqv_clot_LR (T1 T2 : finType) (x : T1) (y : T2) o i : 293 | inl T2 x = inr T1 y %[mod eqv_clot [:: (inl o,inr i)]] -> x = o /\ y = i. 294 | Proof. move/eqquotP. by case/eqv_clot1E => [//|[[->][->]]|[//]]. Qed. 295 | 296 | (* TODO: provide inversion lemmas for the case of two pairs (at least 297 | for the case of inl/inr pairs as used in [par2] *) 298 | 299 | (** Tactics for showing that some concrete equivalence closure 300 | contains a given pair (list of pairs) *) 301 | 302 | Ltac eqv := lazymatch goal with 303 | | |- is_true (equiv (eqv_clot ((?x,?y)::_)) ?x' ?y') => 304 | reflexivity 305 | || (unify x x' ; unify y y'; apply: eqv_clot_hd) 306 | || (unify x y' ; unify y x'; apply: eqv_clot_hd') 307 | || apply: eqv_clot_tl; eqv 308 | end. 309 | Ltac leqv := solve [apply List.Forall_cons;[eqv|leqv] | apply List.Forall_nil]. 310 | 311 | Global Opaque eqv_clot. 312 | -------------------------------------------------------------------------------- /theories/core/extraction_top.v: -------------------------------------------------------------------------------- 1 | From Coq Require Import RelationClasses Morphisms Setoid. 2 | 3 | From mathcomp Require Import all_ssreflect. 4 | 5 | From GraphTheory Require Import edone finite_quotient preliminaries set_tac. 6 | From GraphTheory Require Import digraph sgraph treewidth minor checkpoint. 7 | From GraphTheory Require Import equiv setoid_bigop structures pttdom ptt. 8 | From GraphTheory Require Import mgraph mgraph2 ptt mgraph2_tw2 skeleton. 9 | From GraphTheory Require Import bounded extraction_def extraction_iso excluded. 10 | 11 | Set Implicit Arguments. 12 | Unset Strict Implicit. 13 | Unset Printing Implicit Defensive. 14 | 15 | Set Bullet Behavior "Strict Subproofs". 16 | 17 | Section ExtractionTop. 18 | Variable sym : Type. 19 | Notation graph := (graph unit (flat sym)). 20 | Notation graph2 := (graph2 unit (flat sym)). 21 | Open Scope ptt_ops. 22 | 23 | 24 | (** ** Extraction from Disconnected Graphs *) 25 | 26 | Arguments iso_id {Lv Le G}. 27 | Arguments merge_union_K_l [Lv Le F K i o h] k. 28 | 29 | Lemma iso2_TGT (G : graph2) : top · G · top ≃2 point (G ⊎ g2_top) (inr input) (inr output). 30 | Proof. 31 | rewrite-> topL, topR => /=. 32 | Iso2 (iso_sym (union_A _ _ _)). 33 | Qed. 34 | 35 | Lemma iso2_GTG (G H : graph2) : 36 | G · top · H ≃2 point (G ⊎ H) (unl input) (unr output). 37 | Proof. 38 | rewrite-> topR. 39 | setoid_rewrite-> (merge_iso2 (iso_sym (union_A _ _ _))) => /=. 40 | setoid_rewrite-> (merge_iso2 (union_iso iso_id (union_C _ _))) => /=. 41 | rewrite-> (merge_iso2 (union_A _ _ _)) => /=. 42 | rewrite-> (merge_union_K_l (fun _ => unr input))=>//. 43 | 2: case; apply/eqquotP; by eqv. 44 | apply: merge_nothing. by repeat constructor. 45 | Qed. 46 | 47 | Lemma par_component (G : graph) (H : graph2) : 48 | point (G ⊎ g2_top) (inr input) (inr output) ∥ H ≃2 point (G ⊎ H) (inr input) (inr output). 49 | Proof. 50 | rewrite-> par2C. 51 | setoid_rewrite-> (merge_iso2 (union_A _ _ _)) =>/=. 52 | rewrite-> (merge_union_K_l (fun x: two_graph _ _ => if x then unl input else unl output))=>//=. 53 | setoid_rewrite-> (merge_iso2 (union_C _ _)) =>/=. 54 | apply merge_nothing. by repeat constructor. by case. 55 | move => [[]|[]] /=; apply/eqquotP; eqv. 56 | Qed. 57 | 58 | Notation induced2 := component. 59 | 60 | Lemma component_induced (G : graph2) (C : {set G}) (iC : input \in C) (oC : output \in C) : 61 | component C = point (induced C) (Sub input iC) (Sub output oC). 62 | Proof. 63 | rewrite /induced2. move: (setU11 _ _) => A. move: (setU1r _ _) => B. move: A B. 64 | rewrite (setU1_mem oC) (setU1_mem iC) => A B. 65 | by rewrite (bool_irrelevance A iC) (bool_irrelevance B oC). 66 | Qed. 67 | 68 | Definition component1 (G : graph) (x : G) := 69 | point (induced (@component_of (skeleton G) x)) 70 | (Sub x (@in_component_of (skeleton G) x)) 71 | (Sub x (@in_component_of (skeleton G) x)). 72 | 73 | 74 | Lemma iso2_disconnected_component (G : graph2) x : 75 | input \in ~: @component_of G x -> output \in ~: @component_of G x -> 76 | G ≃2 top · (component1 x · top) ∥ component (~: @component_of G x). 77 | Proof. 78 | move => iC oC. symmetry. 79 | rewrite (component_induced iC oC). 80 | set C := component_of _. 81 | rewrite /component1. 82 | set G1 := point _ _ _. set G2 := point _ _ _. 83 | rewrite -> dot2A,iso2_TGT. simpl. setoid_rewrite -> par_component. 84 | rewrite /G1 /G2 /=. 85 | have comp_C : C \in @components G [set: G]. apply: component_of_components. 86 | Iso2 (iso_component comp_C). 87 | Qed. 88 | 89 | Lemma iso_disconnected_io (G : graph2) : 90 | (forall x : G, (x \in @component_of G input) || (x \in @component_of G output)) -> 91 | output \notin @component_of G input -> 92 | G ≃2 @component1 G input · (top · @component1 G output). 93 | Proof. 94 | move => no_comp dis_io. symmetry. 95 | rewrite -> dot2A. rewrite -> iso2_GTG. 96 | rewrite {1}/component1. rewrite /=. 97 | move: (in_component_of _) => I1. move: (in_component_of _) => I2. 98 | have E : @component_of G output = ~: @component_of G input. 99 | { apply/setP => z. rewrite inE. apply/idP/idP. 100 | - move => Z1. apply: contraNN dis_io => Z2. 101 | by rewrite -(same_component Z2) (same_component Z1). 102 | - move/(_ z) : no_comp. by case: (z \in _). } 103 | rewrite E in I2 *. 104 | move: (@component_of_components G input) => comp_i. 105 | Iso2 (iso_component comp_i). 106 | Qed. 107 | 108 | Lemma CK4F_component (G : graph2) (x : G) : 109 | K4_free (sskeleton G) -> CK4F (component1 x). 110 | Proof. 111 | move => K4F_G. split => //. 112 | - apply: connected_induced. exact: connected_component_of. 113 | - apply: subgraph_K4_free (sub_pointxx _) _. exact: induced_K4_free. 114 | Qed. 115 | 116 | Definition term_of_rec' (t : graph2 -> term sym) (G : graph2) := 117 | if [pick x | (input \notin @component_of G x) && (output \notin @component_of G x)] is Some x 118 | then top · (term_of (component1 x) · top) ∥ t (induced2 (~: component_of x)) 119 | else 120 | if output \in @component_of G input 121 | then term_of G 122 | else term_of (@component1 G input) · (top · term_of (@component1 G output)). 123 | 124 | Definition term_of' := Fix top (fun G : graph2 => #|G|) term_of_rec'. 125 | 126 | Lemma induced2_compN_small (G : graph2) (x : G) : 127 | input \notin @component_of G x -> output \notin @component_of G x -> 128 | #|induced2 (~: @component_of G x)| < #|G|. 129 | Proof. 130 | move => X1 X2. rewrite /= card_sub. apply: proper_card. apply/properP; split => //. 131 | - exact/subsetP. 132 | - exists x => //. rewrite !inE (@in_component_of G) orbF. 133 | apply/negP => /orP[] /eqP ?; subst; by rewrite (@in_component_of G) in X1 X2. 134 | Qed. 135 | 136 | Lemma term_of_rec_eq' (f g : graph2 -> term sym) (G : graph2) : 137 | (forall H : graph2, #|H| < #|G| -> f H = g H) -> term_of_rec' f G = term_of_rec' g G. 138 | Proof. 139 | move => Efg. rewrite /term_of_rec'. case: pickP => [x /andP [X1 X2]|//]. 140 | rewrite Efg //. exact: induced2_compN_small. 141 | Qed. 142 | 143 | Lemma term_of_eq' G : term_of' G = term_of_rec' term_of' G. 144 | Proof. 145 | apply Fix_eq with (fun _ => True) => // f g x _ H. 146 | by apply: term_of_rec_eq'; auto. 147 | Qed. 148 | 149 | Theorem term_of_iso' (G : graph2) : 150 | K4_free (sskeleton G) -> G ≃2 graph_of_term (term_of' G). 151 | Proof. 152 | elim/card_ind : G => G IH K4F_G. 153 | rewrite term_of_eq' /term_of_rec'. case: pickP => [x /andP [X1 X2]|H]. 154 | - rewrite /=. rewrite <- term_of_iso, <- IH. 155 | + apply: iso2_disconnected_component; by rewrite inE. 156 | + exact: induced2_compN_small. 157 | + apply: subgraph_K4_free K4F_G. exact: sskeleton_subgraph_for. 158 | + exact: CK4F_component. 159 | - case: ifP; last first. 160 | + move/negbT => io. 161 | rewrite /=. rewrite <- !term_of_iso; first apply: iso_disconnected_io => //. 162 | * move => x. move/(_ x) : H. apply: contraFT. rewrite negb_or. 163 | by rewrite !(@component_exchange G x). 164 | * exact: CK4F_component. 165 | * exact: CK4F_component. 166 | + move => E. apply: term_of_iso. split => //. 167 | apply: connected_one_component (@component_of_components G input) _. 168 | apply/subsetP => x _. move/(_ x) : H. apply: contraFT => H. 169 | rewrite !(component_exchange x) H /=. by rewrite (same_component E). 170 | Qed. 171 | 172 | Corollary minor_exclusion_2p (G : graph2) : 173 | K4_free (sskeleton G) <-> 174 | exists (T : forest) (B : T -> {set G}), [/\ sdecomp T (sskeleton G) B & width B <= 3]. 175 | Proof. 176 | split => [K4F_G|[T [B [B1 B2 B3]]]]. 177 | - have [T [B] [B1 B2]] := (graph_of_TW2 (term_of' G)). 178 | have I := term_of_iso' K4F_G. symmetry in I. apply sskel_iso2 in I. 179 | have [D D1 D2] := decomp_iso B1 I. 180 | exists T. exists D. by rewrite D2. 181 | - exact: TW2_K4_free B1 B2 B3. 182 | Qed. 183 | 184 | End ExtractionTop. 185 | 186 | (** Remark: contrary to the textbook definition, we do not substract 1 187 | in the definition of treewidth. Consequently, [width <= 3] means 188 | treewidth two. *) 189 | 190 | Corollary graph_minor_TW2 (G : sgraph) : 191 | K4_free G <-> 192 | exists (T : forest) (B : T -> {set G}), sdecomp T G B /\ width B <= 3. 193 | Proof. 194 | split=> [| [T][B][]]; last exact: TW2_K4_free. 195 | case: (posnP #|G|) =>[G_empty | /card_gt0P[x _]]. 196 | { exists tunit; exists (fun _ => [set: G]). split; first exact: triv_sdecomp. 197 | apply: leq_trans (width_bound _) _. by rewrite G_empty. } 198 | move=>HG. 199 | have [G' [iso_G _]] := flesh_out (0 : flat nat) tt x. 200 | apply (iso_K4_free iso_G) in HG. 201 | apply minor_exclusion_2p in HG as (T&B&D&W). 202 | case: (decomp_iso D iso_G) => B' D' W'. 203 | exists T. exists B'. by rewrite W'. 204 | Qed. 205 | 206 | Print Assumptions graph_minor_TW2. 207 | -------------------------------------------------------------------------------- /theories/core/finmap_plus.v: -------------------------------------------------------------------------------- 1 | From mathcomp Require Import all_ssreflect. 2 | From mathcomp Require Export finmap. 3 | 4 | Set Implicit Arguments. 5 | Unset Strict Implicit. 6 | Unset Printing Implicit Defensive. 7 | Set Bullet Behavior "Strict Subproofs". 8 | 9 | Open Scope fset_scope. 10 | 11 | 12 | 13 | Lemma fsval_eqF (T:choiceType) (E : {fset T}) (e : E) x : x \notin E -> val e == x = false. 14 | Proof. apply: contraNF => /eqP <-. exact: fsvalP. Qed. 15 | 16 | Lemma fsetDDD (T : choiceType) (A B C : {fset T}) : A `\` B `\` (C `\` B) = A `\` (B `|` C). 17 | Proof. apply/fsetP => z. rewrite !inE. by case (z \in B). Qed. 18 | 19 | Lemma in_imfsetT (aT : finType) (rT : choiceType) (f : aT -> rT) (x : aT) : 20 | f x \in [fset f x | x in aT]. 21 | Proof. by rewrite in_imfset. Qed. 22 | 23 | Lemma fsetDEl (T : choiceType) (A B : {fset T}) (x : A `\` B) : val x \in A. 24 | Proof. by case/fsetDP : (valP x). Qed. 25 | 26 | Lemma fset1UE (T : choiceType) (x a : T) (A : {fset T}) : 27 | x \in a |` A -> (x = a) + (x != a) * (x \in A). 28 | Proof. rewrite !inE. case: (altP (x =P a)) => /=; [by left|by right;split]. Qed. 29 | 30 | Lemma fsvalK (T : choiceType) (A : {fset T}) (x : A) (p : fsval x \in A) : Sub (fsval x) p = x. 31 | Proof. exact: val_inj. Qed. 32 | 33 | Lemma fsetUDU (T : choiceType) (A B C : {fset T}) : 34 | [disjoint A & B] -> (A `|` B) `\` (A `|` C) = B `\` C. 35 | Proof. 36 | move => disAC. apply/fsetP => x. rewrite !inE. case Hx : (x \in A) => //=. 37 | by rewrite -[x \in B]negbK (fdisjointP disAC) //= andbF. 38 | Qed. 39 | 40 | Lemma cardsDsub (T : choiceType) (A B : {fset T}) : 41 | #|` A `\` B | == 0 -> A `<=` B. 42 | Proof. by rewrite -fsetD_eq0 cardfs_eq0. Qed. 43 | 44 | Lemma cardsIsub (T : choiceType) (A B : {fset T}) : 45 | #|`A `&` B| = #|`B| -> B `<=` A. 46 | Proof. move => H. by rewrite cardsDsub // cardfsD fsetIC H subnn. Qed. 47 | 48 | Lemma fset1U0 (T : choiceType) (x : T) (A : {fset T}) : x |` A != fset0. 49 | Proof. apply: contraFneq (in_fset0 x) => <-. by rewrite !inE eqxx. Qed. 50 | 51 | Lemma fset01 (T : choiceType) (x : T) : [fset x] != fset0. 52 | Proof. by rewrite -[[fset x]]fsetU0 fset1U0. Qed. 53 | 54 | Lemma fset1D (T : choiceType) (x:T) (A : {fset T}) : 55 | [fset x] `\` A = if x \in A then fset0 else [fset x]. 56 | Proof. 57 | case: (boolP (x \in A)) => xA. 58 | - apply/eqP. by rewrite fsetD_eq0 fsub1set. 59 | - apply/fsetDidPl. by rewrite fdisjoint1X. 60 | Qed. 61 | 62 | Lemma imfset0 (aT rT : choiceType) (f : aT -> rT) : [fset f x | x in fset0] = fset0. 63 | Proof. apply/fsetP => z. rewrite inE. apply: contraTF isT. by case/imfsetP. Qed. 64 | 65 | Lemma in_fsep (T : choiceType) (A : {fset T}) (P : pred T) (y : T) : 66 | y \in [fset x | x in A & P x] = (y \in A) && (P y). 67 | Proof. 68 | apply/imfsetP/andP => /= [[x]|[H1 H2]]; first by rewrite inE => /andP[H1 H2] ->. 69 | exists y => //. by rewrite inE H1. 70 | Qed. 71 | 72 | Lemma imfset_sep (T1 T2 : choiceType) (f : T1 -> T2) (A : {fset T1}) (P : pred T1) : 73 | [fset f x | x in [fset x | x in A & P x]] = [fset f x | x in A & P x]. 74 | Proof. 75 | apply/fsetP => x. apply/imfsetP/imfsetP => /=. 76 | - case => x0. rewrite in_fsep => /andP [H1 H2] ->. exists x0 => //. by rewrite inE H1. 77 | - case => x0. rewrite inE => /andP [H1 H2] ->. exists x0 => //. by rewrite in_fset /= inE H1. 78 | Qed. 79 | 80 | (* not used *) 81 | Lemma imfset_comp (T1 T2 T3 : choiceType) (f : T1 -> T2) (g : T2 -> T3) (A : {fset T1}) : 82 | [fset (g \o f) x | x in A] = [fset g x | x in [fset f x | x in A]]. 83 | Abort. 84 | 85 | 86 | Lemma imfset1 (aT rT : choiceType) (f : aT -> rT) (z : aT) : 87 | [fset f x | x in [fset z]] = [fset f z]. 88 | Proof. 89 | apply/fsetP => x. rewrite inE. apply/imfsetP/eqP. 90 | - case => x0 /=. by rewrite inE => /eqP->. 91 | - move => ->. exists z => //. by rewrite inE. 92 | Qed. 93 | 94 | Lemma imfsetU (aT rT : choiceType) (f : aT -> rT) (A B : {fset aT}) : 95 | [fset f x | x in A `|` B] = [fset f x | x in A] `|` [fset f x | x in B]. 96 | Proof. 97 | apply/fsetP => z. rewrite inE. apply/imfsetP/idP. 98 | - case => x0. rewrite !inE. case/orP => H ->; first by rewrite in_imfset. 99 | by rewrite [X in _ || X]in_imfset // orbT. 100 | - case/orP. all:case/imfsetP => z0 /= H ->; exists z0 => //. all: by rewrite !inE H ?orbT. 101 | Qed. 102 | 103 | Lemma imfset1U (aT rT : choiceType) (f : aT -> rT) (z : aT) (A : {fset aT}) : 104 | [fset f x | x in z |` A] = f z |` [fset f x | x in A]. 105 | Proof. by rewrite imfsetU imfset1. Qed. 106 | 107 | 108 | Arguments fset1Ur [K x a B]. 109 | Arguments fset1U1 {K x B}. 110 | Arguments fset1U1 {K x B}. 111 | 112 | (** Things that also depend on preliminaries.v *) 113 | From Coq Require Import Relations.Relation_Definitions. 114 | From GraphTheory Require Import edone preliminaries. 115 | 116 | Lemma fset2_inv (T : choiceType) (x y x' y' : T) : x != y -> 117 | [fset x;y] = [fset x';y'] -> (x = x' /\ y = y') + (x = y' /\ y = x'). 118 | Proof. 119 | move => /negbTE D /fsetP H. move: (H x). rewrite !inE eqxx /= => /esym. 120 | case/orb_sum => /eqP ?;[left|right]; subst; move: (H y). 121 | - rewrite !inE eqxx orbT eq_sym D. by move/esym/eqP. 122 | - rewrite !inE eqxx orbT [y == y']eq_sym D orbF. by move/esym/eqP. 123 | Qed. 124 | 125 | (** uses Sigma *) 126 | Lemma fset2_cases (T : choiceType) (x y x' y' : T) : x != y -> x' != y' -> 127 | let A := [fset x;y] in 128 | let B := [fset x';y'] in 129 | (A = B) + [disjoint A & B] + (Σ z : T, A `&` B = [fset z]). 130 | Proof. 131 | move => D D' A B. 132 | have [CA CB] : #|` A| = 2 /\ #|` B| = 2. 133 | { by rewrite !cardfs2 ?(negbTE D) ?(negbTE D'). } 134 | move C : (#|` A `&` B|) => n. case: n C => [|[|[|]]] => C. 135 | - left;right. by rewrite -fsetI_eq0 (cardfs0_eq C). 136 | - right. 137 | have E : exists z : T, A `&` B == [fset z]. 138 | { setoid_rewrite <- (rwP eqP). apply/cardfs1P. exact/eqP. } 139 | exists (xchoose E). apply/eqP. exact: (xchooseP E). 140 | - left;left. apply/eqP. 141 | by rewrite eqEfsubset !cardsIsub // ?CA ?CB ?[_ `&` A]fsetIC. 142 | - move/eqP. rewrite eqn_leq [C.+3 <= _]negbTE ?andbF // -leqNgt -addn2. 143 | apply: leq_trans (leq_addl _ _). rewrite -CA. 144 | apply: fsubset_leq_card. exact: fsubsetIl. 145 | Qed. 146 | 147 | Lemma imfset_inv (aT : finType) (rT : choiceType) (f : aT -> rT) (y : [fset f x | x in aT]) : 148 | Σ x : aT, f x = val y. 149 | Proof. 150 | suff E : exists x, f x == val y by exists (xchoose E); rewrite (eqP (xchooseP E)). 151 | case/imfsetP : (valP y) => /= x _ ->. by exists x. 152 | Qed. 153 | 154 | Lemma mem_maxn n m (A : {fset nat}) : n \notin A -> m \notin A -> maxn n m \notin A. 155 | Proof. by case: leqP. Qed. 156 | 157 | Lemma maxn_fset2 n m : maxn n m \in [fset n; m]. 158 | Proof. case: leqP; by rewrite !in_fset2 eqxx. Qed. 159 | 160 | Lemma maxn_fsetD n m (A : {fset nat}) : maxn n m \notin A `\` [fset n; m]. 161 | Proof. by rewrite inE negb_and negbK maxn_fset2. Qed. 162 | 163 | Lemma fset2_maxn_neq n m x : x \notin [fset n; m] -> x != maxn n m. 164 | Proof. apply: contraNneq => ->. exact: maxn_fset2. Qed. 165 | 166 | 167 | (** depends on update *) 168 | Lemma in_eqv_update (aT : choiceType) (rT : Type) (f g : aT -> rT) (E : relation rT) 169 | (z : aT) (u v : rT) (A : {fset aT}) : 170 | {in A, forall x : aT, E (f x) (g x)} -> E u v -> 171 | {in z |` A, forall x : aT, E (f[upd z := u] x) (g[upd z := v] x)}. 172 | Proof. 173 | move => H Euv k. rewrite !inE. 174 | case: (altP (k =P z)) => [-> _|? /= inA]; rewrite !updateE //. exact: H. 175 | Qed. 176 | 177 | Lemma eqv_update (aT : eqType) (rT : Type) (f g : aT -> rT) (E : relation rT) z u v : 178 | (forall x, E (f x) (g x)) -> E u v -> forall x, E (f[upd z := u] x) (g[upd z := v] x). 179 | Proof. move => H Euv k. case: (altP (k =P z)) => [->|?]; by rewrite !updateE. Qed. 180 | 181 | 182 | (** Bijections between finite sets *) 183 | From GraphTheory Require Import bij. 184 | 185 | (** TOTHINK: how to have simpl keep the [h/h^-1] notation unless the functions actually reduce? *) 186 | Section Bij. 187 | Variable (G : finType) (T : choiceType) (g : G -> T). 188 | Hypothesis g_inj : injective g. 189 | Let vset := [fset g x | x in G]. 190 | Definition imfset_bij_fwd (x : G) : vset := Sub (g x) (in_imfsetT g x). 191 | Definition imfset_bij_bwd (x : vset) : G := tag (imfset_inv x). 192 | 193 | Lemma can_vset : cancel imfset_bij_fwd imfset_bij_bwd. 194 | Proof. 195 | move => x. rewrite /imfset_bij_fwd /imfset_bij_bwd /=. set S := Sub _ _. 196 | apply: g_inj. by rewrite (tagged (imfset_inv S)). 197 | Qed. 198 | 199 | Lemma can_vset' : cancel imfset_bij_bwd imfset_bij_fwd. 200 | Proof. 201 | move => [x Hx]. rewrite /imfset_bij_fwd /imfset_bij_bwd. apply: val_inj => /=. 202 | by rewrite (tagged (imfset_inv [` Hx])). 203 | Qed. 204 | 205 | Definition imfset_bij := Bij can_vset can_vset'. 206 | 207 | Lemma imfset_bij_bwdE x p : imfset_bij_bwd (Sub (g x) p) = x. 208 | Proof. 209 | rewrite /imfset_bij_bwd. set t := imfset_inv _. 210 | by move/g_inj : (tagged t). 211 | Qed. 212 | 213 | End Bij. 214 | 215 | Lemma fresh_bij (T : finType) (E : {fset nat}) (f : bij T E) e (He : e \notin E) : 216 | bij (option T) (e |` E). 217 | Proof. 218 | pose g (x : option T) : e |` E := 219 | if x is Some z then Sub (val (f z)) (fset1Ur (valP (f z))) else Sub e fset1U1. 220 | pose g_inv (x : e |` E) : option T := 221 | match fsetULVR (valP x) with inl _ => None | inr p => Some (f^-1 (Sub (val x) p)) end. 222 | have @can_g : cancel g g_inv. 223 | { move => [x|]; rewrite /g/g_inv/=; case: (fsetULVR _) => [|p] //=. 224 | - by rewrite inE fsval_eqF. 225 | - by rewrite valK' bijK. 226 | - exfalso. by rewrite p in He. } 227 | have @can_g_inv : cancel g_inv g. 228 | { move => [x Hx]; rewrite /g/g_inv/=. case: (fsetULVR _) => [|p] //=. 229 | - rewrite !inE => A. apply: val_inj => /=. by rewrite (eqP A). 230 | - apply: val_inj => //=. by rewrite bijK'. } 231 | apply: (Bij can_g can_g_inv). 232 | Defined. 233 | 234 | Lemma fresh_bijE (T : finType) (E : {fset nat}) (f : bij T E) x (Hx : x \notin E) : 235 | (forall x, fresh_bij f Hx (Some x) = Sub (val (f x)) (fset1Ur (valP (f x))))* 236 | (fresh_bij f Hx None = Sub x fset1U1). 237 | Proof. done. Qed. 238 | 239 | Lemma fresh_bij' (T : finType) (E : {fset nat}) (f : bij T E) e (He : e \notin E) : 240 | bij (T + unit) (e |` E). 241 | Proof. 242 | pose g (x : T + unit) : e |` E := 243 | if x is inl z then Sub (val (f z)) (fset1Ur (valP (f z))) else Sub e fset1U1. 244 | pose g_inv (x : e |` E) : T + unit := 245 | match fsetULVR (valP x) with inl _ => inr tt | inr p => inl (f^-1 (Sub (val x) p)) end. 246 | have @can_g : cancel g g_inv. 247 | { move => [x|[]]; rewrite /g/g_inv/=; case: (fsetULVR _) => [|p] //=. 248 | - by rewrite inE fsval_eqF. 249 | - by rewrite valK' bijK. 250 | - exfalso. by rewrite p in He. } 251 | have @can_g_inv : cancel g_inv g. 252 | { move => [x Hx]; rewrite /g/g_inv/=. case: (fsetULVR _) => [|p] //=. 253 | - rewrite !inE => A. apply: val_inj => /=. by rewrite (eqP A). 254 | - apply: val_inj => //=. by rewrite bijK'. } 255 | apply: (Bij can_g can_g_inv). 256 | Defined. 257 | 258 | Lemma fresh_bijE' (T : finType) (E : {fset nat}) (f : bij T E) x (Hx : x \notin E) : 259 | (forall x, fresh_bij' f Hx (inl x) = Sub (val (f x)) (fset1Ur (valP (f x))))* 260 | (fresh_bij' f Hx (inr tt) = Sub x fset1U1). 261 | Proof. done. Qed. 262 | 263 | (** not acutally used *) 264 | Definition bij_setD (aT : finType) (C : choiceType) (rT : {fset C}) (A : {set aT}) (f : bij aT rT) : 265 | bij { x | x \in ~: A} (rT `\` [fset val (f x) | x in A]). 266 | Proof. 267 | set aT' := ({ x | _ }). set rT' := _ `\` _. 268 | have @g_proof (x : aT') : val (f (val x)) \in rT'. 269 | { rewrite !inE (valP (f (val x))) andbT. apply: contraTN (valP x). 270 | case/imfsetP => /= x0 inA /val_inj /(@bij_injective _ _ f) ->. by rewrite inE negbK. } 271 | pose g (x : aT') : rT' := Sub (val (f (val x))) (g_proof x). 272 | have @g_inv_proof (x : rT') : f^-1 (Sub (fsval x) (fsetDEl x)) \in ~: A. 273 | { rewrite inE. case/fsetDP: (valP x) => ?. apply: contraNN => X. apply/imfsetP. 274 | exists (f^-1 (Sub (fsval x) (fsetDEl x))) => //. by rewrite bijK'. } 275 | pose g_inv (x : rT') : aT' := Sub (f^-1 (Sub (val x) (fsetDEl x))) (g_inv_proof x). 276 | have @can1 : cancel g g_inv. 277 | { move => [x Hx]. rewrite /g/g_inv. apply: val_inj => /=. apply: (@bij_injective _ _ f). 278 | rewrite bijK'. exact: val_inj. } 279 | have @can2 : cancel g_inv g. 280 | { move => [x Hx]. rewrite /g/g_inv. apply: val_inj => /=. by rewrite bijK'. } 281 | apply: Bij can1 can2. 282 | Defined. 283 | 284 | Section BijCast. 285 | Variables (T : choiceType) (A A' : {fset T}) (eqA : A = A'). 286 | Definition bij_cast : bij A A'. 287 | Proof. case eqA. exact bij_id. Defined. 288 | 289 | Lemma cast_proof x : x \in A -> x \in A'. case eqA. exact id. Qed. 290 | 291 | Lemma bij_castE x (Hx : x \in A) : bij_cast [` Hx] = [` cast_proof Hx]. 292 | Proof. 293 | rewrite /bij_cast. move: (cast_proof _). case eqA => Hx'. exact: val_inj. 294 | Qed. 295 | End BijCast. 296 | 297 | 298 | (* This construction is not actually used *) 299 | 300 | Section FsetU1Fun. 301 | Variables (T : choiceType) (A B : {fset T}) (f : A -> B) (x y : T). 302 | 303 | Definition fsetU1_fun (a : (x |` A)) : (y |`B) := 304 | match fset1UE (fsvalP a) with 305 | | inl _ => Sub y fset1U1 306 | | inr (_,p) => Sub (val (f [` p])) (fset1Ur (valP (f [` p]))) 307 | end. 308 | 309 | 310 | End FsetU1Fun. 311 | Arguments fsetU1_fun [T A B] f x y a. 312 | 313 | Lemma fsetU1_fun_can (T : choiceType) (A B : {fset T}) (x y : T) (f : A -> B) (g : B -> A) : 314 | x \notin A -> y \notin B -> cancel f g -> cancel (fsetU1_fun f x y) (fsetU1_fun g y x). 315 | Proof. 316 | move => Hx Hy can_f a. 317 | rewrite {2}/fsetU1_fun. case: fset1UE => [/=|[D Ha]]. 318 | - rewrite /fsetU1_fun. case: fset1UE => //=. 319 | + move => _ E. apply: val_inj => /=. by rewrite E. 320 | + rewrite eqxx. by case. 321 | - rewrite /fsetU1_fun /=. case: fset1UE. 322 | + move => E. by rewrite -E (fsvalP _) in Hy. 323 | + case => A1 A2. apply: val_inj => //=. 324 | rewrite (_ : [`A2] = (f.[Ha])%fmap) ?can_f //. exact: val_inj. 325 | Qed. 326 | 327 | Section Fresh2Bij. 328 | Variables (T : choiceType) (A B : {fset T}) (x y : T) (f : bij A B) (Hx : x \notin A) (Hy : y \notin B). 329 | 330 | Definition fresh2_bij : bij (x |` A) (y |`B). 331 | Proof. 332 | pose fwd := fsetU1_fun f x y. 333 | pose bwd := fsetU1_fun f^-1 y x. 334 | exists fwd bwd. 335 | - abstract (apply: fsetU1_fun_can => //; exact: bijK). 336 | - abstract (apply: fsetU1_fun_can => //; exact: bijK'). 337 | Defined. 338 | 339 | End Fresh2Bij. 340 | 341 | 342 | Lemma fsetDl (T : choiceType) (A C : {fset T}) k : k \in A `\` C -> k \in A. by case/fsetDP. Qed. 343 | 344 | Section fsetD_bij. 345 | Variables (T : choiceType) (A B C C' : {fset T}) (f : bij A B). 346 | 347 | Hypothesis (E : C' = [fset val (f x) | x : A & val x \in C]). 348 | 349 | Lemma fsetD_bij_fwd_proof (k : A `\` C) : val (f (Sub (val k) (fsetDl (valP k)))) \in B `\` C'. 350 | Proof. 351 | subst. rewrite inE [_ \in B]valP andbT. apply/imfsetP => [/= [x]]. rewrite inE => xC /val_inj. 352 | move/(@bij_injective _ _ f) => ?. subst. rewrite /= in xC. case/fsetDP: (valP k). by rewrite xC. 353 | Qed. 354 | 355 | Lemma fsetD_bij_bwd_proof (k : B `\` C') : val (f^-1 (Sub (val k) (fsetDl (valP k)))) \in A `\` C. 356 | Proof. 357 | subst. rewrite inE [_ \in A]valP andbT. apply: contraTN (valP k) => X. 358 | rewrite inE negb_and negbK. apply/orP;left. apply/imfsetP => /=. 359 | exists (f^-1 (Sub (val k) (fsetDl (valP k)))); by rewrite ?inE ?bijK'. 360 | Qed. 361 | 362 | Definition fsetD_bij_fwd (k : (A `\` C)) : (B `\` C') := [` fsetD_bij_fwd_proof k]. 363 | Definition fsetD_bij_bwd (k : (B `\` C')) : (A `\` C) := [` fsetD_bij_bwd_proof k]. 364 | 365 | Lemma fsetD_bij_can_fwd : cancel fsetD_bij_fwd fsetD_bij_bwd. 366 | Proof. move => x. apply: val_inj => //=. by rewrite !(fsvalK,bijK). Qed. 367 | 368 | Lemma fsetD_bij_can_bwd : cancel fsetD_bij_bwd fsetD_bij_fwd. 369 | Proof. move => x. apply: val_inj => //=. by rewrite !(fsvalK,bijK'). Qed. 370 | 371 | Definition fsetD_bij := Bij fsetD_bij_can_fwd fsetD_bij_can_bwd. 372 | 373 | Lemma fsetD_bijE k (p : k \in A `\` C) q : fsetD_bij (Sub k p) = Sub (val (f (Sub k (fsetDl p)))) q. 374 | apply: val_inj => /=. do 2 f_equal. exact: val_inj. Qed. 375 | End fsetD_bij. 376 | -------------------------------------------------------------------------------- /theories/core/helly.v: -------------------------------------------------------------------------------- 1 | From mathcomp Require Import all_ssreflect. 2 | From GraphTheory Require Import edone preliminaries digraph sgraph set_tac. 3 | 4 | Set Implicit Arguments. 5 | Unset Strict Implicit. 6 | Unset Printing Implicit Defensive. 7 | 8 | (** Preliminaries *) 9 | 10 | Lemma ltn_subn n m o : n < m -> n - o < m. 11 | Proof. apply: leq_ltn_trans. exact: leq_subr. Qed. 12 | 13 | Lemma ord3P (P : 'I_3 -> Type) : P ord0 -> P ord1 -> P ord2 -> forall i : 'I_3, P i. 14 | Proof. 15 | have H (i j : 'I_3) : i == j -> P i -> P j by move/eqP->. 16 | move => P0 P1 P2 [[|[|[|//]]] Hi]. 17 | exact: H P0. exact: H P1. exact: H P2. 18 | Qed. 19 | 20 | (* Notation "A ∩ B" := (A :&: B) (at level 30). *) 21 | 22 | (** We first show that for intersection closed properties, the helly 23 | property of families of size three extends to the families of 24 | arbitrary (finite) cardinalities. *) 25 | 26 | (** TOTHINK: This should extend also to [T:choiceType] using the finmap library *) 27 | Lemma helly3_lifting (T : finType) (P : {set T} -> Prop) : 28 | (forall A B, P A -> P B -> P (A :&: B)) -> 29 | (forall f : 'I_3 -> {set T}, 30 | (forall i, P (f i)) -> (forall i j, f i :&: f j != set0) -> exists x, forall i, x \in f i) -> 31 | forall F : {set {set T}}, 32 | 0 < #|F| -> (forall A, A \in F -> P A) -> {in F &, forall A B, A :&: B != set0} -> exists x, forall A, A \in F -> x \in A. 33 | Proof. 34 | move => closed_P helly3_P. 35 | elim/card_ind => /= F IH inh_F F_sub_P F_pw_in. 36 | case: (ltnP 1 #|F|) => card_F. 37 | - case/card_gt1P : card_F => /= X [Y] [XF YF XY]. 38 | move def_F' : ((F :\: [set X;Y]) :|: [set X :&: Y]) => F'. 39 | have F'_in_U : (forall A, A \in F' -> P A). 40 | { rewrite -def_F'. move => A /setUP [/setDP []|/set1P->]; by auto. } 41 | have F'_pw_in : {in F' &, forall A B : {set T}, A :&: B != set0}. 42 | { move => A B. rewrite -def_F' !in_setU !in_set1 => HA HB. 43 | wlog [HA HB]: A B {HA HB} / A = X :&: Y /\ B \in F. 44 | { move => W. 45 | case/orP : HA => [/setDP [HA _]|/eqP HA]; case/orP : HB => [/setDP [HB _]|/eqP HB]. 46 | - exact: F_pw_in. 47 | - rewrite setIC. by apply: W. 48 | - exact: W. 49 | - rewrite HA HB setIid. exact: F_pw_in. } 50 | rewrite HA. 51 | pose f := tnth [tuple X; Y; B]. 52 | case: (helly3_P f _ _). 53 | - apply: ord3P; by rewrite /f /tnth /=; apply: F_sub_P. 54 | - do 2 apply: ord3P; by rewrite /f /tnth /=; apply: F_pw_in. 55 | - move => x Hx. apply/set0Pn; exists x. rewrite !inE. 56 | move: (Hx ord0) (Hx ord1) (Hx ord2). by rewrite /f /tnth /= => -> -> ->. } 57 | have card_F' : #|F'| < #|F|. 58 | { (* set reasoning with cardinalities *) 59 | rewrite -def_F' cardsU cards1. apply: ltn_subn. 60 | rewrite -setDDl [#|F|](cardsD1 X) [#|F :\ X|](cardsD1 Y). 61 | rewrite !inE XF YF eq_sym XY /= add1n addnC. exact: leqnn. } 62 | have inh_F' : 0 < #|F'|. 63 | { apply/card_gt0P. exists (X :&: Y). by rewrite -def_F' !inE eqxx. } 64 | case: (IH F' _ _ _ _) => // x Hx. 65 | exists x => A A_in_F. case: (boolP ((A == X) || (A == Y))) => H. 66 | + case : (setIP (Hx (X :&: Y) _)). 67 | * by rewrite -def_F' !inE eqxx. 68 | * by case/orP: H => /eqP ->. 69 | + apply: Hx. by rewrite -def_F' !inE H A_in_F. 70 | - have/card1P [A HA] : #|F| == 1 by rewrite eqn_leq card_F. 71 | move: (F_pw_in A A). rewrite !HA inE eqxx. case/(_ _ _)/Wrap => //. 72 | case/set0Pn => x. rewrite setIid => Hx. exists x => B. 73 | by rewrite HA inE => /eqP->. 74 | Qed. 75 | 76 | Section Tree. 77 | Variable (G : sgraph). 78 | Hypothesis tree_G : is_forest [set: G]. 79 | 80 | (** If the whole graph is a forest, every connected set of vertices is a subtree *) 81 | 82 | (** Subtrees are closed under intersection *) 83 | Lemma tree_connectI (T1 T2 : {set G}) : 84 | connected T1 -> connected T2 -> connected (T1 :&: T2). 85 | Proof. 86 | move => C1 C2 x y /setIP [X1 X2] /setIP [Y1 Y2]. 87 | case: (path_in_connected C1 X1 Y1) => p Ip /subsetP Sp. 88 | case: (path_in_connected C2 X2 Y2) => q Iq /subsetP Sq. 89 | have {Iq Ip} ? : p = q by apply: tree_G. 90 | subst q. apply connectRI with p => z zp. by rewrite !inE Sp ?Sq. 91 | Qed. 92 | 93 | (** NOTE: The [irred p] assumption could be removed, but it doesn't hurt *) 94 | Lemma subtree_cut (T1 T2 : {set G}) (x1 x2 : G) (p : Path x1 x2) : 95 | connected T1 -> connected T2 -> T1 :&: T2 != set0 -> x1 \in T1 -> x2 \in T2 -> 96 | irred p -> exists y, [/\ y \in p, y \in T1 & y \in T2]. 97 | Proof. 98 | move => tree_T1 tree_T2 cap_T12 X11 X22 Ip. 99 | case/set0Pn : cap_T12 => z /setIP [Z1 Z2]. 100 | move: p Ip. move def_A : (T1 :&: T2) => A. 101 | have zA : z \in A by rewrite -def_A inE Z1. 102 | gen have H,Hp1 : T1 T2 x1 x2 tree_T1 tree_T2 X11 X22 Z1 Z2 def_A zA / 103 | exists z1 (p1 : Path x1 z1), [/\ z1 \in A, irred p1, p1 \subset T1 & forall k, k \in A -> k \in p1 -> k = z1]. 104 | { case: (@path_in_connected _ T1 x1 z) => // p1 Ip1 subT1. 105 | case: (split_at_first zA (path_end p1)) => z1 [p11] [p12] [E H1 H2]. subst. 106 | exists z1. exists p11. split => //. 107 | + by case/irred_catE : Ip1. 108 | + apply: subset_trans subT1. exact: subset_pcatL. } 109 | move: Hp1 => [z1] [p1] [zA1 Ip1 /subsetP sub_p1 H1]. 110 | case: (H T2 T1 x2 x1) => // {H}; first by rewrite setIC. 111 | move => z2 [p2] [zA2 Ip2 /subsetP sub_p2 H2]. 112 | case: (path_in_connected _ zA1 zA2) => [|q Iq /subsetP qA]. 113 | { rewrite -def_A. exact: tree_connectI. } 114 | set r := pcat (pcat p1 q) (prev p2). 115 | suff I: irred r. 116 | { move => p Ip. 117 | have -> : p = r by apply: forestT_unique. 118 | exists z1. rewrite !inE /= -def_A in zA1 *. by case/setIP : zA1 => -> -> . } 119 | rewrite /r. 120 | apply: irred_catI. 121 | - move => k. rewrite !inE. case/orP => U V. 122 | + rewrite [k]H2 //. by rewrite -def_A inE sub_p1 ?sub_p2. 123 | + by rewrite [k]H2 // qA. 124 | - apply: irred_catI => // k ? /qA ?. exact: H1. 125 | - by rewrite irred_rev. 126 | Qed. 127 | 128 | Lemma tree_I3 (T : 'I_3 -> {set G}) : 129 | (forall i, connected (T i)) -> (forall i j, T i :&: T j != set0) -> exists z, forall i, z \in T i. 130 | Proof. 131 | move => tree_T T_pw_in. 132 | case/set0Pn : (T_pw_in ord0 ord1) => x /setIP [X0 X1]. 133 | case/set0Pn : (T_pw_in ord0 ord2) => y /setIP [Y0 Y1]. 134 | case: (path_in_connected _ X0 Y0) => [|p irr_p /subsetP sub_T0]; first exact: tree_T. 135 | case: (@subtree_cut (T ord1) (T ord2) x y p) => // z [/sub_T0 ? ? ?]. 136 | exists z. exact: ord3P. 137 | Qed. 138 | 139 | Theorem tree_helly (F : {set {set G}}) : 140 | (forall T : {set G}, T \in F -> connected T) -> F != set0 -> 141 | {in F &, forall A B, A :&: B != set0} -> \bigcap_(A in F) A != set0. 142 | Proof. 143 | rewrite -card_gt0. move => F_subtree F_inh F_pq_in. 144 | case: (@helly3_lifting G (@connected G) _ _ F _ _ _) => //. 145 | - exact: tree_connectI. 146 | - exact: tree_I3. 147 | - move => x Hx. apply/set0Pn. exists x. apply/bigcapP. exact: Hx. 148 | Qed. 149 | 150 | End Tree. 151 | 152 | 153 | 154 | -------------------------------------------------------------------------------- /theories/core/mgraph2_tw2.v: -------------------------------------------------------------------------------- 1 | From Coq Require Import RelationClasses Setoid. 2 | From mathcomp Require Import all_ssreflect. 3 | From GraphTheory Require Import edone set_tac finite_quotient preliminaries. 4 | From GraphTheory Require Import digraph sgraph treewidth minor equiv setoid_bigop. 5 | From GraphTheory Require Import structures mgraph pttdom ptt mgraph2 skeleton. 6 | 7 | Set Implicit Arguments. 8 | Unset Strict Implicit. 9 | Unset Printing Implicit Defensive. 10 | Set Bullet Behavior "Strict Subproofs". 11 | 12 | Section Subalgebra. 13 | Variable (Lv : comMonoid) (Le : elabelType). 14 | Notation graph := (graph Lv Le). 15 | Notation graph2 := (graph2 Lv Le). 16 | 17 | Implicit Types (G H : graph) (U : sgraph) (T : forest). 18 | 19 | Open Scope implicit_scope. 20 | 21 | (** * Subalgebra of Tree-Width 2 Graphs *) 22 | 23 | Arguments sdecomp T G B : clear implicits. 24 | 25 | Definition compatible (T : forest) (G : graph2) (B : T -> {set G}) := 26 | exists t, (input \in B t) && (output \in B t). 27 | 28 | Lemma sdecomp_sskel (T : forest) (G : graph2) (B : T -> {set G}) : 29 | sdecomp T (sskeleton G) B <-> (sdecomp T G B /\ compatible B). 30 | Proof. 31 | split. 32 | - case => [D1 D2 D3]. split. split => //. 33 | + move => x y /= xy. apply: D2. by rewrite /edge_rel/= xy. 34 | + case: (altP (input =P output :> skeleton G)) => E. 35 | * case: (D1 input) => t Ht. exists t. by rewrite -E !Ht. 36 | * suff: (input : sskeleton G) -- output by apply: D2. by rewrite /edge_rel/= E !eqxx. 37 | - move => [[D1 D2 D3] C]. split => //= x y. case/or3P; first exact: D2. 38 | + case/and3P => ? /eqP E1 /eqP E2. by subst. 39 | + case/and3P => ? /eqP E1 /eqP E2. subst. 40 | case: C => t. rewrite andbC. by exists t. 41 | Qed. 42 | 43 | Lemma hom_eqL (V : finType) (e1 e2 : rel V) (G : sgraph) (h : V -> G) 44 | (e1_sym : symmetric e1) (e1_irrefl : irreflexive e1) 45 | (e2_sym : symmetric e2) (e2_irrefl : irreflexive e2): 46 | e1 =2 e2 -> 47 | @hom_s (SGraph e1_sym e1_irrefl) G h -> 48 | @hom_s (SGraph e2_sym e2_irrefl) G h. 49 | Proof. move => E hom_h x y. rewrite /edge_rel/= -E. exact: hom_h. Qed. 50 | 51 | 52 | Lemma skel_union_join (G1 G2 : graph) : @sk_rel _ _ (union G1 G2) =2 @join_rel G1 G2. 53 | Proof. 54 | move => [x|x] [y|y] /=. 55 | - rewrite /edge_rel/=/sk_rel sum_eqE. 56 | case: (boolP (x == y)) => //= E. apply/existsP/existsP. 57 | + move => [[e|e]]; rewrite !inE //= !sum_eqE. by exists e; rewrite !inE. 58 | + move => [e] H. exists (inl e). by rewrite !inE /= !sum_eqE in H *. 59 | - apply: contraTF isT => /existsP [[e|e]]; by rewrite !inE //= andbC. 60 | - apply: contraTF isT => /existsP [[e|e]]; by rewrite !inE //= andbC. 61 | - rewrite /edge_rel/=/sk_rel sum_eqE. 62 | case: (boolP (x == y)) => //= E. apply/existsP/existsP. 63 | + move => [[e|e]]; rewrite !inE //= !sum_eqE. by exists e; rewrite !inE. 64 | + move => [e] H. exists (inr e). by rewrite !inE /= !sum_eqE in H *. 65 | Qed. 66 | 67 | Section Quotients. 68 | Variables (G1 G2 : graph2). 69 | 70 | Let P : {set union G1 G2} := [set unl input; unl output; unr input; unr output]. 71 | 72 | Definition admissible (eqv : rel (union G1 G2)) := 73 | forall x y, eqv x y -> x = y \/ [set x;y] \subset P. 74 | 75 | Lemma admissible_eqv_clot (l: pairs (union G1 G2)): 76 | (forall p, p \in l -> p.1 \in P /\ p.2 \in P) -> admissible (eqv_clot l). 77 | Proof. 78 | move => H x y. rewrite eqv_clotE. case/connectP => p. 79 | have relE u v : rel_of_pairs l u v -> ((u \in P) * (v \in P)) %type. 80 | { by move /H => /= [-> ->]. } 81 | elim: p x => /= [x _ -> //|z p IH x /andP [E pth_p] lst_p]; first by left. 82 | right. rewrite subUset !sub1set. case: (IH _ pth_p lst_p) => [Z|S]; subst. 83 | - rewrite -Z. case/orP : E => E; by rewrite !(relE _ _ E). 84 | - case/orP: E => E; rewrite (relE _ _ E) /=; by abstract (set_tac). 85 | Qed. 86 | 87 | Lemma decomp_quot (T1 T2 : forest) D1 D2 (e : equiv_rel (union G1 G2)): 88 | sdecomp T1 (sskeleton G1) D1 -> sdecomp T2 (sskeleton G2) D2 -> 89 | width D1 <= 3 -> width D2 <= 3 -> 90 | admissible e -> #|[set pi e x | x in P]| <= 3 -> 91 | exists T D, [/\ sdecomp T (skeleton (merge _ e)) D, 92 | width D <= 3 & exists t, 93 | D t = [set \pi x | x in P]]. 94 | Proof using. 95 | move => /sdecomp_sskel [dec1 comp1] /sdecomp_sskel [dec2 comp2] W1 W2 adm_e collapse_P. 96 | move: comp1 comp2 => [t1 /andP[t1_in t1_out]] [t2 /andP[t2_in t2_out]]. 97 | pose T := tjoin T1 T2. 98 | pose D : tjoin T1 T2 -> {set sjoin G1 G2}:= decompU D1 D2. 99 | have dec_D: sdecomp T (sjoin G1 G2) D by exact: join_decomp. 100 | have dis_t1_t2 : ~~ connect (@sedge T)(inl t1) (inr t2) by rewrite join_disc. 101 | have dis_T12 : {in [set inl t1;inr t2] &, forall x y, x != y -> ~~ connect (@sedge T) x y}. 102 | { move => [?|?] [?|?] /setUP[] /set1P-> /setUP[]/set1P ->. 103 | all: by rewrite ?eqxx // => _; rewrite sconnect_sym. } 104 | pose T' := @tlink T _ dis_T12. 105 | pose D' := decompL D P : _ -> {set sjoin G1 G2}. 106 | have dec_D' : sdecomp T' (sjoin G1 G2) D'. 107 | { apply: decomp_link => //. 108 | apply/subsetP => x. 109 | rewrite !inE -!orbA => /or4P [] /eqP->. 110 | all: apply/bigcupP; solve 111 | [ by exists (inl t1) => //; rewrite ?inE ?imset_f ?eqxx 112 | | by exists (inr t2) => //; rewrite ?inE ?imset_f ?eqxx]. } 113 | pose h := pi e : skeleton (union G1 G2) -> skeleton (merge _ e). 114 | exists T'. exists (rename D' h); split; last by exists None. 115 | - apply: rename_decomp => //. 116 | + apply: hom_eqL (pi_hom (e := e)). exact: skel_union_join. 117 | + exact: pi_surj. 118 | + move => x y. move/sk_rel_mergeE => [? [x0] [y0] /= [? ? ?]]. 119 | exists x0;exists y0. split => //. by rewrite /edge_rel/= -skel_union_join. 120 | + move => x y. move/eqquotP => /=. case/adm_e => [<-|A]. 121 | * case: (sbag_cover dec_D' x) => t Ht. left. exists t. by rewrite Ht. 122 | * left. exists None. by rewrite /= -!sub1set -subUset. 123 | - rewrite /width (bigop.bigID (pred1 None)). 124 | rewrite bigop.big_pred1_eq. rewrite geq_max. apply/andP;split => //. 125 | + rewrite (bigop.reindex Some) /=. 126 | * apply: (@leq_trans (maxn (width D1) (width D2))); last by rewrite geq_max W1 W2. 127 | apply: leq_trans (join_width _ _). 128 | apply: bigmax_leq_pointwise => t _. exact: leq_imset_card. 129 | * apply: subon_bij; last by (apply bij_on_codom => //; exact: (inl t1)). 130 | by move => [x|]; rewrite !in_simpl // codom_f. 131 | Qed. 132 | 133 | Lemma decomp_par2 (T1 T2 : forest) D1 D2 : 134 | sdecomp T1 (sskeleton G1) D1 -> sdecomp T2 (sskeleton G2) D2 -> 135 | width D1 <= 3 -> width D2 <= 3 -> 136 | exists T D, [/\ sdecomp T (sskeleton (G1 ∥ G2)) D & width D <= 3]. 137 | Proof using. 138 | move => dec1 dec2 W1 W2. 139 | case: (decomp_quot (e:=eqv_clot [:: (unl input, unr input); (unl output, unr output)]) 140 | dec1 dec2 W1 W2 _ _). 141 | - apply admissible_eqv_clot. case => u v. 142 | rewrite !inE /= !xpair_eqE => /orP [] /andP [/eqP -> /eqP->]; by rewrite !eqxx. 143 | - pose P' : {set union G1 G2} := [set unl input; unl output]. 144 | apply: (@leq_trans #|P'|); last by rewrite cards2; by case (_ != _). 145 | apply: (@leq_trans #|[set (\pi x : G1 ∥ G2) | x in P']|); last exact: leq_imset_card. 146 | apply: subset_leq_card. 147 | apply/subsetP => ? /imsetP [x H1 ->]. case/setUP : H1 => H1; first case/setUP : H1 => H1. 148 | * by rewrite imset_f. 149 | * move/set1P : H1 => ->. apply/imsetP. exists (unl input); first by rewrite !inE eqxx ?orbT. 150 | apply/eqquotP. eqv. 151 | * move/set1P : H1 => ->. apply/imsetP. exists (unl output); first by rewrite !inE eqxx ?orbT. 152 | apply/eqquotP. eqv. 153 | - move => T [D] [A B [t C]]. exists T. exists D. split => //. 154 | apply/sdecomp_sskel. split => //. 155 | exists t. by rewrite C !imset_f // !inE ?eqxx ?orbT. 156 | Qed. 157 | 158 | Lemma decomp_dot2 (T1 T2 : forest) D1 D2 : 159 | sdecomp T1 (sskeleton G1) D1 -> sdecomp T2 (sskeleton G2) D2 -> 160 | width D1 <= 3 -> width D2 <= 3 -> 161 | exists T D, [/\ sdecomp T (sskeleton (G1 · G2)) D & width D <= 3]. 162 | Proof using. 163 | move => dec1 dec2 W1 W2. 164 | case: (decomp_quot (e:=eqv_clot [:: (unl output, unr input)]) dec1 dec2 W1 W2 _ _). 165 | - apply admissible_eqv_clot. case => u v. 166 | rewrite !inE /= !xpair_eqE => /andP [/eqP -> /eqP->]; by rewrite !eqxx. 167 | - pose P' : {set union G1 G2} := [set unl input; unl output; unr output]. 168 | apply: (@leq_trans #|P'|); last apply cards3. 169 | apply: (@leq_trans #|[set (\pi x : G1 · G2) | x in P']|); last exact: leq_imset_card. 170 | apply: subset_leq_card. 171 | apply/subsetP => ? /imsetP [x H1 ->]. move: H1. 172 | rewrite /P -!setUA [[set _;_]]setUC !setUA. case/setUP => H1. 173 | * by rewrite imset_f. 174 | * move/set1P : H1 => ->. apply/imsetP. exists (unl output); first by rewrite !inE eqxx ?orbT. 175 | apply/eqquotP. eqv. 176 | - move => T [D] [A B [t C]]. exists T. exists D. split => //. 177 | apply/sdecomp_sskel. split => //. 178 | exists t. by rewrite C !imset_f // !inE ?eqxx ?orbT. 179 | Qed. 180 | 181 | End Quotients. 182 | 183 | Lemma decomp_cnv (G : graph2) T D : 184 | sdecomp T (sskeleton G) D -> sdecomp T (sskeleton (G°)) D. 185 | Proof. 186 | move/sdecomp_sskel => [dec cmp]. apply/sdecomp_sskel; split => //. 187 | move: cmp => [t] H. exists t => /=. by rewrite andbC. 188 | Qed. 189 | 190 | Lemma decomp_dom (G : graph2) T D : 191 | sdecomp T (sskeleton G) D -> sdecomp T (sskeleton (dom G)) D. 192 | Proof. 193 | move/sdecomp_sskel => [dec cmp]. apply/sdecomp_sskel; split => //. 194 | move: cmp => [t] /andP [H _]. exists t => /=. by rewrite !H. 195 | Qed. 196 | 197 | Theorem eval_TW2 A (f: A -> graph2): 198 | (forall a, exists T D, [/\ sdecomp T (sskeleton (f a)) D & width D <= 3]) -> 199 | forall u, exists T D, [/\ sdecomp T (sskeleton (eval f u)) D & width D <= 3]. 200 | Proof. 201 | move => Hf. elim => [u IHu v IHv | u IHu v IHv | u IHu | u IHu | | | a]. 202 | - move: IHu IHv => [T1] [D1] [? ?] [T2] [D2] [? ?]. 203 | exact: (decomp_dot2 (D1 := D1) (D2 := D2)). 204 | - move: IHu IHv => [T1] [D1] [? ?] [T2] [D2] [? ?]. 205 | exact: (decomp_par2 (D1 := D1) (D2 := D2)). 206 | - move: IHu => [T] [D] [D1 D2]. exists T. exists D. split => //. 207 | exact: decomp_cnv. 208 | - move: IHu => [T] [D] [D1 D2]. exists T. exists D. split => //. 209 | exact: decomp_dom. 210 | - apply: decomp_small. by rewrite card_unit. 211 | - apply: decomp_small. by rewrite card_sum card_unit. 212 | - apply Hf. 213 | Qed. 214 | 215 | End Subalgebra. 216 | 217 | Section s. 218 | Variable A: Type. 219 | Let graph_of_term: term A -> graph2 unit (flat A) := eval (fun a : flat A => g2_var _ a). 220 | 221 | Theorem graph_of_TW2 (u : term A) : 222 | exists T D, [/\ @sdecomp T (sskeleton (graph_of_term u)) D & width D <= 3]. 223 | Proof. 224 | apply eval_TW2 => a. 225 | apply: decomp_small. by rewrite card_sum card_unit. 226 | Qed. 227 | 228 | Lemma sskel_K4_free (u : term A) : K4_free (sskeleton (graph_of_term u)). 229 | Proof. 230 | case: (graph_of_TW2 u) => T [B] [B1 B2]. 231 | exact: TW2_K4_free B1 B2. 232 | Qed. 233 | 234 | Lemma skel_K4_free (u : term A) : K4_free (skeleton (graph_of_term u)). 235 | Proof. 236 | apply: minor_K4_free (@sskel_K4_free u). 237 | exact: sub_minor (skel_sub _). 238 | Qed. 239 | 240 | (* TODO: define the subalgebra as a ptt_algebra? (with sigma types) *) 241 | 242 | End s. 243 | -------------------------------------------------------------------------------- /theories/core/partition.v: -------------------------------------------------------------------------------- 1 | From mathcomp Require Import all_ssreflect. 2 | 3 | Set Implicit Arguments. 4 | Unset Strict Implicit. 5 | Unset Printing Implicit Defensive. 6 | 7 | (** *** partitions and related properties *) 8 | 9 | (** The majority of the lemmas in this file is part of mathcomp PR 731 *) 10 | 11 | Section BigSetOps. 12 | 13 | Variables T I : finType. 14 | Implicit Types (U : {pred T}) (P : pred I) (A B : {set I}) (F : I -> {set T}). 15 | 16 | Lemma bigcup0P P F : 17 | reflect (forall i, P i -> F i = set0) (\bigcup_(i | P i) F i == set0). 18 | Proof. 19 | rewrite -subset0; apply: (iffP bigcupsP) => sub0 i /sub0; last by move->. 20 | by rewrite subset0 => /eqP. 21 | Qed. 22 | 23 | Lemma bigcup_disjointP U P F : 24 | reflect (forall i : I, P i -> [disjoint U & F i]) 25 | [disjoint U & \bigcup_(i | P i) F i]. 26 | Proof. 27 | apply: (iffP idP) => [disUF i Pp|]; last exact: bigcup_disjoint. 28 | apply: disjointWr disUF; exact: bigcup_sup. 29 | Qed. 30 | 31 | End BigSetOps. 32 | 33 | 34 | Lemma imset_cover (aT rT : finType) (P : {set {set aT}}) (f : aT -> rT) : 35 | [set f x | x in cover P] = \bigcup_(i in P) [set f x | x in i]. 36 | Proof. 37 | apply/setP=> y; apply/imsetP/bigcupP => [|[A AP /imsetP[x xA ->]]]. 38 | by move=> [x /bigcupP[A AP xA] ->]; exists A => //; rewrite imset_f. 39 | by exists x => //; apply/bigcupP; exists A. 40 | Qed. 41 | 42 | Section partition. 43 | Variable (T : finType) (P : {set {set T}}) (D : {set T}). 44 | Implicit Types (A B S : {set T}). 45 | 46 | Lemma partition0 : partition P D -> set0 \in P = false. 47 | Proof. case/and3P => _ _. by apply: contraNF. Qed. 48 | 49 | Lemma partition_neq0 B : partition P D -> B \in P -> B != set0. 50 | Proof. by move=> partP; apply: contraTneq => ->; rewrite partition0. Qed. 51 | 52 | Lemma partition_trivIset: partition P D -> trivIset P. 53 | Proof. by case/and3P. Qed. 54 | 55 | Lemma partitionS B : partition P D -> B \in P -> B \subset D. 56 | Proof. 57 | by move=> partP BP; rewrite -(cover_partition partP); apply: bigcup_max BP _. 58 | Qed. 59 | 60 | Lemma cover1 A : cover [set A] = A. 61 | Proof. by rewrite /cover big_set1. Qed. 62 | 63 | Lemma trivIset1 A : trivIset [set A]. 64 | Proof. by rewrite /trivIset cover1 big_set1. Qed. 65 | 66 | Lemma trivIsetD Q : trivIset P -> trivIset (P :\: Q). 67 | Proof. 68 | move/trivIsetP => tP; apply/trivIsetP => A B /setDP[TA _] /setDP[TB _]; exact: tP. 69 | Qed. 70 | 71 | Lemma trivIsetU Q : 72 | trivIset Q -> trivIset P -> [disjoint cover Q & cover P] -> trivIset (Q :|: P). 73 | Proof. 74 | move => /trivIsetP tQ /trivIsetP tP dQP; apply/trivIsetP => A B. 75 | move => /setUP[?|?] /setUP[?|?]; first [exact:tQ|exact:tP|move => _]. 76 | by apply: disjointW dQP; rewrite bigcup_sup. 77 | by rewrite disjoint_sym; apply: disjointW dQP; rewrite bigcup_sup. 78 | Qed. 79 | 80 | Lemma coverD1 S : trivIset P -> S \in P -> cover (P :\ S) = cover P :\: S. 81 | Proof. 82 | move/trivIsetP => tP SP; apply/setP => x; rewrite inE. 83 | apply/bigcupP/idP => [[A /setD1P [ADS AP] xA]|/andP[xNS /bigcupP[A AP xA]]]. 84 | by rewrite (disjointFr (tP _ _ _ _ ADS)) //=; apply/bigcupP; exists A. 85 | by exists A; rewrite // !inE AP andbT; apply: contraNneq xNS => <-. 86 | Qed. 87 | 88 | Lemma partitionD1 S : 89 | partition P D -> S \in P -> partition (P :\ S) (D :\: S). 90 | Proof. 91 | case/and3P => /eqP covP trivP set0P SP. 92 | by rewrite /partition inE (negbTE set0P) trivIsetD ?coverD1 -?covP ?eqxx ?andbF. 93 | Qed. 94 | 95 | Lemma partitionU1 S : 96 | partition P D -> S != set0 -> [disjoint S & D] -> partition (S |: P) (S :|: D). 97 | Proof. 98 | case/and3P => /eqP covP trivP set0P SD0 disSD. 99 | rewrite /partition !inE (negbTE set0P) orbF [_ == S]eq_sym SD0 andbT. 100 | rewrite /cover bigcup_setU big_set1 -covP eqxx /=. 101 | by move: disSD; rewrite -covP=> /bigcup_disjointP/trivIsetU1 => -[]. 102 | Qed. 103 | 104 | Lemma partition_set0 : partition P set0 = (P == set0). 105 | Proof. 106 | apply/and3P/eqP => [[/bigcup0P covP _ ]|->]; last first. 107 | by rewrite /partition inE /trivIset/cover !big_set0 cards0 !eqxx. 108 | by apply: contraNeq => /set0Pn[B BP]; rewrite -(covP B BP). 109 | Qed. 110 | 111 | Section Image. 112 | Variables (T' : finType) (f : T -> T') (inj_f : injective f). 113 | Let fP := [set f @: (S : {set T}) | S in P]. 114 | 115 | Lemma imset_inj : injective (fun A : {set T} => f @: A). 116 | Proof. 117 | move => A B => /setP E; apply/setP => x. 118 | by rewrite -(mem_imset (mem A) x inj_f) E mem_imset. 119 | Qed. 120 | 121 | Lemma imset_disjoint (A B : {pred T}) : 122 | [disjoint f @: A & f @: B] = [disjoint A & B]. 123 | Proof. 124 | apply/pred0Pn/pred0Pn => /= [[? /andP[/imsetP[x xA ->]] xB]|]. 125 | by exists x; rewrite xA -(mem_imset (mem B) x inj_f). 126 | by move => [x /andP[xA xB]]; exists (f x); rewrite !mem_imset ?xA. 127 | Qed. 128 | 129 | Lemma imset_trivIset : trivIset P = trivIset fP. 130 | Proof. 131 | apply/trivIsetP/trivIsetP. 132 | - move=> trivP ? ? /imsetP[A AP ->] /imsetP[B BP ->]. 133 | by rewrite (inj_eq imset_inj) imset_disjoint; apply: trivP. 134 | - move=> trivP A B AP BP; rewrite -imset_disjoint -(inj_eq imset_inj). 135 | by apply: trivP; rewrite imset_f. 136 | Qed. 137 | 138 | Lemma imset0mem : (set0 \in fP) = (set0 \in P). 139 | Proof. 140 | apply/imsetP/idP => [[A AP /esym/eqP]|P0]; last by exists set0; rewrite ?imset0. 141 | by rewrite imset_eq0 => /eqP<-. 142 | Qed. 143 | 144 | Lemma imset_partition : partition P D = partition fP (f @: D). 145 | Proof. 146 | suff cov: (cover fP == f @:D) = (cover P == D). 147 | by rewrite /partition -imset_trivIset imset0mem cov. 148 | by rewrite /fP cover_imset -imset_cover (inj_eq imset_inj). 149 | Qed. 150 | End Image. 151 | 152 | Lemma partition_pigeonhole A : 153 | partition P D -> #|P| <= #|A| -> A \subset D -> {in P, forall B, #|A :&: B| <= 1} -> 154 | {in P, forall B, A :&: B != set0}. 155 | Proof. 156 | move=> partP card_A_P /subsetP subAD sub1; apply/forall_inP. 157 | apply: contraTT card_A_P => /forall_inPn [B BP]; rewrite negbK => eq0. 158 | rewrite -!ltnNge -(setD1K BP) cardsU1 !inE eqxx /= add1n ltnS. 159 | have F (x : T) (xA : x \in A) : { C | (C \in P) & (x \in C) }. 160 | by apply/sig2W/bigcupP; rewrite -/(cover P) (cover_partition partP) subAD. 161 | pose f (x : T) : {set T} := 162 | if @idP (x \in A) is ReflectT xA then s2val (F _ xA) else set0. 163 | have inj_f : {in A &, injective f}. 164 | { move => x y; rewrite /f; 165 | case : {1}_ / idP => // xA _; case : {1}_ / idP => // yA _ E. 166 | case: (F x xA) E (s2valP' (F y yA)) => /= C CP xC <- yC. 167 | by have/card_le1_eqP/(_ y x) := sub1 _ CP; apply; apply/setIP. } 168 | rewrite -(card_in_imset inj_f); apply: subset_leq_card. 169 | apply/subsetP => ? /imsetP[x xA ->]; rewrite /f; move: xA. 170 | case : {1}_ / idP => // xA _; case: (F x xA) => /= C CP xC; rewrite !inE CP andbT. 171 | by apply: contraTneq eq0 => <-; apply/set0Pn; exists x; apply/setIP. 172 | Qed. 173 | 174 | End partition. 175 | 176 | Lemma indexed_partition (I T : finType) (J : {pred I}) (B : I -> {set T}) : 177 | let P := [set B i | i in J] in 178 | {in J &, forall i j : I, j != i -> [disjoint B i & B j]} -> 179 | (forall i : I, J i -> B i != set0) -> partition P (cover P) /\ {in J&, injective B}. 180 | Proof. 181 | move=> P disjB inhB. 182 | have s0NP : set0 \notin P. 183 | by apply/negP => /imsetP[x xI /eqP]; apply/negP; rewrite eq_sym inhB. 184 | by rewrite /partition eqxx s0NP andbT /=; apply: trivIimset. 185 | Qed. 186 | 187 | (* TOTHINK: an alternative definition would be [[set B :&: A | B in P]:\ set0]. 188 | Then one has to prove the partition properties, but the lemmas below 189 | are simpler to prove. *) 190 | 191 | (* This is not part of PR 731 *) 192 | 193 | Section partition. 194 | Variable (T : finType) (P : {set {set T}}) (D : {set T}). 195 | Implicit Types (A B S : {set T}). 196 | 197 | 198 | Definition sub_partition A : {set {set T}} := 199 | preim_partition (pblock P) A. 200 | 201 | Lemma sub_partitionP A : partition (sub_partition A) A. 202 | Proof. exact: preim_partitionP. Qed. 203 | 204 | Lemma sub_partition_sub A : 205 | partition P D -> A \subset D -> sub_partition A \subset [set B :&: A | B in P]. 206 | Proof. 207 | move=> partP /subsetP subAD; apply/subsetP => B; case/imsetP => [x xA ->]. 208 | have ? : x \in cover P by rewrite (cover_partition partP) subAD. 209 | apply/imsetP; exists (pblock P x); first by rewrite pblock_mem. 210 | by apply/setP => y; rewrite !inE eq_pblock 1?andbC //; case/and3P: partP. 211 | Qed. 212 | 213 | Lemma card_sub_partition A : 214 | partition P D -> A \subset D -> #|sub_partition A| <= #|P|. 215 | Proof. 216 | move=> partP subAD; apply: leq_trans (leq_imset_card (fun B => B :&: A) _). 217 | apply: subset_leq_card. exact: sub_partition_sub. 218 | Qed. 219 | 220 | End partition. 221 | -------------------------------------------------------------------------------- /theories/core/ptt.v: -------------------------------------------------------------------------------- 1 | From HB Require Import structures. 2 | From Coq Require Import Setoid Morphisms. 3 | From mathcomp Require Import all_ssreflect. 4 | From GraphTheory Require Import edone preliminaries setoid_bigop structures pttdom. 5 | 6 | Set Implicit Arguments. 7 | Unset Strict Implicit. 8 | Unset Printing Implicit Defensive. 9 | Set Bullet Behavior "Strict Subproofs". 10 | 11 | (** * 2p algebras, tests, initial algebra of terms *) 12 | 13 | (** ** 2p algebras (2pdom algebras with top) *) 14 | 15 | (** We define [ptt] as a substructure of [pttdom] where [top] is 16 | interpreted appropriately. We also provide a factory where the laws 17 | for [dom], (i.e., [A13] and [A14]) can be omitted, as they are 18 | derivable *) 19 | 20 | HB.mixin Record Ptt_of_Pttdom A of Pttdom A := 21 | { A11: forall x: A, x · top ≡ dom x · top; 22 | A12: forall x y: A, (x∥1) · y ≡ (x∥1)·top ∥ y; 23 | domE: forall x: A, dom x ≡ 1 ∥ x·top }. 24 | HB.structure Definition Ptt := { A of Ptt_of_Pttdom A & }. 25 | Notation ptt := Ptt.type. 26 | 27 | HB.factory Record Ptt_of_Ops A of Ops_of_Type A & Setoid_of_Type A := 28 | { dot_eqv: Proper (eqv ==> eqv ==> eqv) (dot : A -> A -> A); 29 | par_eqv: Proper (eqv ==> eqv ==> eqv) (par : A -> A -> A); 30 | cnv_eqv: Proper (eqv ==> eqv) (cnv : A -> A); 31 | domE: forall x: A, dom x ≡ 1 ∥ x·top; 32 | parA: forall x y z: A, x ∥ (y ∥ z) ≡ (x ∥ y) ∥ z; 33 | parC: forall x y: A, x ∥ y ≡ y ∥ x; 34 | dotA: forall x y z: A, x · (y · z) ≡ (x · y) · z; 35 | dotx1: forall x: A, x · 1 ≡ x; 36 | cnvI: forall x: A, x°° ≡ x; 37 | cnvpar: forall x y: A, (x ∥ y)° ≡ x° ∥ y°; 38 | cnvdot: forall x y: A, (x · y)° ≡ y° · x°; 39 | par11: 1 ∥ 1 ≡ 1 :> A ; 40 | A10: forall x y: A, 1 ∥ x·y ≡ dom (x ∥ y°); 41 | A11: forall x: A, x · top ≡ dom x · top; 42 | A12: forall x y: A, (x∥1) · y ≡ (x∥1)·top ∥ y 43 | }. 44 | 45 | HB.builders Context A (F : Ptt_of_Ops A). 46 | 47 | Instance ptt_equivalence : Equivalence (@eqv [the setoid of A]). 48 | Proof. exact: Eqv. Qed. 49 | 50 | Instance ptt_par_eqv : Proper (eqv ==> eqv ==> eqv) (par : A -> A -> A). 51 | Proof. exact: par_eqv. Qed. 52 | 53 | Instance ptt_dot_eqv : Proper (eqv ==> eqv ==> eqv) (dot : A -> A -> A). 54 | Proof. exact: dot_eqv. Qed. 55 | 56 | Lemma A13_ (x y: A): dom(x·y) ≡ dom(x·dom y). 57 | Proof. by rewrite domE -dotA A11 dotA -domE. Qed. 58 | 59 | Lemma A14_ (x y z: A): dom x·(y∥z) ≡ dom x·y ∥ z. 60 | Proof. by rewrite domE parC A12 (A12 _ y) parA. Qed. 61 | 62 | Lemma dom_eqv_ : Proper (eqv ==> eqv) (dom : A -> A). 63 | Proof. by move=> x y xy; rewrite !domE xy. Qed. 64 | 65 | HB.instance Definition Pttdom_of_Ops := 66 | Pttdom_of_Ops.Build A 67 | dot_eqv par_eqv cnv_eqv dom_eqv_ 68 | parA parC dotA dotx1 cnvI cnvpar cnvdot par11 A10 A13_ A14_. 69 | 70 | HB.instance Definition Ptt_of_Ops := 71 | Ptt_of_Pttdom.Build A A11 A12 domE. 72 | 73 | HB.end. 74 | 75 | #[export] 76 | Instance ptt_equivalence (A : ptt) : Equivalence (@eqv [the ptt of A]). 77 | Proof. exact: Eqv. Qed. 78 | 79 | #[export] 80 | Instance ptt_par_eqv (A : ptt) : Proper (eqv ==> eqv ==> eqv) (par : A -> A -> A). 81 | Proof. exact: par_eqv. Qed. 82 | 83 | #[export] 84 | Instance ptt_dot_eqv (A : ptt) : Proper (eqv ==> eqv ==> eqv) (dot : A -> A -> A). 85 | Proof. exact: dot_eqv. Qed. 86 | 87 | (** ** basic derivable laws *) 88 | Section derived. 89 | Variable X: ptt. 90 | 91 | Lemma parxtop (x: X): x ∥ top ≡ x. 92 | Proof. 93 | symmetry. generalize (A12 1 x). 94 | by rewrite par11 2!dot1x parC. 95 | Qed. 96 | 97 | Lemma partopx (x: X): top ∥ x ≡ x. 98 | Proof. by rewrite parC parxtop. Qed. 99 | 100 | Lemma cnvtop: top° ≡ @top X. 101 | Proof. 102 | rewrite -(parxtop top°) -{2}(cnvI top). 103 | by rewrite -cnvpar partopx cnvI. 104 | Qed. 105 | 106 | End derived. 107 | 108 | Section terms. 109 | Variable A: Type. 110 | Inductive term := 111 | | tm_dot: term -> term -> term 112 | | tm_par: term -> term -> term 113 | | tm_cnv: term -> term 114 | | tm_dom: term -> term 115 | | tm_one: term 116 | | tm_top: term 117 | | tm_var: A -> term. 118 | Section e. 119 | Variable (X: Ops.type) (f: A -> X). 120 | Fixpoint eval (u: term): X := 121 | match u with 122 | | tm_dot u v => eval u · eval v 123 | | tm_par u v => eval u ∥ eval v 124 | | tm_cnv u => (eval u) ° 125 | | tm_dom u => dom (eval u) 126 | | tm_one => 1 127 | | tm_top => top 128 | | tm_var a => f a 129 | end. 130 | End e. 131 | Definition tm_eqv (u v: term): Prop := 132 | forall (X: ptt) (f: A -> X), eval f u ≡ eval f v. 133 | 134 | Hint Unfold tm_eqv : core. 135 | Lemma tm_eqv_equivalence: Equivalence tm_eqv. 136 | Proof. 137 | constructor. 138 | now intro. 139 | intros ?? H X f. specialize (H X f). by symmetry. 140 | intros ??? H H' X f. specialize (H X f). specialize (H' X f). etransitivity. apply H. apply H'. 141 | Qed. 142 | HB.instance Definition tm_setoid := Setoid_of_Type.Build term tm_eqv_equivalence. 143 | 144 | HB.instance Definition tm_ops := Ops_of_Type.Build term tm_dot tm_par tm_cnv tm_dom tm_one tm_top. 145 | 146 | Let tm_eqv_eqv (u v: term) (X: ptt) (f: A -> X) : u ≡ v -> eval f u ≡ eval f v. 147 | Proof. exact. Qed. 148 | 149 | (* quotiented terms indeed form a 2p algebra *) 150 | Definition tm_ptt : Ptt_of_Ops.axioms_ term tm_ops tm_setoid. 151 | refine (Ptt_of_Ops.Build term _ _ _ _ _ _ _ _ _ _ _ _ _ _ _). 152 | abstract (repeat intro; simpl; by apply: dot_eqv; apply: tm_eqv_eqv). 153 | abstract (repeat intro; simpl; by apply: par_eqv; apply: tm_eqv_eqv). 154 | abstract (repeat intro; simpl; by apply: cnv_eqv; apply: tm_eqv_eqv). 155 | abstract (repeat intro; simpl; by apply: domE; apply: tm_eqv_eqv). 156 | abstract (repeat intro; simpl; by apply: parA; apply: tm_eqv_eqv). 157 | abstract (repeat intro; simpl; by apply: parC; apply: tm_eqv_eqv). 158 | abstract (repeat intro; simpl; by apply: dotA; apply: tm_eqv_eqv). 159 | abstract (repeat intro; simpl; by apply: dotx1; apply: tm_eqv_eqv). 160 | abstract (repeat intro; simpl; by apply: cnvI; apply: tm_eqv_eqv). 161 | abstract (repeat intro; simpl; by apply: cnvpar; apply: tm_eqv_eqv). 162 | abstract (repeat intro; simpl; by apply: cnvdot; apply: tm_eqv_eqv). 163 | abstract (repeat intro; simpl; by apply: par11; apply: tm_eqv_eqv). 164 | abstract (repeat intro; simpl; by apply: A10; apply: tm_eqv_eqv). 165 | abstract (repeat intro; simpl; by apply: A11; apply: tm_eqv_eqv). 166 | abstract (repeat intro; simpl; by apply: A12; apply: tm_eqv_eqv). 167 | Defined. 168 | HB.instance Definition _ := tm_ptt. 169 | 170 | End terms. 171 | Declare Scope ptt_ops. 172 | Bind Scope ptt_ops with term. 173 | -------------------------------------------------------------------------------- /theories/core/pttdom.v: -------------------------------------------------------------------------------- 1 | From HB Require Import structures. 2 | From Coq Require Import Setoid Morphisms. 3 | From mathcomp Require Import all_ssreflect. 4 | From GraphTheory Require Import edone preliminaries setoid_bigop structures. 5 | 6 | Set Implicit Arguments. 7 | Unset Strict Implicit. 8 | Unset Printing Implicit Defensive. 9 | Set Bullet Behavior "Strict Subproofs". 10 | 11 | (** * 2pdom algebra, tests, initial algebra of terms *) 12 | 13 | (** ** 2pdom algebra (the top-free fragment of 2p algebra) *) 14 | 15 | (** NOTE: we let Ops inherit from Setoid, to avoid having a 16 | "criss-cross" inheritance pattern that is not (yet) supported by HB *) 17 | HB.mixin Record Ops_of_Type A := 18 | { dot: A -> A -> A; 19 | par: A -> A -> A; 20 | cnv: A -> A; 21 | dom: A -> A; 22 | one: A; 23 | top: A; (* top is left uninterpreted in 2pdom *) 24 | }. 25 | HB.structure Definition Ops := { A of Ops_of_Type A & }. 26 | 27 | Arguments one {_}: simpl never. 28 | Arguments top {_}: simpl never. 29 | Arguments dot: simpl never. 30 | Arguments par: simpl never. 31 | Arguments cnv: simpl never. 32 | Arguments dom: simpl never. 33 | 34 | Declare Scope pttdom_ops. 35 | Bind Scope pttdom_ops with Ops.type. 36 | Delimit Scope pttdom_ops with ptt. 37 | Open Scope pttdom_ops. 38 | Notation "x ∥ y" := (par x y) (left associativity, at level 40, format "x ∥ y"): pttdom_ops. 39 | Notation "x · y" := (dot x y) (left associativity, at level 25, format "x · y"): pttdom_ops. 40 | Notation "x °" := (cnv x) (left associativity, at level 5, format "x °"): pttdom_ops. 41 | Notation "1" := (one): pttdom_ops. 42 | 43 | (* 2pdom axioms *) 44 | 45 | HB.mixin Record Pttdom_of_Ops A of Ops_of_Type A & Setoid_of_Type A := 46 | { dot_eqv: Proper (eqv ==> eqv ==> eqv) (dot : A -> A -> A); 47 | par_eqv: Proper (eqv ==> eqv ==> eqv) (par : A -> A -> A); 48 | cnv_eqv: Proper (eqv ==> eqv) (cnv : A -> A); 49 | dom_eqv: Proper (eqv ==> eqv) (dom : A -> A); 50 | parA: forall x y z: A, x ∥ (y ∥ z) ≡ (x ∥ y) ∥ z; 51 | parC: forall x y: A, x ∥ y ≡ y ∥ x; 52 | dotA: forall x y z: A, x · (y · z) ≡ (x · y) · z; 53 | dotx1: forall x: A, x · 1 ≡ x; 54 | cnvI: forall x: A, x°° ≡ x; 55 | cnvpar: forall x y: A, (x ∥ y)° ≡ x° ∥ y°; 56 | cnvdot: forall x y: A, (x · y)° ≡ y° · x°; 57 | par11: (1 : A) ∥ 1 ≡ 1; 58 | A10: forall x y: A, 1 ∥ x·y ≡ dom (x ∥ y°); 59 | A13: forall x y: A, dom(x·y) ≡ dom(x·dom y); 60 | A14: forall x y z: A, dom x·(y∥z) ≡ dom x·y ∥ z; 61 | }. 62 | HB.structure Definition Pttdom := { A of Pttdom_of_Ops A & }. 63 | Notation pttdom := Pttdom.type. 64 | #[export] Existing Instances dot_eqv par_eqv cnv_eqv dom_eqv. 65 | 66 | Class is_test (X : pttdom) (x : X) := { testE : dom x ≡ x }. 67 | 68 | (* Coercion ops_of (X : pttdom) (x : Pttdom.sort X) : Ops.sort X := x. *) 69 | (* Coercion setoid_of (X : Ops) (x : Pttdom.sort X) : Setoid.sort X := x. *) 70 | 71 | (** ** basic derivable laws *) 72 | Section derived. 73 | 74 | Variable X: pttdom. 75 | Implicit Types u v x y z: X. 76 | 77 | Lemma cnv1: 1° ≡ @one X. 78 | Proof. rewrite -[1°]dotx1 -{2}[1]cnvI. by rewrite -cnvdot dotx1 cnvI. Qed. 79 | 80 | Lemma dot1x x: 1·x ≡ x. 81 | Proof. by rewrite -[1·x]cnvI cnvdot cnv1 dotx1 cnvI. Qed. 82 | 83 | Lemma cnv_inj x y: x° ≡ y° -> x ≡ y. 84 | Proof. intro. rewrite <-(cnvI x), <-(cnvI y). by apply cnv_eqv. Qed. 85 | 86 | Lemma dotcnv x y: x·y ≡ (y°·x°)°. 87 | Proof. apply cnv_inj. by rewrite cnvdot cnvI. Qed. 88 | 89 | (** ** tests *) 90 | (* Definition is_test x := dom x ≡ x. *) 91 | Record test := Test{ elem_of :> X ; testP : is_test elem_of }. 92 | 93 | Global Instance test_test (a : test) : is_test (elem_of a). 94 | Proof. exact: testP. Qed. 95 | 96 | Implicit Types a b c d : X. 97 | 98 | Lemma is_test_alt x: dom x ≡ x <-> x∥1 ≡ x. 99 | Proof. 100 | split=>E. 101 | - rewrite -{1}E -{1}(dotx1 (dom x)) -A14. 102 | by rewrite par11 dotx1. 103 | - by rewrite -E -{1}cnv1 -A10 dotx1 parC. 104 | Qed. 105 | 106 | Lemma domtst a of is_test a : dom a ≡ a. 107 | Proof. exact: testE. Qed. 108 | 109 | Lemma tstpar1 a of is_test a : a ∥ 1 ≡ a. 110 | Proof. by apply/is_test_alt; rewrite domtst. Qed. 111 | 112 | Lemma one_test: is_test (1:X). 113 | Proof. constructor. by rewrite -{1}par11 -{2}cnv1 -A10 dotx1 par11. Qed. 114 | Global Existing Instance one_test. 115 | 116 | Lemma dom_test x: is_test (dom x). 117 | Proof. constructor. by rewrite -{1}[dom x]dot1x -A13 dot1x. Qed. 118 | Global Existing Instance dom_test. 119 | 120 | Lemma par_test a u of is_test a : is_test (a∥u). 121 | Proof. 122 | constructor; apply/is_test_alt. 123 | by rewrite -parA (parC u) parA tstpar1. 124 | Qed. 125 | Global Existing Instance par_test. 126 | 127 | Lemma cnvtst a of is_test a : a° ≡ a. 128 | Proof. 129 | rewrite -[a]tstpar1 cnvpar cnv1 -(dot1x (a°)) parC A10 cnvI parC. 130 | apply: domtst. 131 | Qed. 132 | 133 | Lemma cnv_test a of is_test a : is_test (a°). 134 | Proof. constructor. by rewrite is_test_alt cnvtst tstpar1. Qed. 135 | Global Existing Instance cnv_test. 136 | 137 | Lemma tstpar a x y of is_test a : a·(x∥y) ≡ a·x ∥ y. 138 | Proof. rewrite -[a]domtst. apply A14. Qed. 139 | 140 | Lemma tstpar_r a x y of is_test a : a·(x∥y) ≡ x ∥ a·y. 141 | Proof. by rewrite parC tstpar parC. Qed. 142 | 143 | Lemma pardot a b of is_test a & is_test b : a ∥ b ≡ a·b. 144 | Proof. 145 | by rewrite -{2}(@tstpar1 b) (parC _ 1) tstpar dotx1. 146 | Qed. 147 | 148 | Lemma dotC a b of is_test a & is_test b : a·b ≡ b·a. 149 | Proof. by rewrite -pardot parC pardot. Qed. 150 | 151 | Lemma dot_test a b of is_test a & is_test b : is_test (a·b). 152 | Proof. constructor. rewrite -pardot. apply: domtst. Qed. 153 | Global Existing Instance dot_test. 154 | 155 | (* (** automatised inference of tests *) *) 156 | (* Definition infer_test x b (e: elem_of b = x) := b. *) 157 | (* Notation "[ x ]" := (@infer_test x _ erefl). *) 158 | Notation "[ x ]" := (@Test x _). 159 | 160 | (** ** commutative monoid of tests *) 161 | Definition eqv_test (a b : test) := elem_of a ≡ elem_of b. 162 | Arguments eqv_test _ _ /. 163 | Lemma eqv_test_equiv: Equivalence eqv_test. 164 | Proof. 165 | split => [x|x y|x y z]; rewrite /eqv_test /=. 166 | reflexivity. by symmetry. by transitivity (elem_of y). 167 | Qed. 168 | HB.instance Definition pttdom_test_setoid := 169 | Setoid_of_Type.Build test eqv_test_equiv. 170 | 171 | Lemma infer_testE a of is_test a : elem_of [a] ≡ a. 172 | Proof. by []. Qed. 173 | Lemma eqv_testE a b of is_test a & is_test b : [a] ≡ [b] <-> a ≡ b. 174 | Proof. by []. Qed. 175 | 176 | Section M. 177 | Definition tst_dot (a b : test) : test := [elem_of a · elem_of b]. 178 | Local Infix "·" := tst_dot. 179 | 180 | Lemma tst_dot_eqv: Proper (eqv ==> eqv ==> eqv) tst_dot. 181 | Proof. intros [a] [b] ? [c] [d] ?. by apply dot_eqv. Qed. 182 | Lemma tst_dotA: forall a b c : test, a·(b·c) ≡ (a·b)·c. 183 | Proof. intros [a] [b] [c]. apply dotA. Qed. 184 | Lemma tst_dotC: forall a b : test, a·b ≡ b·a. 185 | Proof. intros. by rewrite /tst_dot eqv_testE -pardot parC pardot. Qed. 186 | Lemma tst_dotU: forall a : test , a·[1] ≡ a. 187 | Proof. intros [a]. apply dotx1. Qed. 188 | 189 | Definition pttdom_monoid_laws := 190 | mkComMonoidLaws tst_dot_eqv tst_dotA tst_dotC tst_dotU. 191 | HB.instance Definition pttdom_monoid := 192 | ComMonoid_of_Setoid.Build test pttdom_monoid_laws. 193 | End M. 194 | 195 | 196 | (** ** label structure of a 2pdom algebra (Definition 4.3) *) 197 | 198 | (* dualised equality (to get the [labels] structure below) *) 199 | Definition eqv' x y := x ≡ y°. 200 | Arguments eqv' _ _ /. 201 | Lemma eqv'_sym: Symmetric eqv'. 202 | Proof. move=> x y /= H. apply cnv_inj. by rewrite cnvI H. Qed. 203 | Lemma eqv01 x y z: x ≡ y -> eqv' y z -> eqv' x z. 204 | Proof. by move=> /= ->. Qed. 205 | Lemma eqv11 x y z: eqv' x y -> eqv' y z -> x ≡ z. 206 | Proof. move=> /= -> ->. apply cnvI. Qed. 207 | 208 | #[export,non_forgetful_inheritance] 209 | HB.instance Definition pttdom_elabel := 210 | Elabel_of_Setoid.Build X eqv'_sym eqv01 eqv11. 211 | 212 | (* Lemmas to turn pttdom expressions into (projections of) tests *) 213 | Lemma par1tst u : 1 ∥ u = elem_of [1∥u]. by []. Qed. 214 | Lemma paratst (a : test) u : elem_of a ∥ u = elem_of [elem_of a∥u]. by []. Qed. 215 | Lemma dom_tst u : dom u = elem_of [dom u]. by []. Qed. 216 | 217 | (* this allows rewriting an equivalence between tests inside a pttdom expression *) 218 | Lemma rwT (a b: test) : a ≡ b -> elem_of a ≡ elem_of b. by []. Qed. 219 | 220 | (** ** other derivable laws used in the completeness proof *) 221 | 222 | Lemma partst u v a of is_test a : (u ∥ v)·a ≡ u ∥ v·a. 223 | Proof. 224 | apply cnv_inj. rewrite cnvdot 2!cnvpar cnvdot. 225 | by rewrite parC tstpar parC. 226 | Qed. 227 | 228 | Lemma par_tst_cnv a u of is_test a : a ∥ u° ≡ a ∥ u. 229 | Proof. by rewrite -[a∥u°]cnvtst cnvpar cnvtst cnvI. Qed. 230 | 231 | Lemma eqvb_par1 a u v (b : bool) of is_test a : u ≡[b] v -> a ∥ u ≡ a ∥ v. 232 | Proof. case: b => [->|-> //]. exact: par_tst_cnv. Qed. 233 | 234 | (* used twice in reduce in reduction.v *) 235 | Lemma reduce_shuffle v a c d of is_test a & is_test c & is_test d : 236 | c·(d·a)·(1∥v) ≡ a ∥ c·v·d. 237 | Proof. 238 | rewrite -!dotA -tstpar_r; apply: dot_eqv => //. 239 | by rewrite -partst tstpar dotx1 dotC. 240 | Qed. 241 | 242 | (* lemma for nt_correct *) 243 | Lemma par_nontest u v a b c d of is_test a & is_test b & is_test c & is_test d : 244 | a·u·b∥c·v·d ≡ (a·c)·(u∥v)·(b·d). 245 | Proof. by rewrite -partst -[a·u·b]dotA -tstpar parC -tstpar -partst !dotA parC. Qed. 246 | 247 | 248 | (* used in open.v *) 249 | Lemma eqvbN u v : u ≡[false] v -> u ≡ v. by []. Qed. 250 | Lemma eqvbT u v : u ≡[true] v -> u ≡ v°. by []. Qed. 251 | 252 | Lemma eqvE' u v : (u ≡' v) = (u ≡ v°). by []. Qed. 253 | 254 | Lemma eqvb_neq u v (b : bool) : u ≡[~~b] v <-> u ≡[b] v°. 255 | Proof. by split; apply: eqvb_transL; rewrite ?(addbN,addNb) addbb /= ?eqvE' ?cnvI. Qed. 256 | 257 | End derived. 258 | (* Coercion pttdom_labels: pttdom >-> labels. *) 259 | 260 | 261 | 262 | Notation "[ x ]" := (@Test _ x _). 263 | 264 | (* Notation "[ x ]" := (@infer_test _ x%ptt _ erefl): pttdom_ops. *) 265 | 266 | (** ** initial algebra of terms *) 267 | Section terms. 268 | Variable A: Type. 269 | Inductive term := 270 | | tm_dot: term -> term -> term 271 | | tm_par: term -> term -> term 272 | | tm_cnv: term -> term 273 | | tm_dom: term -> term 274 | | tm_one: term 275 | | tm_var: A -> term. 276 | Bind Scope pttdom_ops with term. 277 | Section e. 278 | Variable (X: Ops.type) (f: A -> X). 279 | Fixpoint eval (u: term): X := 280 | match u with 281 | | tm_dot u v => eval u · eval v 282 | | tm_par u v => eval u ∥ eval v 283 | | tm_cnv u => (eval u) ° 284 | | tm_dom u => dom (eval u) 285 | | tm_one => 1 286 | | tm_var a => f a 287 | end. 288 | End e. 289 | 290 | (* axiomatic equality on terms *) 291 | (* (via impredicative encoding to avoid repeating the axioms in an inductive definition)) *) 292 | Definition tm_eqv (u v: term): Prop := 293 | forall (X: pttdom) (f: A -> X), eval f u ≡ eval f v. 294 | 295 | Hint Unfold tm_eqv : core. 296 | Lemma tm_eqv_equivalence: Equivalence tm_eqv. 297 | Proof. 298 | constructor. 299 | now intro. 300 | intros ?? H X f. specialize (H X f). by symmetry. 301 | intros ??? H H' X f. specialize (H X f). specialize (H' X f). etransitivity. apply H. apply H'. 302 | Qed. 303 | HB.instance Definition tm_setoid := Setoid_of_Type.Build term tm_eqv_equivalence. 304 | 305 | HB.instance Definition tm_ops := Ops_of_Type.Build term tm_dot tm_par tm_cnv tm_dom tm_one tm_one. 306 | 307 | (* Arguments eqv { _ } _ _ / . *) 308 | 309 | Lemma tm_eqv_eqv (u v: term) (X: pttdom) (f: A -> X) : 310 | u ≡ v -> eval f u ≡ eval f v. 311 | Proof. exact. Qed. 312 | 313 | Definition tm_pttdom : Pttdom_of_Ops.axioms_ term tm_ops tm_setoid. 314 | Proof. 315 | refine (Pttdom_of_Ops.Build term _ _ _ _ _ _ _ _ _ _ _ _ _ _ _). 316 | abstract (by repeat intro; simpl; apply dot_eqv; apply: tm_eqv_eqv). 317 | abstract (by repeat intro; simpl; apply par_eqv; apply: tm_eqv_eqv). 318 | abstract (by repeat intro; simpl; apply cnv_eqv; apply: tm_eqv_eqv). 319 | abstract (by repeat intro; simpl; apply dom_eqv; apply: tm_eqv_eqv). 320 | abstract (by repeat intro; simpl; apply parA; apply: tm_eqv_eqv). 321 | abstract (by repeat intro; simpl; apply parC; apply: tm_eqv_eqv). 322 | abstract (by repeat intro; simpl; apply dotA; apply: tm_eqv_eqv). 323 | abstract (by repeat intro; simpl; apply dotx1; apply: tm_eqv_eqv). 324 | abstract (by repeat intro; simpl; apply cnvI; apply: tm_eqv_eqv). 325 | abstract (by repeat intro; simpl; apply cnvpar; apply: tm_eqv_eqv). 326 | abstract (by repeat intro; simpl; apply cnvdot; apply: tm_eqv_eqv). 327 | abstract (by repeat intro; simpl; apply par11; apply: tm_eqv_eqv). 328 | abstract (by repeat intro; simpl; apply A10; apply: tm_eqv_eqv). 329 | abstract (by repeat intro; simpl; apply A13; apply: tm_eqv_eqv). 330 | abstract (by repeat intro; simpl; apply A14; apply: tm_eqv_eqv). 331 | Defined. 332 | 333 | HB.instance Definition _ := tm_pttdom. 334 | HB.instance Definition _ := Elabel.copy term [the pttdom of term]. 335 | 336 | Notation test := (test [the pttdom of term]). 337 | 338 | (** ** normal terms and normalisation function (Section 7)*) 339 | 340 | (* TOTHINK: might want to move normalisation to completeness related files 341 | also, the normal terms construction actually works in an arbitrary pttdom *) 342 | 343 | (* normal terms *) 344 | Inductive nterm := 345 | | nt_test: test -> nterm 346 | | nt_conn: test -> term -> test -> nterm. 347 | 348 | (* reading back terms *) 349 | Definition term_of_nterm (t: nterm) := 350 | match t with 351 | | nt_test alpha => elem_of alpha (* why do we need to insert the coercion??? *) 352 | | nt_conn alpha u gamma => elem_of alpha · u · elem_of gamma 353 | end. 354 | 355 | (* pttdom algebra on normal terms *) 356 | Definition nt_one := nt_test [1]. 357 | Definition nt_var a := nt_conn [1] (tm_var a) [1]. 358 | Definition nt_cnv u := 359 | match u with 360 | | nt_test _ => u 361 | | nt_conn a u b => nt_conn b (u°) a 362 | end. 363 | Definition nt_dom u := 364 | match u with 365 | | nt_test _ => u 366 | | nt_conn a u b => nt_test [elem_of a · dom (u·elem_of b)] 367 | end. 368 | Definition nt_dot u v := 369 | match u,v with 370 | | nt_test a, nt_test b => nt_test [elem_of a·elem_of b] 371 | | nt_test a, nt_conn b u c => nt_conn [elem_of a·elem_of b] u c 372 | | nt_conn a u b, nt_test c => nt_conn a u [elem_of b·elem_of c] 373 | | nt_conn a u b, nt_conn c v d => nt_conn a (u·elem_of b·elem_of c·v) d 374 | end. 375 | Definition nt_par u v := 376 | match u,v with 377 | | nt_test a, nt_test b => nt_test [elem_of a·elem_of b] 378 | | nt_test a, nt_conn b u c => nt_test [elem_of a ∥ elem_of b·u·elem_of c] 379 | | nt_conn a u b, nt_test c => nt_test [elem_of c ∥ elem_of a·u·elem_of b] 380 | | nt_conn a u b, nt_conn c v d => nt_conn [elem_of a·elem_of c] (u ∥ v) [elem_of b·elem_of d] 381 | end. 382 | 383 | (* normalisation function (Definition 7.1) *) 384 | (* TODO: define it as an [eval]) *) 385 | Fixpoint nt (u: term): nterm := 386 | match u with 387 | | tm_dot u v => nt_dot (nt u) (nt v) 388 | | tm_par u v => nt_par (nt u) (nt v) 389 | | tm_cnv u => nt_cnv (nt u) 390 | | tm_var a => nt_var a 391 | | tm_dom u => nt_dom (nt u) 392 | | tm_one => nt_one 393 | end. 394 | 395 | (** Induction on terms exposes [tm_*] constructors. The [fold_ops] 396 | tactic recovers the notations for the term algebra *) 397 | Ltac fold_ops := 398 | repeat match goal with 399 | | |- context[tm_par ?u ?v] => change (tm_par u v) with (u ∥ v) 400 | | |- context[tm_dot ?u ?v] => change (tm_dot u v) with (u · v) 401 | | |- context[tm_cnv ?u] => change (tm_cnv u) with (u°) 402 | | |- context[tm_dom ?u] => change (tm_dom u) with (dom u) 403 | | |- context[tm_one ?A] => change (tm_one A) with one 404 | | |- tm_eqv ?u ?v => change (u ≡ v) 405 | end. 406 | 407 | 408 | (* correctness of the normalisation function (Proposition 7.1) *) 409 | Proposition nt_correct (u: term): u ≡ term_of_nterm (nt u). 410 | Proof. 411 | induction u=>//=; fold_ops. 412 | - (* rewrite {1}IHu1 {1}IHu2. - coq 8.12 regression *) 413 | rewrite (dot_eqv _ _ IHu1 _ _ IHu2). 414 | case (nt u1) =>[a|a u b]; 415 | case (nt u2)=>[c|c v d] //=; 416 | rewrite !dotA//. 417 | - (* rewrite {1}IHu1 {1}IHu2. *) 418 | rewrite (par_eqv _ _ IHu1 _ _ IHu2). 419 | case (nt u1)=>[a|a u b]; 420 | case (nt u2)=>[c|c v d]=>//=. 421 | exact: pardot. 422 | apply: parC. 423 | exact: par_nontest. 424 | - rewrite {1}IHu. 425 | case (nt u)=>[a|a v b]=>//=. 426 | exact: cnvtst. 427 | by rewrite 2!cnvdot dotA !cnvtst. 428 | - rewrite {1}IHu. 429 | case (nt u)=>[a|a v b]=>//=. 430 | exact: domtst. 431 | by rewrite -dotA A13 domtst. 432 | - by rewrite dotx1 dot1x. 433 | Qed. 434 | 435 | End terms. 436 | -------------------------------------------------------------------------------- /theories/core/reduction.v: -------------------------------------------------------------------------------- 1 | From HB Require Import structures. 2 | From Coq Require Import Setoid Morphisms. 3 | From mathcomp Require Import all_ssreflect. 4 | From GraphTheory Require Import edone finite_quotient preliminaries bij equiv. 5 | From GraphTheory Require Import setoid_bigop structures pttdom mgraph mgraph2 rewriting. 6 | 7 | Set Implicit Arguments. 8 | Unset Strict Implicit. 9 | Unset Printing Implicit Defensive. 10 | Set Bullet Behavior "Strict Subproofs". 11 | 12 | (** * Reducibility for the rewrite system *) 13 | 14 | (** ** Preliminary isomorphisms (on arbitrary graphs) *) 15 | Section prelim. 16 | Variable (Lv : comMonoid) (Le : elabelType). 17 | Notation graph := (graph Lv Le). 18 | Notation graph2 := (graph2 Lv Le). 19 | Local Open Scope cm_scope. 20 | 21 | Lemma two_edges (a b c d: Lv) (u v: Le): 22 | edge_graph a u b ⊎ edge_graph c v d 23 | ≃ (two_graph a b ⊎ two_graph c d) 24 | ∔ [inl (inl tt), u, inl (inr tt)] 25 | ∔ [inr (inl tt), v, inr (inr tt)]. 26 | Proof. 27 | etransitivity. apply (union_add_edge_l _ _ _ _). 28 | etransitivity. apply (add_edge_iso (union_add_edge_r _ _ _ _) _ _ _). 29 | apply add_edge_C. 30 | Defined. 31 | 32 | Definition two_option_void: 33 | bij (option (void+void) + option (void+void)) (option (option ((void+void)+void))). 34 | Proof. 35 | etransitivity. apply sum_option_r. apply option_bij. 36 | etransitivity. apply sum_bij. reflexivity. apply sumxU. 37 | etransitivity. apply sumxU. apply option_bij. 38 | symmetry. apply sumxU. 39 | Defined. 40 | 41 | 42 | Lemma dot_edges (a b c d: Lv) (u v: Le): 43 | point (merge_seq (edge_graph a u b ⊎ edge_graph c v d) [:: (inl (inr tt), inr (inl tt))]) 44 | (\pi inl (inl tt)) (\pi (inr (inr tt))) 45 | ≃2 two_graph2 a d ∔ (b⊗c) ∔ [inl (inl tt), u, inr tt] ∔ [inr tt, v, inl (inr tt)]. 46 | Proof. 47 | set G := (_ ⊎ _)%G. 48 | set H := (_ ∔ [_, _, _] ∔ [_,_,_])%G2. 49 | pose f (x : G) : H := match x with 50 | | inl (inl _) => inl (inl tt) 51 | | inr (inr _) => inl (inr tt) 52 | | _ => inr tt 53 | end. 54 | unshelve Iso2 55 | (@merge_surj _ _ G _ H f 56 | (fun x => 57 | match x with 58 | | inl (inl _) => inl (inl tt) 59 | | inl (inr _) => inr (inr tt) 60 | | inr tt => inl (inr tt) 61 | end) 62 | (two_option_void) 63 | xpred0 _ _ _). 64 | 4,5: apply merge_surjE. 65 | - apply kernel_eqv_clot. 66 | * by repeat constructor. 67 | * case=>[[[]|[]]|[[]|[]]]; case=>[[[]|[]]|[[]|[]]]//= _; eqv. 68 | - by repeat case. 69 | - split. 70 | + by repeat case. 71 | + move => y. rewrite !big_sumType !big_unitType. 72 | by case: y ; [case; case | case]; rewrite /= ?monUl ?monU. 73 | + by repeat case. 74 | Qed. 75 | 76 | Definition two_option_void': bij (option (void+void) + option (void+void)) (option (option (void+void))). 77 | Proof. 78 | etransitivity. apply sum_option_r. apply option_bij. 79 | etransitivity. apply sum_bij. reflexivity. apply sumxU. 80 | apply sumxU. 81 | Defined. 82 | 83 | Lemma par_edges (a b c d: Lv) (u v: Le): 84 | point (merge_seq (edge_graph a u b ⊎ edge_graph c v d) 85 | [:: (inl (inl tt), inr (inl tt)); (inl (inr tt), inr (inr tt))]) 86 | (\pi inl (inl tt)) (\pi (inr (inr tt))) 87 | ≃2 two_graph2 (a⊗c) (b⊗d) ∔ [inl tt, u, inr tt] ∔ [inl tt, v, inr tt]. 88 | Proof. 89 | unshelve Iso2 90 | (@merge_surj _ _ 91 | (edge_graph a u b ⊎ edge_graph c v d) _ 92 | (two_graph2 (a⊗c) (b⊗d) ∔ [_, u, _] ∔ [_, v, _]) 93 | (fun x => 94 | match x with 95 | | inl y => y 96 | | inr y => y 97 | end) 98 | (inl) 99 | (two_option_void') 100 | xpred0 _ _ _ ). 101 | 4,5: apply merge_surjE. 102 | - apply kernel_eqv_clot. 103 | * by repeat constructor. 104 | * case=>[[[]|[]]|[[]|[]]]; case=>[[[]|[]]|[[]|[]]]//= _; eqv. 105 | - by repeat case. 106 | - split. 107 | + by repeat case. 108 | + move => y. rewrite !big_sumType !big_unitType. 109 | by case: y => [[]|[]] /=; rewrite ?monU ?monUl. 110 | + by repeat case. 111 | Qed. 112 | 113 | End prelim. 114 | 115 | 116 | (** ** preservation of steps under algebraic operations *) 117 | (* (for every pttdom algebra) *) 118 | Section s. 119 | Variable X: pttdom. 120 | Notation test := (test X). 121 | Notation graph := (graph test X). 122 | Notation graph2 := (graph2 test X). 123 | Notation step := (@step X). 124 | Notation steps := (@steps X). 125 | 126 | (* preliminaries to obtain the technical Lemma 6.3 *) 127 | 128 | Definition mentions (A: eqType) (l: pairs A) := 129 | flatten [seq [::x.1;x.2] | x <- l]. 130 | 131 | Definition admissible_l (G: graph2) (H: eqType) (e : pairs (G+H)) := 132 | all (fun x => if x is inl z then z \in IO else true) (mentions e). 133 | 134 | Definition replace_ioL (G G': graph2) (H: eqType) (e : pairs (G+H)) : pairs (G'+H) := 135 | map_pairs (fun x => 136 | match x with 137 | | inl z => if z == output then inl output else inl input 138 | | inr z => inr z 139 | end) e. 140 | Arguments replace_ioL [G G' H]. 141 | 142 | Lemma replace_ioE vT eT1 eT2 st1 st2 lv1 lv2 le1 le2 i o H e : admissible_l e -> 143 | @replace_ioL (point (@Graph _ _ vT eT1 st1 lv1 le1) i o) 144 | (point (@Graph _ _ vT eT2 st2 lv2 le2) i o) H e = e. 145 | Proof. 146 | elim: e => //=. case => [[a|a] [b|b]] l /= IH. 147 | all: rewrite /admissible_l /=. all: first [case/and3P|case/andP|idtac]. 148 | all: repeat (case/set2P => ->). all: move => HA; rewrite ?IH ?eqxx //. 149 | all: by case: (altP (i =P o)) => [->|?]. 150 | Qed. 151 | 152 | Lemma cons_iso_steps G G' H : steps G' H -> G ≃2 G' -> steps G H. 153 | Proof. intros E F. etransitivity. apply iso_step, F. assumption. Qed. 154 | 155 | Lemma cons_step_steps G G' H : steps G' H -> step G G' -> steps G H. 156 | Proof. intros E F. by setoid_rewrite F. Qed. 157 | 158 | Lemma merge_add_edgeL (G H : graph) x y u l i o : 159 | point (merge_seq (G ∔ [x,u,y] ⊎ H) l) (\pi i) (\pi o) 160 | ≃2 point (merge_seq (G ⊎ H) l) (\pi i) (\pi o) ∔ [\pi inl x,u,\pi inl y]. 161 | Proof. 162 | eapply iso2_comp. 163 | apply (iso_iso2' (h:=merge_iso (union_add_edge_l _ _ _ _) _)). 164 | 1,2: by rewrite merge_isoE. 165 | eapply iso2_comp. 166 | refine (iso_iso2' (h:=merge_add_edge _ _ _ _) _ _). 167 | 1,2: by rewrite merge_add_edgeE. 168 | unshelve refine (iso_iso2' (h:=add_edge_iso'' (h:=mgraph.merge_same _) _ _ _) _ _)=>/=. 169 | 4: reflexivity. 170 | by rewrite map_pairs_id. 171 | all: by rewrite merge_sameE. 172 | Defined. 173 | 174 | (* TOFIX: even with Opaque merge_iso h_merge, the rewrite merge_add_edgeE 175 | succeeds by unfolding if we don't do the rewrite merge_isoE first. *) 176 | Lemma merge_add_edgeLE G H x y u l i o z: 177 | @merge_add_edgeL G H x y u l i o (\pi z) = (\pi z). 178 | Proof. 179 | rewrite /merge_add_edgeL/=. 180 | rewrite (@merge_isoE _ _ _ _ (union_add_edge_l H x u y) l). 181 | rewrite merge_add_edgeE. 182 | by rewrite merge_sameE. 183 | Qed. 184 | 185 | Section a. 186 | Variables (G H : graph2) (a: test) (l: pairs (add_vertex2 G a ⊎ H)%G). 187 | Hypothesis A: admissible_l l. 188 | Lemma admissible_map : 189 | map_pairs sumA (map_pairs (sumf id sumC) (map_pairs sumA' l)) = 190 | map_pairs inl (replace_ioL l). 191 | Proof. 192 | rewrite 2!map_map_pairs. induction l as [|[a1 a2] q IH]=>//. 193 | simpl. move: A =>/andP[/=A1 /andP[/=A2 Q]]. f_equal. f_equal. 194 | destruct a1 as [[x|[]]|x]=>//=. 195 | case/set2P : A1 => [] [->]; rewrite sum_eqE ?eqxx //. by case: (altP (input =P output)) => [->|]. 196 | exfalso. clear -A1. by rewrite !inE in A1. 197 | destruct a2 as [[x|[]]|x]=>//=. 198 | case/set2P : A2 => [] [->]; rewrite sum_eqE ?eqxx //. by case: (altP (input =P output)) => [->|]. 199 | exfalso. clear -A2. by rewrite !inE in A2. 200 | apply IH, Q. 201 | Qed. 202 | 203 | Lemma merge_add_vertexL: 204 | point (merge_seq (G ∔ a ⊎ H) l) (\pi (inl (inl input))) (\pi (unr output)) 205 | ≃2 point (merge_seq (G ⊎ H) (replace_ioL l)) (\pi (unl input)) (\pi (unr output)) ∔ a. 206 | Proof. 207 | eapply iso2_comp. 208 | apply (iso_iso2' (h:=merge_iso (iso_sym (union_A _ _ _)) _)). 209 | 1,2: rewrite merge_isoE//. 210 | eapply iso2_comp. 211 | refine (iso_iso2' (h:=merge_iso (union_iso iso_id (union_C _ _)) _) _ _). 212 | 1,2: rewrite merge_isoE//. 213 | eapply iso2_comp. 214 | refine (iso_iso2' (h:=merge_iso (union_A _ _ _) _) _ _). 215 | 1,2: rewrite merge_isoE//. 216 | eapply iso2_sym. 217 | eapply iso2_comp. 218 | refine (iso_iso2' (h:=union_merge_l _ _) _ _). 219 | 1,2: rewrite union_merge_lEl//. 220 | eapply iso2_sym. (* just so that [merge_add_vertexLE] gets easier below... *) 221 | apply merge_same'. 222 | by rewrite admissible_map. 223 | Defined. 224 | 225 | Lemma merge_add_vertexLE x: 226 | merge_add_vertexL (\pi (inl x)) = 227 | match x with inl x => inl (\pi inl x) | _ => inr tt end. 228 | Proof. 229 | simpl. 230 | rewrite (@merge_isoE _ _ _ _ (iso_sym (union_A G (unit_graph a) H)) l). 231 | rewrite (@merge_isoE _ _ _ _ (union_iso iso_id (union_C (unit_graph a) H)) _). 232 | rewrite (@merge_isoE _ _ _ _ (union_A G H (unit_graph a)) _). 233 | rewrite merge_same'E. 234 | rewrite union_merge_lE'. 235 | by case x=>[y|[]]. 236 | Qed. 237 | 238 | End a. 239 | 240 | Definition merge_add_vlabelL (G H: graph2) x a l i o : 241 | point (merge_seq (G[tst x <- a] ⊎ H) l) (\pi i) (\pi o) 242 | ≃2 point (merge_seq (G ⊎ H) l) (\pi i) (\pi o) [tst \pi inl x <- a]. 243 | Proof. 244 | eapply iso2_comp. 245 | apply (iso_iso2' (h:=merge_iso (union_add_vlabel_l _ _ _) _)). 246 | 1,2: rewrite merge_isoE//. 247 | eapply iso2_comp. 248 | refine (iso_iso2' (h:=merge_add_vlabel _ _ _) _ _). 249 | 1,2: by rewrite merge_add_vlabelE. 250 | unshelve refine (iso_iso2' (h:=add_vlabel_iso'' (h:=mgraph.merge_same _) _ _) _ _)=>/=. 251 | 3: reflexivity. 252 | by rewrite map_pairs_id. 253 | all: by rewrite merge_sameE. 254 | (* this proof could be made simpler since we don't need to Defined it *) 255 | Qed. 256 | 257 | (** *** Lemma 6.3 *) 258 | Lemma merge_step (G' G H: graph2) (l : pairs (G+H)) : 259 | admissible_l l -> step G G' -> 260 | steps (point (merge_seq (G ⊎ H) l) (\pi (unl input)) (\pi (unr output))) 261 | (point (merge_seq (G' ⊎ H) (replace_ioL l)) (\pi (unl input)) (\pi (unr output))). 262 | Proof. 263 | move => A B. destruct B. 264 | - refine (cons_iso_steps _ (merge_add_vertexL A)). 265 | apply (one_step (step_v0 _ _)). 266 | 267 | - refine (cons_iso_steps _ (merge_add_edgeL _ _ _)). 268 | refine (cons_iso_steps _ (add_edge2_iso (merge_add_vertexL A) _ _ _)). 269 | rewrite 2!merge_add_vertexLE. 270 | refine (cons_step_steps _ (step_v1 _ _ _)). 271 | apply iso_step. 272 | symmetry. apply merge_add_vlabelL. 273 | 274 | - refine (cons_iso_steps _ (merge_add_edgeL _ _ _)). 275 | refine (cons_iso_steps _ (add_edge2_iso (merge_add_edgeL _ _ _) _ _ _)). 276 | rewrite !merge_add_edgeLE. 277 | refine (cons_iso_steps _ (add_edge2_iso (add_edge2_iso (merge_add_vertexL A) _ _ _) _ _ _)). 278 | do 4 rewrite {1}merge_add_vertexLE. 279 | refine (cons_step_steps _ (step_v2 _ _ _ _ _)). 280 | apply iso_step. 281 | symmetry. apply merge_add_edgeL. 282 | 283 | - refine (cons_iso_steps _ (merge_add_edgeL _ _ _)). 284 | refine (cons_step_steps _ (step_e0 _ _)). 285 | apply iso_step. 286 | etransitivity. symmetry. apply merge_add_vlabelL. 287 | by rewrite replace_ioE. 288 | 289 | - refine (cons_iso_steps _ (merge_add_edgeL _ _ _)). 290 | refine (cons_iso_steps _ (add_edge2_iso (merge_add_edgeL _ _ _) _ _ _)). 291 | rewrite !merge_add_edgeLE. 292 | refine (cons_step_steps _ (step_e2 _ _ _ _)). 293 | apply iso_step. 294 | etransitivity. symmetry. apply (merge_add_edgeL (u:=u∥v)). 295 | by rewrite replace_ioE. 296 | Qed. 297 | 298 | Lemma step_IO G G': step G G' -> (input == output :> G) = (input == output :> G'). 299 | Proof. by case. Qed. 300 | 301 | Lemma step_to_steps f: 302 | Proper (eqv ==> eqv) f -> Proper (step ==> steps) f -> Proper (steps ==> steps) f. 303 | Proof. 304 | intros If Sf G G' S. 305 | induction S as [G G' I|G G' F H' I S Ss IH]. 306 | - by apply isop_step, If. 307 | - etransitivity. apply isop_step, If. exists. apply I. 308 | etransitivity. apply Sf, S. apply IH. 309 | Qed. 310 | 311 | 312 | (** *** Lemma 6.2 *) 313 | 314 | Instance cnv_steps: Proper (steps ==> steps) (cnv : graph2 -> graph2). 315 | Proof. 316 | apply: step_to_steps. 317 | move=>F G S. eapply one_step. destruct S. 318 | * apply (@step_v0 _ (point G output input) alpha). 319 | * apply (@step_v1 _ (point G output input) x u alpha). 320 | * apply (@step_v2 _ (point G output input) x y u alpha v). 321 | * apply (@step_e0 _ (point G output input) x u). 322 | * apply (@step_e2 _ (point G output input) x y u v). 323 | Qed. 324 | 325 | Instance dom_steps: Proper (steps ==> steps) (@dom _). 326 | Proof. 327 | apply: step_to_steps. 328 | move=>F G S. eapply one_step. destruct S. 329 | * apply (@step_v0 _ (point G input input) alpha). 330 | * apply (@step_v1 _ (point G input input) x u alpha). 331 | * apply (@step_v2 _ (point G input input) x y u alpha v). 332 | * apply (@step_e0 _ (point G input input) x u). 333 | * apply (@step_e2 _ (point G input input) x y u v). 334 | Qed. 335 | 336 | Lemma dot_steps_l G G' H: steps G G' -> steps (G·H) (G'·H). 337 | Proof. 338 | apply: (step_to_steps (f:=fun G => G·H)) => {G G'}. 339 | - move => F G E. exact: dot_eqv. 340 | - move => G G' GG'. etransitivity. apply (@merge_step G') => //=. 341 | + rewrite /admissible_l/=. by rewrite !inE eqxx. 342 | + by rewrite /replace_ioL/= eqxx. 343 | Qed. 344 | 345 | Lemma dot_steps_r G G' H: steps G G' -> steps (H·G) (H·G'). 346 | Proof. 347 | move => GG'. rewrite dotcnv. transitivity ((G'°·H°)°). 348 | by apply cnv_steps, dot_steps_l, cnv_steps. 349 | by rewrite -dotcnv. 350 | Qed. 351 | 352 | Instance dot_steps: Proper (steps ==> steps ==> steps) (@dot _). 353 | Proof. 354 | repeat intro. by etransitivity; [apply dot_steps_l | apply dot_steps_r]. 355 | Qed. 356 | 357 | Lemma par_steps_l G G' H: steps G G' -> steps (G∥H) (G'∥H). 358 | Proof. 359 | apply (step_to_steps (f:=fun G => (G∥H))) => {G G'}. 360 | - move => G G' I; exact: par_eqv. 361 | - move => G G' step_G_G'. 362 | etransitivity. apply: (@merge_step G') => //=. 363 | + by rewrite /admissible_l/= !inE !eqxx. 364 | + rewrite /replace_ioL/= !eqxx. case: ifP => [E|//]. 365 | rewrite (step_IO step_G_G') in E. 366 | by rewrite -[in (inl output,inr input)](eqP E). 367 | Qed. 368 | 369 | Lemma par_steps_r G G' H: steps G G' -> steps (H∥G) (H∥G'). 370 | Proof. 371 | intro. rewrite parC. etransitivity. apply par_steps_l. eassumption. 372 | by rewrite parC. 373 | Qed. 374 | 375 | Instance par_steps: Proper (steps ==> steps ==> steps) (@par _). 376 | Proof. 377 | repeat intro. by etransitivity; [apply par_steps_l | apply par_steps_r]. 378 | Qed. 379 | 380 | End s. 381 | 382 | Lemma eqvEcnv (X : pttdom) (x y : X) : x ≡' y <-> x ≡ y°. 383 | Proof. done. Qed. 384 | 385 | (** ** reduction lemma *) 386 | (* (in the initial pttdom algebra of terms) *) 387 | Section s'. 388 | Variable A: Type. 389 | Notation term := (pttdom.term A). 390 | Notation nterm := (pttdom.nterm A). 391 | Notation test := (test [the pttdom of term]). 392 | Notation tgraph2 := (graph2 test term). 393 | Notation graph := (graph unit (flat A)). 394 | Notation graph2 := (graph2 unit (flat A)). 395 | Notation step := (@step [the pttdom of term]). 396 | Notation steps := (@steps [the pttdom of term]). 397 | 398 | (** *** graphs of terms and normal terms *) 399 | 400 | (* function g^A from the end of Section 5 *) 401 | Definition graph_of_term: term -> graph2 := pttdom.eval (fun a: flat A => g2_var _ a). 402 | 403 | (* function g^T from the end of Section 5 *) 404 | Definition tgraph_of_term: term -> tgraph2 := pttdom.eval (fun a: A => g2_var _ (pttdom.tm_var a)). 405 | 406 | Definition tgraph_of_nterm (t: nterm): tgraph2 := 407 | match t with 408 | | nt_test a => unit_graph2 a 409 | | nt_conn a u b => edge_graph2 a u b 410 | end. 411 | 412 | (* reduction lemma (Proposition 7.2) *) 413 | Proposition reduce (u: term): steps (tgraph_of_term u) (tgraph_of_nterm (nt u)). 414 | Proof. 415 | induction u=>//=. 416 | - etransitivity. apply dot_steps; [apply IHu1|apply IHu2]. 417 | case (nt u1)=>[a|a u b]; 418 | case (nt u2)=>[c|c v d]=>/=. 419 | * apply iso_step. 420 | etransitivity. apply dot2unit_r. apply add_vlabel2_unit. 421 | * apply iso_step. 422 | etransitivity. apply dot2unit_l. 423 | etransitivity. apply add_vlabel2_edge. 424 | apply edge_graph2_iso=>//=. by apply: monC. 425 | * apply iso_step. 426 | etransitivity. apply dot2unit_r. apply add_vlabel2_edge. 427 | * etransitivity. apply isop_step. 428 | 2: etransitivity. 429 | 2: apply one_step, (step_v2 (G:=two_graph2 a d) (inl tt) (inr tt) u [elem_of b·elem_of c] v). 430 | exists. apply: dot_edges. 431 | apply isop_step. exists. 432 | apply: (add_edge2_iso' iso2_id). 433 | by rewrite !dotA. 434 | 435 | - etransitivity. apply par_steps; [apply IHu1|apply IHu2]. 436 | case (nt u1)=>[a|a u b]; 437 | case (nt u2)=>[c|c v d]=>/=. 438 | * apply isop_step. exists. apply par2unitunit. 439 | * etransitivity. apply isop_step. 440 | 2: etransitivity. 441 | 2: apply one_step, (step_e0 (G:=unit_graph2 (c⊗(d⊗a))%CM) tt v). 442 | rewrite parC. exists. apply: par2edgeunit. 443 | apply isop_step. exists. 444 | etransitivity. apply add_vlabel2_unit. apply unit_graph2_iso. 445 | exact: reduce_shuffle. 446 | * etransitivity. apply isop_step. 447 | 2: etransitivity. 448 | 2: apply one_step, (step_e0 (G:=unit_graph2 (a⊗(b⊗c))%CM) tt u). 449 | exists. apply: par2edgeunit. 450 | apply isop_step. exists. 451 | etransitivity. apply add_vlabel2_unit. apply unit_graph2_iso. 452 | exact: reduce_shuffle. 453 | * etransitivity. apply isop_step. 454 | 2: etransitivity. 455 | 2: apply one_step, (step_e2 (G:=two_graph2 (a⊗c)%CM (b⊗d)%CM) (inl tt) (inr tt) u v). 456 | 2: reflexivity. 457 | exists. apply: par_edges. 458 | 459 | - etransitivity. apply cnv_steps, IHu. 460 | case (nt u)=>[a|a v b]=>//=. 461 | apply isop_step. exists. 462 | etransitivity. refine (iso_iso2 (add_edge_rev _ _ _) _ _). 463 | rewrite eqvEcnv. symmetry. apply cnvI. 464 | simpl. symmetry. etransitivity. apply: (add_edge2_iso (iso_iso2 (union_C _ _) _ _)). 465 | reflexivity. 466 | 467 | - etransitivity. apply dom_steps, IHu. 468 | case (nt u)=>[a|a v b]=>//=. 469 | etransitivity. apply one_step, (@step_v1 _ (unit_graph2 a) tt v b). 470 | apply isop_step. exists. 471 | etransitivity. apply add_vlabel2_unit. apply unit_graph2_iso. 472 | done. (* reflexivity fails ... *) 473 | Qed. 474 | 475 | End s'. 476 | -------------------------------------------------------------------------------- /theories/core/rewriting.v: -------------------------------------------------------------------------------- 1 | From Coq Require Import Setoid Morphisms. 2 | From mathcomp Require Import all_ssreflect. 3 | From GraphTheory Require Import setoid_bigop structures pttdom mgraph mgraph2. 4 | 5 | Set Implicit Arguments. 6 | Unset Strict Implicit. 7 | Unset Printing Implicit Defensive. 8 | Set Bullet Behavior "Strict Subproofs". 9 | 10 | Section s. 11 | Variable X: pttdom. 12 | Notation test := (test X). 13 | Notation graph := (graph test X). 14 | Notation graph2 := (graph2 test X). 15 | 16 | (** * Rewrite System for 2p-graphs (additive presentation) *) 17 | 18 | (** In this file we define a rewrite system for reducing 2p-graphs 19 | labeled with elements of a 2pdom algebra. *) 20 | 21 | 22 | (** note: 23 | - we need everything to be finite to get a terminating rewrite system 24 | - elsewhere we don't care that the edge type is a finType, it could certainly just be a Type 25 | - the vertex type has to be an eqType at various places since we regularly compare vertices (e.g., [add_vlabel]) 26 | - the vertex type has to be a finType for the [merge] operation, but only in order to express the new vertex labeling function... we could imagine a [finitary_merge] operation that would not impose this restriction 27 | - the vertex type has to be finite also when we go to open graphs (although maybe countable would suffice) *) 28 | 29 | Inductive step: graph2 -> graph2 -> Prop := 30 | | step_v0: forall G alpha, 31 | step 32 | (G ∔ alpha) 33 | G 34 | | step_v1: forall (G: graph2) x u alpha, 35 | step 36 | (G ∔ alpha ∔ [inl x, u, inr tt]) 37 | (G [tst x <- [dom (u·elem_of alpha)]]) 38 | | step_v2: forall G x y u alpha v, 39 | step 40 | (G ∔ alpha ∔ [inl x, u, inr tt] ∔ [inr tt, v, inl y]) 41 | (G ∔ [x, u·elem_of alpha·v, y]) 42 | | step_e0: forall G x u, 43 | step 44 | (G ∔ [x, u, x]) 45 | (G [tst x <- [1%ptt∥u]]) 46 | | step_e2: forall G x y u v, 47 | step 48 | (G ∔ [x, u, y] ∔ [x, v, y]) 49 | (G ∔ [x, u∥v, y]). 50 | 51 | Inductive steps: relation graph2 := 52 | | iso_step F G: iso2 F G -> steps F G 53 | | cons_step F G H H': iso2 F G -> step G H -> steps H H' -> steps F H'. 54 | 55 | Global Instance PreOrder_steps: PreOrder steps. 56 | Proof. 57 | split. intro. by apply iso_step. 58 | intros F G H S S'. induction S as [F G I|F G G' G'' I S _ IH]. 59 | - destruct S' as [F' G' I'|F' G' G'' G''' I' S']. 60 | apply iso_step. etransitivity; eassumption. 61 | apply cons_step with G' G''=>//. etransitivity; eassumption. 62 | - apply cons_step with G G'=>//. by apply IH. 63 | Qed. 64 | 65 | Global Instance isop_step: subrelation iso2prop steps. 66 | Proof. intros F G [H]. by apply iso_step. Qed. 67 | 68 | Global Instance one_step: subrelation step steps. 69 | Proof. intros F G S. now apply cons_step with F G. Qed. 70 | 71 | Lemma steps_refl G: steps G G. 72 | Proof. reflexivity. Qed. 73 | 74 | End s. 75 | #[export] 76 | Hint Resolve steps_refl : core. 77 | -------------------------------------------------------------------------------- /theories/core/set_tac.v: -------------------------------------------------------------------------------- 1 | From mathcomp Require Import all_ssreflect. 2 | 3 | From GraphTheory Require Import preliminaries. 4 | 5 | Set Implicit Arguments. 6 | Unset Strict Implicit. 7 | Unset Printing Implicit Defensive. 8 | 9 | (** * Simple Experimental Tactic for finite sets *) 10 | 11 | (** We use a simple "tableau style" tactic for finite sets. We start 12 | by turning the goal into the form [A1, ..., An |- False] and then derive 13 | facts from the [Ai] until a constdiction is obtained or no more rules 14 | are applicable. *) 15 | 16 | Section SetTac. 17 | Variables (T : finType) (A B C : {set T}). 18 | 19 | Lemma set_tac_subUl: A :|: B \subset C -> A \subset C /\ B \subset C. 20 | Proof. rewrite subUset. by case/andP. Qed. 21 | 22 | Lemma set_tac_subIr: A \subset B :&: C -> A \subset B /\ A \subset C. 23 | Proof. rewrite subsetI. by case/andP. Qed. 24 | 25 | Lemma set_tac_subIl x : 26 | x \in A -> x \in B -> A :&: B \subset C -> x \in C. 27 | Proof. move => xA xB /subsetP. apply. by rewrite inE xA xB. Qed. 28 | 29 | End SetTac. 30 | 31 | Lemma setIPn (T : finType) (A B : {set T}) (x:T) : 32 | reflect (x \notin A \/ x \notin B) (x \notin A :&: B). 33 | Proof. rewrite !inE negb_and. exact: orP. Qed. 34 | 35 | Lemma setUPn (T : finType) (A B : {set T}) (x:T) : 36 | reflect (x \notin A /\ x \notin B) (x \notin A :|: B). 37 | Proof. rewrite !inE negb_or. exact: andP. Qed. 38 | 39 | Ltac notHyp b := assert_fails (assert b by assumption). 40 | 41 | Ltac extend H T := notHyp H; have ? : H by T. 42 | 43 | Ltac convertible A B := assert_succeeds (assert (A = B) by reflexivity). 44 | 45 | (** NOTE: since Ltac is untyped, we need to provide the coercions 46 | usually hidden, e.g., [is_true] or [SetDef.pred_of_set]. *) 47 | 48 | (** TOTHINK: For some collective predicates, in particular for paths, 49 | the coercion to a predicates can take several different forms. This 50 | means that rules involving [_ \subset _] should match up to conversion 51 | to not miss instances. Similarly, we need to perform a full conversion 52 | check when testing whether a given fact is already present. Otherwise, 53 | the "same" fact might be added multiple times *) 54 | 55 | (** NOTE: The only rules that introduce hypotheses of the form 56 | [_\subset _] are those eliminating equalities between sets. Since 57 | these remove their hypotheses, the trivial subset assumption 58 | [[set _] \subset A] can be modified in place *) 59 | 60 | Local Notation pos := pred_of_set. 61 | 62 | (** TODO: 63 | - reverse propagation for subset 64 | - dealing with setT and set0 65 | - dealing with existential hypotheses 66 | + A != B (possibly do the A != set0 case separately) 67 | + ~~ (A \subset B) (this is never generated, do as init?) 68 | 69 | *) 70 | 71 | Ltac no_inhabitant A := 72 | match goal with [ _ : ?x \in _ A |- _ ] => fail 1 | _ => idtac end. 73 | 74 | (* non-branching / closure rules *) 75 | Ltac set_tab_close := 76 | match goal with 77 | | [H : is_true (?x == ?y) |- _ ] => 78 | assert_fails (have: x = y by []); (* [x = y] is nontrivial and unknown *) 79 | move/eqP : (H) => ?; subst 80 | | [H : is_true (_ \in _ set0) |- _] => by rewrite in_set0 in H 81 | 82 | | [H : is_true (?x \in pos (?A :&: ?B)) |- _] => 83 | first [notHyp (x \in A)|notHyp(x \in B)]; case/setIP : (H) => [? ?] 84 | | [H : is_true (?x \in _ (?A :\: ?B)) |- _] => 85 | first [notHyp (x \in A)|notHyp(x \notin B)]; case/setDP : (H) => [? ?] 86 | | [H : is_true (?x \notin _ (?A :|: ?B)) |- _] => 87 | first [notHyp (x \notin A)|notHyp(x \notin B)]; case/setUPn : (H) => [? ?] 88 | | [H : is_true (?x \in pos (~: ?A)) |- _] => 89 | extend (x \notin A) ltac:(move: H; rewrite in_setC) 90 | | [H : is_true (?x \notin pos (~: ?A)) |- _] => 91 | extend (x \in A) ltac:(move: H; rewrite in_setC negbK) 92 | 93 | | [H : is_true (?x \in _ [set _ in ?p]) |- _ ] => 94 | extend (x \in p) ltac:(move: H; rewrite inE) 95 | | [H : is_true (?x \notin _ [set _ in ?p]) |- _ ] => 96 | extend (x \notin p) ltac:(move: H; rewrite inE) 97 | 98 | | [H : is_true (?x \in _ [set ?y]) |- _ ] => 99 | assert_fails (have: x = y by []); (* [x = y] is nontrivial and unknown *) 100 | move/set1P : (H) => ?;subst 101 | | [H : is_true (?x \notin _ [set ?y]) |- _ ] => 102 | extend (x != y) ltac:(move: H ; rewrite inE) 103 | 104 | (* These rules will be tried (and fail) on equalities between non-sets, but 105 | set types can take many different shapes *) 106 | | [ H : ?A = ?B |- _] => 107 | first [notHyp (A \subset B)|notHyp(B \subset A)]; 108 | have/andP[? ?]: (A \subset B) && (B \subset A) by 109 | (move/eqP : (H); rewrite eqEsubset; apply) 110 | | [ H : is_true (pos (?A :|: ?B) \subset ?C) |- _] => 111 | first[notHyp (A \subset C)|notHyp (B \subset C)]; 112 | case/set_tac_subUl : (H) => [? ?] 113 | | [ H : is_true (?A \subset pos (?B :&: ?C)) |- _] => 114 | first[notHyp (A \subset B)|notHyp (A \subset C)]; 115 | case/set_tac_subIr : (H) => [? ?] 116 | | [ H : is_true (pos [set ?x] \subset ?A) |- _] => 117 | extend (x \in A) ltac:(move: (H); rewrite sub1set; apply) 118 | 119 | | [H : is_true (in_mem ?x (mem ?A)), S : is_true (subset (mem ?A') (mem ?B)) |- _] => 120 | convertible (mem A) (mem A'); 121 | extend (x \in B) ltac:(move/(subsetP S) : (H) => ?) 122 | 123 | | [H : is_true (?x \in ?B), D : is_true [disjoint ?A & ?B] |- _] => 124 | notHyp (x \notin A); have ? : x \notin A by rewrite (disjointFl D H) 125 | | [H : is_true (?x \in ?A), D : is_true [disjoint ?A & ?B] |- _] => 126 | notHyp (x \notin B); have ? : x \notin B by rewrite (disjointFr D H) 127 | 128 | | [ H : is_true (?A != set0) |- _] => 129 | no_inhabitant A; case/set0Pn : H => [? ?] 130 | 131 | | [ xA : is_true (?x \in _ ?A), xB : is_true (?x \in _ ?B), 132 | H : is_true (_ (?A :&: ?B) \subset ?D) |- _] => 133 | notHyp (x \in D); have ? := set_tac_subIl xA xB H 134 | end. 135 | 136 | (*branching rules *) 137 | Ltac set_tab_branch := 138 | match goal with 139 | | [H : is_true (?x \in pos (?A :|: ?B)) |- _] => 140 | notHyp (x \in A); notHyp (x \in B); case/setUP : (H) => [?|?] 141 | | [ H : is_true (?x \notin pos (?A :&: ?B)) |- _] => 142 | notHyp (x \notin A); notHyp (x \notin B); case/setIPn : (H) => [?|?] 143 | end. 144 | 145 | (** Note that the rules on disjointness and subset do not restricted 146 | to the type [{set _}] *) 147 | 148 | Ltac set_init := 149 | match goal with 150 | | [ |- forall _,_ ] => intro;set_init 151 | | [ |- _ -> _] => intro;set_init 152 | | [ |- is_true (~~ _) ] => apply/negP => ? 153 | | [ |- is_true _] => apply: contraTT isT => ? 154 | | [ |- _ ] => idtac (* nothing to be done here *) 155 | end. 156 | 157 | Ltac clean_mem := 158 | repeat match goal with 159 | [ H : _ |- _ ] => rewrite !mem_mem in H 160 | end; rewrite !mem_mem. 161 | 162 | (** Tactics intened to be redefined when combining sets with set-like 163 | structures (e.g., paths in graphs) *) 164 | 165 | Ltac set_tac_close_plus := fail. 166 | Ltac set_tac_branch_plus := fail. 167 | 168 | Ltac eqxx := match goal with 169 | | [ H : is_true (?x != ?x) |- _ ] => by rewrite eqxx in H 170 | end. 171 | 172 | (** Use theory rules (plus) before set rules *) 173 | Ltac set_tac_step := first [eqxx 174 | |contrab 175 | |set_tac_close_plus 176 | |set_tab_close 177 | |set_tac_branch_plus 178 | |set_tab_branch]. 179 | 180 | Ltac set_tac := set_init; subst; repeat set_tac_step. 181 | 182 | (** Use typeclass inference to trigger set_tac using rewrite lemmas *) 183 | 184 | Class setBox (P : Prop) : Prop := SetBox { setBoxed : P }. 185 | #[export] 186 | Hint Extern 0 (setBox _) => apply SetBox; set_tac : typeclass_instances. 187 | 188 | Lemma inD (T : finType) (x : T) (A : pred T) `{setBox (x \in A)} : x \in A. 189 | Proof. by case: H. Qed. 190 | 191 | Lemma inD_debug (T : finType) (x : T) (A : pred T) : (x \in A) -> x \in A. 192 | Proof. by []. Qed. 193 | 194 | Lemma notinD (T : finType) (x : T) (A : pred T) `{setBox (x \notin A)} : x \notin A. 195 | Proof. by case: H. Qed. 196 | 197 | Lemma notinD_debug (T : finType) (x : T) (A : pred T) : (x \notin A) -> x \notin A. 198 | Proof. by []. Qed. 199 | 200 | 201 | (* examples / unit tests *) 202 | 203 | Goal forall (T:finType) (S V1 V2 : {set T}) x b, x \in S -> S = V1 :&: V2 -> b || (x \in V1). 204 | Proof. move => *. by rewrite inD orbT. Qed. 205 | 206 | Goal forall (T:finType) (A B : {set T}) x b, x \in B -> B \subset A -> (x \in A) || b. 207 | Proof. move => T A B x b H D. by rewrite inD. Qed. 208 | 209 | Goal forall (T:finType) (A B : {set T}) x b, x \in B -> [disjoint A & B] -> (x \notin A) || b. 210 | Proof. move => T A B x b H D. by rewrite notinD. Qed. 211 | 212 | Goal forall (T:finType) (A B : {set T}) x b, x \in A -> [disjoint A & B] -> b || (x \notin B). 213 | Proof. move => T A B x b H D. by rewrite notinD orbT. Qed. 214 | 215 | Goal forall (T:finType) (A B : {set T}) x b, x \notin A -> x \in A :|: B -> b || (x \in B). 216 | Proof. move => *. by rewrite inD orbT. Qed. 217 | 218 | (** NOTE: This does not require backward propagation of \subset since [x \in B] is assumed *) 219 | Goal forall (T:finType) (A B : {set T}) x b, x \notin A -> B \subset A -> (x \notin B) || b. 220 | Proof. move => T A B x b H D. by rewrite notinD. Qed. 221 | 222 | Goal forall (T:finType) (A B : {set T}) x, x \in A -> A = B -> x \in B. 223 | Proof. by set_tac. Qed. 224 | 225 | Goal forall (T:finType) (A B : {set T}) x, x \in A -> A == B -> x \in B. 226 | Proof. by set_tac. Qed. 227 | -------------------------------------------------------------------------------- /theories/core/setoid_bigop.v: -------------------------------------------------------------------------------- 1 | From HB Require Import structures. 2 | From Coq Require Import RelationClasses Morphisms Relation_Definitions. 3 | From mathcomp Require Import all_ssreflect. 4 | 5 | Set Implicit Arguments. 6 | Unset Strict Implicit. 7 | 8 | (** * Bigops over Setoids *) 9 | 10 | (** This file generalizes various lemmas from 11 | [mathcomp.ssreflect.bigop] to the setting where monoid laws only hold 12 | up to the equivalence of some setoid. *) 13 | 14 | HB.mixin Record Setoid_of_Type A := 15 | { eqv : relation A; Eqv : Equivalence eqv }. 16 | 17 | HB.structure Definition Setoid := { A of Setoid_of_Type A }. 18 | Notation setoid := Setoid.type. 19 | 20 | Declare Scope setoid_scope. 21 | Open Scope setoid_scope. 22 | Infix "≡" := eqv (at level 79) : setoid_scope. 23 | Notation "x ≡ y :> X" := ((x : X) ≡ (y : X)) 24 | (at level 79, y at next level, only parsing) : setoid_scope. 25 | Global Existing Instance Eqv. 26 | 27 | Definition flat (A : Type) := A. 28 | 29 | HB.instance Definition _ (A : Type) := Setoid_of_Type.Build (flat A) (@eq_equivalence A). 30 | HB.instance Definition _ := Setoid_of_Type.Build unit (@eq_equivalence unit). 31 | 32 | Lemma eqvxx (X : setoid) (x : X) : x ≡ x. reflexivity. Qed. 33 | Arguments eqvxx {X x}. 34 | 35 | (** This allows [trivial] (and hence [done]) to solve [x ≡ x]. *) 36 | #[export] Hint Extern 0 => reflexivity : core. 37 | 38 | Class monoidLaws {X : setoid} (mon0 : X) (mon2 : X -> X -> X) := 39 | MonoidLaws { 40 | mon_eqv: Proper (eqv ==> eqv ==> eqv) mon2; 41 | monA: forall x y z, mon2 x (mon2 y z) ≡ mon2 (mon2 x y) z; 42 | monU: forall x, mon2 x mon0 ≡ x; 43 | monUl: forall x, mon2 mon0 x ≡ x 44 | }. 45 | Global Existing Instance mon_eqv. 46 | 47 | Class comMonoidLaws {X:setoid} (mon0 : X) (mon2 : X -> X -> X) := 48 | ComMonoidLaws { 49 | mon_of_com :: monoidLaws mon0 mon2; 50 | monC : forall x y, mon2 x y ≡ mon2 y x 51 | }. 52 | 53 | Section SetoidTheory. 54 | Variables (X : setoid) (mon0 : X) (mon2 : X -> X -> X). 55 | Local Notation "1" := mon0. 56 | Local Notation "*%M" := mon2 (at level 0). 57 | Notation "x ⊗ y" := (mon2 x y) (left associativity, at level 25). 58 | 59 | Lemma monUl_of_com : 60 | (forall x, mon2 x mon0 ≡ x) -> (forall x y, mon2 x y ≡ mon2 y x) -> forall x, mon2 mon0 x ≡ x. 61 | Proof. move => monU monC x. by rewrite monC monU. Qed. 62 | 63 | Definition mkComMonoidLaws 64 | (mon_eqv: Proper (eqv ==> eqv ==> eqv) mon2) 65 | (monA: forall x y z, mon2 x (mon2 y z) ≡ mon2 (mon2 x y) z) 66 | (monC : forall x y, mon2 x y ≡ mon2 y x) 67 | (monU: forall x, mon2 x mon0 ≡ x) := 68 | ComMonoidLaws (MonoidLaws mon_eqv monA monU (monUl_of_com monU monC)) monC. 69 | 70 | Section MonoidTheory. 71 | Context {X_monoid : monoidLaws mon0 mon2}. 72 | 73 | (* TOTHINK: The initial lemmas only require the Proper instance: introduce another class? *) 74 | Lemma eqv_bigr (I : Type) (r : seq I) (P : pred I) (F1 F2 : I -> X) : 75 | (forall i : I, P i -> F1 i ≡ F2 i) -> \big[*%M/1]_(i <- r | P i) F1 i ≡ \big[*%M/1]_(i <- r | P i) F2 i. 76 | Proof. elim/big_rec2 : _ => // i x y Pi H1 H2. by rewrite H2 ?H1. Qed. 77 | 78 | Lemma eqv_bigl I r (P1 P2 : pred I) (F : I -> X) : 79 | P1 =1 P2 -> 80 | \big[*%M/1]_(i <- r | P1 i) F i ≡ \big[*%M/1]_(i <- r | P2 i) F i. 81 | Proof. by move=> eqP12; rewrite -!(big_filter r) (eq_filter eqP12). Qed. 82 | 83 | Lemma eqv_big I (r:seq I) (P1 P2 : pred I) (F1 F2 : I -> X) : 84 | P1 =1 P2 -> (forall i, P1 i -> F1 i ≡ F2 i) -> 85 | \big[*%M/1]_(i <- r | P1 i) F1 i ≡ \big[*%M/1]_(i <- r | P2 i) F2 i. 86 | Proof. by move/eqv_bigl <-; move/eqv_bigr->. Qed. 87 | 88 | Lemma big_mkcond (I : eqType) (r : seq I) (P : pred I) (F : I -> X) : 89 | \big[*%M/1]_(i <- r | P i) F i ≡ \big[*%M/1]_(i <- r) (if P i then F i else 1). 90 | Proof. rewrite unlock. elim: r => //= i r H. by case P; rewrite H ?monUl. Qed. 91 | 92 | Lemma big_cat (I : eqType) (r1 r2 : seq I) (P : pred I) (F : I -> X) : 93 | \big[*%M/1]_(i <- (r1 ++ r2) | P i) F i ≡ 94 | (\big[*%M/1]_(i <- r1 | P i) F i) ⊗ (\big[*%M/1]_(i <- r2 | P i) F i). 95 | Proof. 96 | rewrite !(big_mkcond _ P). elim: r1 => /= [|i r1 IH]; first by rewrite big_nil monUl. 97 | by rewrite !big_cons IH monA. 98 | Qed. 99 | 100 | Lemma big_seq1 (I : Type) (i : I) (F : I -> X) : \big[*%M/1]_(j <- [:: i]) F j ≡ F i. 101 | Proof. by rewrite big_cons big_nil monU. Qed. 102 | 103 | Lemma big_pred1_eq (I : finType) (i : I) (F : I -> X) : 104 | \big[*%M/1]_(j | j == i) F j ≡ F i. 105 | Proof. 106 | rewrite -big_filter filter_pred1_uniq //; first by rewrite big_seq1. 107 | solve [by rewrite /index_enum -?enumT ?enum_uniq (* mathcomp-1.9.0 *) 108 | |exact: index_enum_uniq]. (* mathcomp-1.10.0 *) 109 | Qed. 110 | 111 | Lemma big_pred1 (I : finType) i (P : pred I) (F : I -> X) : 112 | P =1 pred1 i -> \big[*%M/1]_(j | P j) F j ≡ F i. 113 | Proof. move/(eq_bigl _ _)->; apply: big_pred1_eq. Qed. 114 | 115 | Lemma eqv_map (I1 I2 : finType) (r1 : seq I1) (P1 : pred I1) (P2 : pred I2) 116 | (f : I1 -> I2) (F1 : I1 -> X) (F2 : I2 -> X) : 117 | (forall x, P1 x = P2 (f x)) -> (forall i : I1, P1 i -> F1 i ≡ F2 (f i)) -> 118 | \big[*%M/1]_(i <- r1 | P1 i) F1 i ≡ \big[*%M/1]_(i <- map f r1 | P2 i) F2 i. 119 | Proof. 120 | move => HP HF. elim r1 => [|k r2 IH]; first by rewrite !big_nil. 121 | rewrite /= !big_cons -HP. case: (boolP (P1 k)) => [Pk|_]; by rewrite -?HF ?IH. 122 | Qed. 123 | 124 | End MonoidTheory. 125 | 126 | Section ComMonoidTheory. 127 | Context {X_comMonoid : comMonoidLaws mon0 mon2}. 128 | 129 | Local Notation "1" := mon0. 130 | Local Notation "*%M" := mon2 (at level 0). 131 | Notation "x ⊗ y" := (mon2 x y) (left associativity, at level 25). 132 | 133 | Lemma big_split I r (P : pred I) (F1 F2 : I -> X) : 134 | \big[*%M/1]_(i <- r | P i) (F1 i ⊗ F2 i) ≡ 135 | (\big[*%M/1]_(i <- r | P i) F1 i) ⊗ (\big[*%M/1]_(i <- r | P i) F2 i). 136 | Proof. 137 | elim/big_rec3 : _ => [|i x y z Pi ->]; rewrite ?monU //. 138 | rewrite -!monA. apply: mon_eqv => //. by rewrite monA [_ ⊗ y]monC monA. 139 | Qed. 140 | 141 | Lemma perm_big (I : eqType) r1 r2 (P : pred I) (F : I -> X) : 142 | perm_eq r1 r2 -> 143 | \big[*%M/1]_(i <- r1 | P i) F i ≡ \big[*%M/1]_(i <- r2 | P i) F i. 144 | Proof. 145 | move/permP; rewrite !(big_mkcond _ P). 146 | elim: r1 r2 => [|i r1 IHr1] r2 eq_r12. 147 | by case: r2 eq_r12 => // i r2; move/(_ (pred1 i)); rewrite /= eqxx. 148 | have r2i: i \in r2 by rewrite -has_pred1 has_count -eq_r12 /= eqxx. 149 | case/splitPr: r2 / r2i => [r3 r4] in eq_r12 *. rewrite big_cat /= !big_cons. 150 | rewrite monA [_ ⊗ if _ then _ else _]monC -monA. rewrite -big_cat. 151 | rewrite (IHr1 (r3 ++ r4)) //. move => a. move/(_ a) : eq_r12. 152 | rewrite !count_cat /= addnCA. apply: addnI. 153 | Qed. 154 | 155 | Lemma bigID (I:eqType) r (a P : pred I) (F : I -> X) : 156 | \big[*%M/1]_(i <- r | P i) F i ≡ 157 | (\big[*%M/1]_(i <- r | P i && a i) F i) ⊗ (\big[*%M/1]_(i <- r | P i && ~~ a i) F i). 158 | Proof. 159 | rewrite !(@big_mkcond _ I r _ F) -big_split. 160 | apply: eqv_bigr => i; case: (a i); by rewrite /= ?andbT ?andbF ?monU ?monUl. 161 | Qed. 162 | Arguments bigID [I r] a P F. 163 | 164 | 165 | Lemma bigD1 (I : finType) j (P : pred I) (F : I -> X) : 166 | P j -> \big[*%M/1]_(i | P i) F i ≡ F j ⊗ (\big[*%M/1]_(i | P i && (i != j)) F i). 167 | Proof. 168 | move=> Pj; rewrite (bigID (pred1 j)); apply mon_eqv => //. 169 | apply: big_pred1 => i /=. by rewrite /= andbC; case: eqP => // ->. 170 | Qed. 171 | Arguments bigD1 [I] j [P F]. 172 | 173 | Lemma reindex_onto (I J : finType) (h : J -> I) h' (P : pred I) (F : I -> X) : 174 | (forall i, P i -> h (h' i) = i) -> 175 | \big[*%M/1]_(i | P i) F i ≡ 176 | \big[*%M/1]_(j | P (h j) && (h' (h j) == j)) F (h j). 177 | Proof. 178 | move=> h'K; elim: {P}_.+1 {-3}P h'K (ltnSn #|P|) => //= n IHn P h'K. 179 | case: (pickP P) => [i Pi | P0 _]; last first. 180 | by rewrite !big_pred0 // => j; rewrite P0. 181 | rewrite ltnS (cardD1x Pi); move/IHn {n IHn} => IH. 182 | rewrite (bigD1 i Pi) (bigD1 (h' i)) h'K ?Pi ?eq_refl //=. apply: mon_eqv => //. 183 | rewrite {}IH => [|j]; [apply: eqv_bigl => j | by case/andP; auto]. 184 | rewrite andbC -andbA (andbCA (P _)); case: eqP => //= hK; congr (_ && ~~ _). 185 | by apply/eqP/eqP=> [<-|->] //; rewrite h'K. 186 | Qed. 187 | Arguments reindex_onto [I J] h h' [P F]. 188 | 189 | Lemma reindex (I J : finType) (h : J -> I) (P : pred I) (F : I -> X) : 190 | {on [pred i | P i], bijective h} -> 191 | \big[*%M/1]_(i | P i) F i ≡ \big[*%M/1]_(j | P (h j)) F (h j). 192 | Proof. 193 | case=> h' hK h'K; rewrite (reindex_onto h h' h'K). 194 | by apply eqv_bigl => j; rewrite !inE; case Pi: (P _); rewrite //= hK ?eqxx. 195 | Qed. 196 | Arguments reindex [I J] h P F. 197 | 198 | Lemma partition_big (I J : finType) (P : pred I) p (Q : pred J) (F : I -> X) : 199 | (forall i, P i -> Q (p i)) -> 200 | \big[*%M/1]_(i | P i) F i ≡ 201 | \big[*%M/1]_(j | Q j) \big[*%M/1]_(i | P i && (p i == j)) F i. 202 | Proof. 203 | move=> Qp; transitivity (\big[*%M/1]_(i | P i && Q (p i)) F i). 204 | by apply: eqv_bigl => i; case Pi: (P i); rewrite // Qp. 205 | elim: {Q Qp}_.+1 {-2}Q (ltnSn #|Q|) => // n IHn Q. 206 | case: (pickP Q) => [j Qj | Q0 _]; last first. 207 | by rewrite !big_pred0 // => i; rewrite Q0 andbF. 208 | rewrite ltnS (cardD1x Qj) (bigD1 j) //; move/IHn=> {n IHn} <-. 209 | rewrite (bigID (fun i => p i == j)) => /=. apply: mon_eqv; apply: eqv_bigl => i. 210 | case: eqP => [-> | _] ; by rewrite ?(Qj) ?andbT ?andbF. 211 | by rewrite andbA. 212 | Qed. 213 | 214 | Lemma big_sumType (I1 I2 : finType) (P : pred (I1 + I2)) (F : (I1 + I2) -> X) : 215 | \big[*%M/1]_(x | P x) F x ≡ 216 | (\big[*%M/1]_(x | P (inl x)) F (inl x)) ⊗ (\big[*%M/1]_(x | P (inr x)) F (inr x)). 217 | Proof. by rewrite ![index_enum _]unlock [@Finite.enum in X in X ≡ _]unlock big_cat !big_map. Qed. 218 | Arguments big_sumType [I1 I2] P F. 219 | 220 | Lemma big_unitType (P : pred unit) (F : unit -> X) : 221 | \big[*%M/1]_(x | P x) F x ≡ if P tt then F tt else 1. 222 | Proof. by rewrite ![index_enum _]unlock [@Finite.enum]unlock big_mkcond big_seq1. Qed. 223 | 224 | (** in conjunction with [bij_perm_enum] *) 225 | Lemma eqv_big_bij (I1 I2 : finType) (f : I1 -> I2) 226 | (r1 : seq I1) (r2 : seq I2) (P1 : pred I1) (P2 : pred I2) (F1 : I1 -> X) (F2 : I2 -> X) : 227 | perm_eq r2 (map f r1) -> (forall x, P1 x = P2 (f x)) -> (forall i : I1, P1 i -> F1 i ≡ F2 (f i)) -> 228 | \big[*%M/1]_(i <- r1 | P1 i) F1 i ≡ \big[*%M/1]_(i <- r2 | P2 i) F2 i. 229 | Proof. move => pr HP HF. rewrite (perm_big _ _ pr). exact: eqv_map. Qed. 230 | 231 | Lemma big_inj2_eq (I1 I2 : finType) (F : I1 -> X) (f : I1 -> I2) (y : I1) : 232 | injective f -> \big[*%M/mon0]_(x | f x == f y) F x ≡ F y. 233 | Proof. move => inj_f; rewrite (@big_pred1 _ _ y) //= => x; exact: inj_eq. Qed. 234 | 235 | End ComMonoidTheory. 236 | End SetoidTheory. 237 | 238 | Arguments reindex_onto [X mon0 mon2 _ I J] h h' [P F]. 239 | Arguments reindex [X mon0 mon2 _ I J] h [P F]. 240 | Arguments bigD1 [X mon0 mon2 _ I] j [P F]. 241 | Arguments partition_big [X mon0 mon2 _ I J P] p Q [F]. 242 | Arguments big_pred1 [X mon0 mon2 _ I] i P F. 243 | -------------------------------------------------------------------------------- /theories/core/structures.v: -------------------------------------------------------------------------------- 1 | From HB Require Import structures. 2 | From Coq Require Import RelationClasses Morphisms Relation_Definitions. 3 | From mathcomp Require Import all_ssreflect. 4 | From GraphTheory Require Import edone preliminaries setoid_bigop bij. 5 | 6 | Set Implicit Arguments. 7 | Unset Strict Implicit. 8 | 9 | (** * Setoids and Label Structures *) 10 | 11 | (* Note on Equivalences and Morphisms: This development mixes both 12 | rewriting in Prop (e.g., 2pdom algebras) and rewriting in Type (e.g., 13 | iso). To facilitate this, we import the Prop versions and introduce 14 | notations for the Type versions. This leads to the follwing usage 15 | patterns: 16 | 17 | - Morphisms and Relation classes should be imported as needed. 18 | - CMorhisms and CRelationClasses should be Required but never imported. 19 | - There are notations CEquivalence and CProper that refer to the Type versions. 20 | - The "_ ==> ..." argumentof CProper is parsed using the respectful from CMorphisms. 21 | *) 22 | 23 | Notation CEquivalence := CRelationClasses.Equivalence. 24 | Notation CProper := CMorphisms.Proper. 25 | Declare Scope csignature. 26 | Delimit Scope csignature with C. 27 | Notation "A ==> B" := (@CMorphisms.respectful _ _ (A%C) (B%C)) : csignature. 28 | Arguments CMorphisms.Proper [A] _%C _. 29 | 30 | Section CProper. 31 | Variables A B C: Type. 32 | Notation i R := (fun x y => inhabited (R x y)). 33 | Variable R: A -> A -> Type. 34 | Variable S: B -> B -> Type. 35 | Variable T: C -> C -> Type. 36 | Variable f: A -> B. 37 | Hypothesis Hf: CProper (R ==> S) f. 38 | Lemma CProper1: Proper (i R ==> i S) f. 39 | Proof. intros x y [H]. exists. by apply Hf. Qed. 40 | Variable g: A -> B -> C. 41 | Hypothesis Hg: CProper (R ==> S ==> T) g. 42 | Lemma CProper2: Proper (i R ==> i S ==> i T) g. 43 | Proof. intros x y [E] u v [F]. exists. by apply Hg. Qed. 44 | End CProper. 45 | 46 | 47 | (** ** label structures (Definition 4.1) *) 48 | 49 | (** The original label structure (comment has been split into a commutative monoid (for 50 | the vertex labels) and an "elabel Type" (accounting for possible edge-flipping) 51 | for edge labels. *) 52 | 53 | (* 54 | Record labels := 55 | Labels { 56 | lv: setoid; 57 | mon0: lv; 58 | mon2: lv -> lv -> lv; 59 | lv_monoid: comMonoidLaws mon0 mon2; 60 | le: setoid; 61 | eqv': relation le; 62 | Eqv'_sym: Symmetric eqv'; 63 | eqv01: forall x y z, eqv x y -> eqv' y z -> eqv' x z; 64 | eqv11: forall x y z, eqv' x y -> eqv' y z -> eqv x z; 65 | }. 66 | Global Existing Instance lv_monoid. 67 | *) 68 | 69 | HB.mixin Record ComMonoid_of_Setoid A of Setoid_of_Type A := 70 | { cm_id : A; 71 | cm_op : A -> A -> A; 72 | cm_laws : comMonoidLaws cm_id cm_op }. 73 | HB.structure Definition ComMonoid := { A of ComMonoid_of_Setoid A & }. 74 | Notation comMonoid := ComMonoid.type. 75 | 76 | #[export] Existing Instance cm_laws. 77 | Arguments cm_op {_} _ _. 78 | Declare Scope cm_scope. 79 | Delimit Scope cm_scope with CM. 80 | Infix "⊗" := cm_op (left associativity, at level 25) : cm_scope. 81 | Arguments cm_id {_}. 82 | Notation "1" := cm_id : cm_scope. 83 | 84 | (** ingredients required to label graphs 85 | - eqv' x y = eqv x y° (when we have an involution _°) 86 | - eqv' _ _ = False (otherwise) *) 87 | 88 | HB.mixin Record Elabel_of_Setoid A of Setoid_of_Type A := 89 | { eqv': Relation_Definitions.relation A; 90 | Eqv'_sym: Symmetric eqv'; 91 | eqv01: forall x y z : A, eqv x y -> eqv' y z -> eqv' x z; 92 | eqv11: forall x y z : A, eqv' x y -> eqv' y z -> eqv x z }. 93 | HB.structure Definition Elabel := { A of Elabel_of_Setoid A & }. 94 | Notation elabelType := Elabel.type. 95 | Infix "≡'" := eqv' (at level 79). 96 | 97 | Lemma eqv10 (l : elabelType) (x y z : l) : eqv' x y -> eqv y z -> eqv' x z. 98 | Proof. move => /Eqv'_sym A B. apply: Eqv'_sym. apply: eqv01 A. by symmetry. Qed. 99 | 100 | (* switch between [≡] and [≡'] based on a Boolean 101 | (useful for defining potentially edge swapping homomorphisms) *) 102 | Definition eqv_ (X: elabelType) (b: bool) (x y: X) := if b then x ≡' y else x ≡ y. 103 | Notation "x ≡[ b ] y" := (eqv_ b x y) (at level 79). 104 | Global Instance eqv_sym {X: elabelType} {b}: Symmetric (@eqv_ X b). 105 | Proof. case b=> x y/=. apply Eqv'_sym. by symmetry. Qed. 106 | 107 | Lemma eqvb_trans (X : elabelType) (u v w : X) (b1 b2 : bool) : 108 | u ≡[b1] v -> v ≡[b2] w -> u ≡[b1 (+) b2] w. 109 | Proof. 110 | case: b1; case: b2 => /=; try solve [exact: eqv01|exact: eqv11|exact: eqv10]. 111 | by transitivity v. 112 | Qed. 113 | 114 | (* variants of the above that are more useful for backward chaining *) 115 | Lemma eqvb_transR (X : elabelType) b b' (u v v' : X) : 116 | u ≡[b (+) b'] v' -> v' ≡[b'] v -> u ≡[b] v. 117 | Proof. move => A B. move:(eqvb_trans A B). by rewrite -addbA addbb addbF. Qed. 118 | 119 | Lemma eqvb_transL (X : elabelType) b b' (u u' v : X) : 120 | u' ≡[b (+) b'] v -> u ≡[b'] u' -> u ≡[b] v. 121 | Proof. move => A B. move:(eqvb_trans B A). by rewrite addbC -addbA addbb addbF. Qed. 122 | 123 | Global Instance eqv_morphim (X: elabelType) : 124 | Proper (eq ==> eqv ==> eqv ==> iff) (@eqv_ X). 125 | Proof. 126 | move => b ? <- x x' xx y y' yy. 127 | change (x ≡[false] x') in xx. change (y ≡[false] y') in yy. split => H. 128 | - symmetry in xx. apply: eqvb_transR yy. apply: eqvb_transL xx. by rewrite !addbF. 129 | - symmetry in yy. apply: eqvb_transR yy. apply: eqvb_transL xx. by rewrite !addbF. 130 | Qed. 131 | 132 | Lemma eq_unit (a b: unit): a = b. 133 | Proof. by case a; case b. Qed. 134 | #[export] 135 | Hint Resolve eq_unit: core. 136 | 137 | Lemma big_bij_eq (T : comMonoid) (I1 I2 : finType) (F : I1 -> T) (f : bij I1 I2) (y : I2) : 138 | \big[cm_op/1%CM]_(x | f x == y) F x ≡ F (f^-1 y). 139 | Proof. apply: big_pred1 => x /=. exact: bij_eqLR. Qed. 140 | 141 | (* TOTHINK: this is necessary because f^-1 is a bijective function and not a bijection ... *) 142 | Lemma big_bij_eq' (T : comMonoid) (I1 I2 : finType) (F : I1 -> T) (f : bij I2 I1) (y : I2) : 143 | \big[cm_op/1%CM]_(x | f^-1 x == y) F x ≡ F (f y). 144 | Proof. apply: big_pred1 => x /=. by rewrite eq_sym -bij_eqLR eq_sym. Qed. 145 | 146 | (** ** Structure Inference *) 147 | 148 | (** On [unit], [eq] is the only equivalence relation. Hence, we can 149 | safely register [unit_setoid] as the canonical setoid for unit *) 150 | 151 | Lemma unit_commMonoidLaws : comMonoidLaws tt (fun _ _ => tt). 152 | Proof. by do 2 (split; try done). Qed. 153 | 154 | HB.instance Definition unit_commMonoid := 155 | ComMonoid_of_Setoid.Build unit unit_commMonoidLaws. 156 | 157 | (** Any type can be endowed with a flat edge-label structure over the 158 | equality setoid. However, we cannot declare this canonical for 159 | arbitrary types, because this would take precedence over all other 160 | setoids. Instead, we introduce an alias [flat] and equip it with a 161 | flat edge-label structure. Note that [flat A] is convertible to [A] *) 162 | 163 | Section E. 164 | Variable (A : Type). 165 | Let rel := (fun _ _ : A => False). 166 | Let rel_sym : Symmetric rel. by []. Qed. 167 | Let rel01 (x y z : A) : x = y -> rel y z -> rel x z. by []. Qed. 168 | Let rel11 (x y z : A) : rel x y -> rel y z -> x = z. by []. Qed. 169 | 170 | HB.instance Definition flat_elabel_mixin := 171 | @Elabel_of_Setoid.Build (flat A) rel rel_sym rel01 rel11. 172 | End E. 173 | -------------------------------------------------------------------------------- /theories/planar/K4plane.v: -------------------------------------------------------------------------------- 1 | From mathcomp Require Import all_ssreflect. 2 | From fourcolor Require Import hypermap geometry. 3 | From GraphTheory Require Import preliminaries digraph sgraph. 4 | From GraphTheory Require Import hmap_ops embedding. 5 | 6 | Set Implicit Arguments. 7 | Unset Strict Implicit. 8 | Unset Printing Implicit Defensive. 9 | 10 | Lemma order_max (T : finType) (f : T -> T) (x : T) : order f x <= #|T|. 11 | Proof. by rewrite -size_orbit -(card_uniqP _) ?max_card ?orbit_uniq. Qed. 12 | 13 | 14 | 15 | Section Dfs. 16 | Variables (T : finType) (g : T -> seq T). 17 | 18 | (* not used *) 19 | Lemma dfs_uniq (v : seq T) x n : 20 | uniq v -> uniq (dfs g n v x). 21 | Proof. 22 | elim: n v x => [|/= n IHn] v x uniq_v ; first by rewrite /= if_same. 23 | have [//|xNv] := boolP (x \in v). 24 | have: uniq (x::v) by rewrite /= xNv. 25 | elim: (g x) (x::v) => //= => {v x uniq_v xNv} y gx IHgx v uniq_v. 26 | exact/IHgx/IHn. 27 | Qed. 28 | 29 | Lemma dfs_start x : x \in dfs g #|T| [::] x. 30 | Proof. by apply/dfsP; exists [::]. Qed. 31 | 32 | (** To actually run [dfs] we need to have [#|T|] as an explicit number *) 33 | Variable k : nat. 34 | Hypothesis kT : k = #|T|. 35 | 36 | Definition connect_dfs x := dfs g k [::] x. 37 | 38 | Lemma connectEdfs x : connect (grel g) x =i connect_dfs x. 39 | Proof. by move=> y;rewrite /connect_dfs kT; apply/connectP/dfsP. Qed. 40 | 41 | Fixpoint n_comp_dfs_rec n (s: seq T) := 42 | if n isn't n'.+1 then 0 else 43 | if s is y::s' then 44 | let p := connect_dfs y in 45 | (n_comp_dfs_rec n' (filter [predC p] s')).+1 else 0. 46 | 47 | Definition n_comp_dfs s := n_comp_dfs_rec (size s) s. 48 | 49 | Lemma n_comp_dfsP (s: seq T) : 50 | connect_sym (grel g) -> closed (grel g) s -> n_comp (grel g) s = n_comp_dfs s. 51 | Proof. 52 | move=> csym_g; rewrite /n_comp_dfs; move: {-1}(size s) (leqnn (size s)) => n. 53 | have [m Hm] := ubnP (size s); elim: m s Hm n => // m IH [_|y s /ltnSE Hm [//|n]]. 54 | by move => n _ _; rewrite n_comp0 //; case: n. 55 | move=> leq_s_n closed_y; set p := connect_dfs y. 56 | have y_p : y \in p by rewrite /p/connect_dfs kT; exact: dfs_start. 57 | have Hp : p =i connect (grel g) y by move => ?; apply/esym/connectEdfs. 58 | have sub_p : {subset p <= y::s}. 59 | { move=> z; rewrite Hp inE => con_yz. 60 | by rewrite -(closed_connect closed_y con_yz) mem_head. } 61 | rewrite (n_compD (mem p)) [RHS]/= -/p -add1n; congr(_ + _). 62 | - suff S : [predI y :: s & mem p] =i connect (grel g) y. 63 | by rewrite (eq_n_comp_r S) n_comp_connect. 64 | by move=> z; rewrite -[RHS]Hp inE /= andb_idl//; exact: sub_p. 65 | - rewrite -IH. 66 | + apply: eq_n_comp_r => z; rewrite mem_filter !inE. 67 | have [//|zNp/=] := boolP (z \in p); rewrite (_ : z == y = false) //. 68 | by apply: contraNF zNp => /eqP->. 69 | + by apply: leq_trans Hm; rewrite size_filter /= ltnS count_size. 70 | + rewrite /= ltnS in leq_s_n. apply: leq_trans leq_s_n. 71 | by rewrite size_filter count_size. 72 | + have -> : [seq x <- s | [predC p] x] = [seq x <- y::s | [predC p] x]. 73 | by rewrite /= y_p. 74 | have i : [seq x <- y :: s | [predC p] x] =i [predD (y :: s) & p]. 75 | by move=> z; rewrite mem_filter /= !inE. 76 | rewrite (eq_closed_r i); apply: predD_closed => //. 77 | by rewrite (eq_closed_r Hp); apply: connect_closed. 78 | Qed. 79 | 80 | End Dfs. 81 | 82 | (** TODO: this uses nothing that is specific to ['I_n], all we use is 83 | that [#|'I_n| = n] and that we habe a concrete enumeration, i.e., one 84 | where all elements of the list are of the form [Ordinal n (isT : _)]. 85 | Hence, it would be preferrabe to introduce a class or structure for 86 | this. *) 87 | 88 | Section ComputeOrd. 89 | Variable (n : nat). 90 | 91 | Definition ord_enum_eq : seq 'I_n := pmap (insub_eq _) (iota 0 n). 92 | 93 | Lemma eq_ord_enum : ord_enum_eq = ord_enum n. 94 | Proof. apply:eq_in_pmap => k _. exact: insub_eqE. Qed. 95 | 96 | Lemma ord_enum_eqT : ord_enum_eq =i 'I_n. 97 | Proof. by move => i; rewrite eq_ord_enum mem_ord_enum. Qed. 98 | 99 | Lemma forall_all_ord (p : {pred 'I_n}) : 100 | [forall x : 'I_n, p x] = all p ord_enum_eq. 101 | Proof. 102 | by rewrite forall_all; apply/eq_all_r => x; rewrite mem_enum ord_enum_eqT. 103 | Qed. 104 | 105 | Lemma exists_has_ord (p : {pred 'I_n}) : 106 | [exists x : 'I_n, p x] = has p ord_enum_eq. 107 | Proof. 108 | by rewrite exists_has ; apply/eq_has_r => x; rewrite mem_enum ord_enum_eqT. 109 | Qed. 110 | 111 | Implicit Types (e: rel 'I_n) (f : 'I_n -> 'I_n) (x : 'I_n). 112 | 113 | Definition sseq e x := [seq y <- ord_enum_eq | e x y]. 114 | 115 | Let eq_sseq e : e =2 grel (sseq e). 116 | Proof. 117 | by move=> x y /=; rewrite mem_filter eq_ord_enum mem_ord_enum andbT. 118 | Qed. 119 | 120 | Definition n_comp_ord e (s : seq 'I_n) := n_comp_dfs (sseq e) n s. 121 | 122 | Lemma n_compEord_seq e (s : seq 'I_n) (a : {pred 'I_n}) : 123 | connect_sym e -> closed e a -> s =i a -> n_comp e a = n_comp_ord e s. 124 | Proof. 125 | move=> sym_e cl_a eq_a_s; rewrite -(eq_n_comp_r eq_a_s). 126 | rewrite (eq_n_comp (eq_connect (eq_sseq e))). 127 | apply: n_comp_dfsP; rewrite ?card_ord //. 128 | exact: eq_connect_sym sym_e. 129 | by rewrite -(eq_closed (eq_sseq e)) (eq_closed_r eq_a_s). 130 | Qed. 131 | 132 | Definition order_ord f x := size (undup (traject f x n)). 133 | 134 | Lemma orderEord f x : order f x = order_ord f x. 135 | Abort. 136 | 137 | Definition orbit_ord f x := traject f x (order_ord f x). 138 | 139 | Lemma orbitEord f x : orbit f x = orbit_ord f x. 140 | (* Proof. by rewrite /orbit_ord -orderEord. Qed. *) 141 | Abort. 142 | 143 | Definition connect_ord (e : rel 'I_n) x y := y \in dfs (sseq e) n [::] x. 144 | 145 | Lemma connectEord (e : rel 'I_n) : connect e =2 connect_ord e. 146 | Proof. 147 | move => x y; rewrite (eq_connect (eq_sseq e)); apply: connectEdfs. 148 | by rewrite card_ord. 149 | Qed. 150 | 151 | Definition fcard_ord f := n_comp_dfs (fun x => [:: f x]) n ord_enum_eq. 152 | 153 | Lemma n_compEord e : 154 | connect_sym e -> n_comp e 'I_n = n_comp_ord e (ord_enum_eq). 155 | Proof. move=> sym_s; exact: n_compEord_seq ord_enum_eqT. Qed. 156 | 157 | (** we don't use [n_compEord_seq], because doing so would require 158 | proving extensionality of [dfs] and the SCC algorithm *) 159 | Lemma fcardEord f : injective f -> fcard f 'I_n = fcard_ord f. 160 | Proof. 161 | have eq_f : frel f =2 grel (fun x => [:: f x]). 162 | by move => u v; rewrite /= !inE eq_sym. 163 | move=> inj_f; rewrite (eq_n_comp (eq_connect eq_f)). 164 | rewrite -(eq_n_comp_r ord_enum_eqT). 165 | rewrite (n_comp_dfsP (k := n)) ?card_ord //. 166 | - apply: eq_connect_sym eq_f _. exact: fconnect_sym. 167 | - move => x y. by rewrite !ord_enum_eqT. 168 | Qed. 169 | 170 | End ComputeOrd. 171 | 172 | Section D4. 173 | 174 | Definition n := 12. 175 | Notation "''d' m" := (@Ordinal n m is_true_true) (at level 0, m at level 8, format "''d' m"). 176 | 177 | Definition D4_edge (x : 'I_n) : 'I_n := 178 | match val x with 179 | | 0 => 'd4 180 | | 1 => 'd7 181 | | 2 => 'd10 182 | | 3 => 'd8 183 | | 4 => 'd0 184 | | 5 => 'd9 185 | | 6 => 'd11 186 | | 7 => 'd1 187 | | 8 => 'd3 188 | | 9 => 'd5 189 | | 10 => 'd2 190 | | 11 => 'd6 191 | | _ => 'd0 192 | end. 193 | 194 | Definition D4_node (x : 'I_n) : 'I_n := 195 | match val x with 196 | | 0 => 'd1 197 | | 1 => 'd2 198 | | 2 => 'd0 199 | | 3 => 'd4 200 | | 4 => 'd5 201 | | 5 => 'd3 202 | | 6 => 'd7 203 | | 7 => 'd8 204 | | 8 => 'd6 205 | | 9 => 'd10 206 | | 10 => 'd11 207 | | 11 => 'd9 208 | | _ => 'd0 209 | end. 210 | 211 | Definition D4_face (x : 'I_n) : 'I_n := 212 | match val x with 213 | | 0 => 'd3 214 | | 1 => 'd6 215 | | 2 => 'd9 216 | | 3 => 'd7 217 | | 4 => 'd2 218 | | 5 => 'd11 219 | | 6 => 'd10 220 | | 7 => 'd0 221 | | 8 => 'd5 222 | | 9 => 'd4 223 | | 10 => 'd1 224 | | 11 => 'd8 225 | | _ => 'd0 226 | end. 227 | 228 | 229 | Lemma D4can : cancel3 D4_edge D4_node D4_face. 230 | Proof. 231 | move=>x; apply/eqP; move: x; apply/forallP. 232 | by rewrite forall_all_ord. 233 | Qed. 234 | 235 | Definition D4 := Hypermap D4can. 236 | 237 | Lemma D4_planar : planar D4. 238 | Proof. 239 | rewrite /planar/genus/Euler_lhs/Euler_rhs. 240 | rewrite (n_compEord (@glinkC D4)) (fcardEord (@faceI D4)). 241 | by rewrite (fcardEord (@edgeI D4)) (fcardEord (@nodeI D4)) card_ord. 242 | Qed. 243 | 244 | Lemma D4_plain : plain D4. 245 | Proof. 246 | apply/plainP => x _; rewrite (rwP eqP) (rwP andP); move: x. 247 | by apply/forallP; rewrite forall_all_ord. 248 | Qed. 249 | 250 | Definition D4_g (x : D4) : 'K_4 := 251 | match val x with 252 | | 0 => ord0 253 | | 1 => ord0 254 | | 2 => ord0 255 | | 3 => ord1 256 | | 4 => ord1 257 | | 5 => ord1 258 | | 6 => ord2 259 | | 7 => ord2 260 | | 8 => ord2 261 | | 9 => ord3 262 | | 10 => ord3 263 | | 11 => ord3 264 | | _ => ord0 265 | end. 266 | 267 | 268 | Lemma D4_embedding : embedding D4_g. 269 | Proof. 270 | split; first exact D4_plain. 271 | - move=> x. apply/codomP. setoid_rewrite (rwP eqP). apply/existsP; rewrite exists_has_ord. 272 | move: x. apply/forallP. rewrite forall_all_ord. reflexivity. 273 | - move => x y. rewrite connectEord (rwP eqP). 274 | move: y; apply/forallP; rewrite forall_all_ord. 275 | move: x; apply/forallP; rewrite forall_all_ord. reflexivity. 276 | - move => x y. rewrite /adjn; under eq_existsb => z do rewrite !inE !connectEord. 277 | rewrite exists_has_ord (rwP eqP). 278 | move: y; apply/forallP; rewrite forall_all_ord. 279 | move: x; apply/forallP; rewrite forall_all_ord. reflexivity. 280 | Qed. 281 | 282 | Definition K4_plane_emb := Build_plane_embedding D4_embedding D4_planar. 283 | 284 | End D4. 285 | 286 | (** Any subgraph of K4 is planar as well *) 287 | Lemma small_planar (G : sgraph) : 288 | #|G| <= 4 -> no_isolated G -> inhabited (plane_embedding G). 289 | Proof. 290 | move=> smallG no_isoG. 291 | exact: subgraph_plane_embedding (sub_Kn smallG) no_isoG K4_plane_emb. 292 | Qed. 293 | 294 | 295 | 296 | -------------------------------------------------------------------------------- /theories/planar/Make: -------------------------------------------------------------------------------- 1 | -arg -w -arg -notation-overridden 2 | -arg -w -arg -redundant-canonical-projection 3 | -arg -w -arg -projection-no-head-constant 4 | -arg -w -arg -duplicate-clear 5 | -arg -w -arg -elpi.add-const-for-axiom-or-sectionvar 6 | -arg -w -arg -ambiguous-paths 7 | 8 | -Q . GraphTheory.planar 9 | 10 | hmap_ops.v 11 | hcycle.v 12 | embedding.v 13 | K4plane.v 14 | wagner.v 15 | -------------------------------------------------------------------------------- /theories/planar/Makefile: -------------------------------------------------------------------------------- 1 | # -*- Makefile -*- 2 | 3 | # setting variables 4 | COQPROJECT?=Make 5 | 6 | # Main Makefile 7 | include ../../Makefile.common 8 | -------------------------------------------------------------------------------- /theories/planar/dune: -------------------------------------------------------------------------------- 1 | (coq.theory 2 | (name GraphTheory.planar) 3 | (package coq-graph-theory-planar) 4 | (synopsis "Graph theory definitions and results on planarity in Coq and MathComp") 5 | (flags :standard 6 | -w -notation-overridden 7 | -w -redundant-canonical-projection 8 | -w -projection-no-head-constant 9 | -w -duplicate-clear 10 | -w -ambiguous-paths)) 11 | -------------------------------------------------------------------------------- /theories/planar/hcycle.v: -------------------------------------------------------------------------------- 1 | From mathcomp Require Import all_ssreflect. 2 | 3 | From GraphTheory Require Import edone preliminaries digraph sgraph. 4 | From fourcolor Require Import hypermap geometry jordan color coloring combinatorial4ct. 5 | From GraphTheory Require Import hmap_ops. 6 | 7 | Set Implicit Arguments. 8 | Unset Strict Implicit. 9 | Unset Printing Implicit Defensive. 10 | 11 | Definition kconnected_map (k : nat) (G : hypermap) := 12 | k < fcard node G /\ 13 | forall A : pred G, #|A| < k -> 14 | {in [predC fclosure node A]&, forall x y, connect (restrict [predC fclosure node A] glink) x y}. 15 | 16 | Lemma closed_connect (T : finType) (e : rel T) (A : pred T) : 17 | closed e A -> {in A, subrel (connect e) (connect (restrict A e))}. 18 | Proof. 19 | move => clA x xA y. 20 | case/connectP => p; elim: p x xA => [x _ _ -> //|z p IHp /= x xA /andP [xz pth_p] lst_p]. 21 | have zA: z \in A by rewrite -(clA _ _ xz). 22 | by apply: connect_trans (IHp _ zA pth_p lst_p); apply:connect1; rewrite /= xA zA. 23 | Qed. 24 | 25 | Lemma in_connect_sym (T : finType) (e : rel T) (A : pred T) : 26 | closed e A -> connect_sym e -> {in A&, connect_sym (restrict A e)}. 27 | Proof. 28 | move => clA sym_e x y xA yA. 29 | wlog suff : x y xA yA / connect (restrict A e) x y -> connect (restrict A e) y x. 30 | { by move => W; apply/idP/idP; apply: W. } 31 | case/connectP => p; elim: p x xA => /= [x _ _ -> //| z p IHp x xA]. 32 | rewrite -!andbA => /and4P [_ zA x_z pth_p lst_p]. 33 | have {pth_p lst_p} IH := IHp _ zA pth_p lst_p. apply: connect_trans IH _. 34 | have := (connect1 x_z); rewrite sym_e; exact: closed_connect. 35 | Qed. 36 | 37 | Lemma sub_restrict T (e1 e2 : rel T) (A : pred T) : 38 | {in A&, subrel e1 e2} -> subrel (restrict A e1) (restrict A e2). 39 | Proof. move => sub x y /=/andP[/andP [xA yA] xy]. by rewrite xA yA sub. Qed. 40 | 41 | Lemma glinkN (G : hypermap) : subrel (frel node) (@glink G). 42 | Proof. move => x y. by rewrite /glink /= => ->. Qed. 43 | 44 | Lemma sub_node_clink {G : hypermap} : subrel (frel (finv node)) (@clink G). 45 | Proof. move => x y /eqP <-. by rewrite /clink/= eqxx. Qed. 46 | 47 | Lemma in_clink_glink (G : hypermap) (A : pred G) (plainG : plain G) : 48 | fclosed node A -> {in A&, connect (restrict A clink) =2 connect (restrict A glink)}. 49 | Proof. 50 | move => clA x y xA yA. apply/idP/idP. 51 | - case/connectP => [p]. elim: p x xA => [x xA _ -> //|z p IHp x xA /=]. 52 | rewrite -!andbA => /and4P [_ zA xz pth_p lst_p]. 53 | apply: connect_trans (IHp _ zA pth_p lst_p) => {pth_p lst_p}. 54 | case/clinkP : xz xA zA => [->|<-] => xA zA. 55 | + apply: connect_mono. apply: sub_restrict. apply: in2W. exact: glinkN. 56 | rewrite in_connect_sym // ?connect1 //=. exact: cnodeC. 57 | + by apply connect1; rewrite /= xA zA /glink/= eqxx. 58 | - case/connectP => [p]. elim: p x xA => [x xA _ -> //|z p IHp x xA /=]. 59 | rewrite -!andbA => /and4P [_ zA xz pth_p lst_p]. 60 | apply: connect_trans (IHp _ zA pth_p lst_p) => {pth_p lst_p IHp}. 61 | gen have N,N': x z xA zA {xz} / node x == z -> connect (restrict A clink) x z. 62 | { move/eqP => E. rewrite -{}E in zA *. 63 | apply: connect_mono. apply: sub_restrict. apply: in2W. exact: sub_node_clink. 64 | rewrite in_connect_sym // ?connect1 //= ?xA ?zA ?finv_f ?eqxx //. 65 | * move => u v /eqP <-. by rewrite (clA (finv node u) u) //= f_finv. 66 | * by apply/fconnect_sym/finv_inj. } 67 | gen have F,F': x z xA zA {xz N N'} / face x == z -> connect (restrict A clink) x z. 68 | { move/eqP => E; rewrite -{}E in zA *. by apply: connect1; rewrite /= xA zA clinkF. } 69 | case/or3P : xz => //= {N' F'}. 70 | rewrite -plain_eq' => // /eqP => E; rewrite -{}E in zA *. 71 | have ? : face x \in A by rewrite (clA (face x) (node (face x))) //=. 72 | apply: connect_trans (N (face x) _ _ _ _) => //. exact: F. 73 | Qed. 74 | 75 | Definition avoid_one (G : hypermap) := 76 | forall z x y : G , ~~ cnode z x -> ~~ cnode z y -> connect (restrict [predC cnode z] clink) x y. 77 | 78 | Lemma two_connected_avoid (G : hypermap) (plainG : plain G) : 79 | kconnected_map 2 G -> avoid_one G. 80 | Proof. 81 | case => _ tcG z x y Hx Hy. 82 | have:= tcG (pred1 z) _; rewrite card1 => /(_ isT) {tcG} tcG. 83 | have Nz : cnode z =i fclosure node (pred1 z) by apply/closure1/cnodeC. 84 | have PNz : [predC cnode z] =i [predC fclosure node (pred1 z)]. 85 | { by move => u; rewrite inE /= Nz. } 86 | rewrite in_clink_glink //; last exact/predC_closed/connect_closed/cnodeC. 87 | apply: connect_restrict_mono (tcG x y _ _); rewrite -?PNz //. 88 | apply/subsetP => u. by rewrite -PNz. 89 | Qed. 90 | 91 | Definition drestrict (G : diGraph) (A : pred G) := DiGraph (restrict A (--)). 92 | 93 | Lemma upathPR (G : diGraph) (x y : G) A : 94 | reflect (exists p : seq G, @upath (drestrict A) x y p) 95 | (connect (restrict A (--)) x y). 96 | Proof. exact: (@upathP (drestrict A)). Qed. 97 | 98 | Lemma upath_rconsE (G: diGraph) (x y : G) p : x != y -> 99 | upath x y p -> path (--) x (rcons (behead (belast x p)) y) /\ uniq (rcons (belast x p) y). 100 | Proof. 101 | rewrite /upath/pathp; elim/last_ind : p x y => [x y /negbTE-> //|p z ? x y ?]. 102 | rewrite !belast_rcons last_rcons /= -andbA => /and4P [H1 H2 H3 /eqP<-]. 103 | by rewrite H1 H2 H3. 104 | Qed. 105 | 106 | Lemma drestrict_upath (G : diGraph) (x y : G) (A : pred G) (p : seq G) : 107 | @upath (@drestrict G A) x y p -> @upath G x y p. 108 | Proof. 109 | elim: p x => // z p IH x /upath_consE [/= /andP [_ u1] u2 u3]. 110 | rewrite upath_cons u1 u2 /=. exact: IH. 111 | Qed. 112 | 113 | (* TODO: 114 | - clean up digraph/sgraph connect/path lemmas 115 | - provide link between [p : Path x y] and [path e x (rcons q y)] *) 116 | Lemma connect_inE (T : finType) (e : rel T) (A : pred T) (x y : T) : 117 | x != y -> connect (restrict A e) x y -> 118 | (exists p, [/\ path e x (rcons p y), uniq (x::rcons p y) & {subset x::rcons p y <= A}]). 119 | Proof. 120 | move => xDy. case/(@upathPR (DiGraph e)) => p U. 121 | move/upath_rconsE : (drestrict_upath U) => -/(_ xDy) [P1 P2]. 122 | have E : last x p = y by case/andP : U => _; apply: pathp_last. 123 | rewrite -E -lastI in P2. 124 | exists (behead (belast x p)); split => //. 125 | - suff -> : rcons (behead (belast x p)) y = p by []. 126 | destruct p; rewrite -?E -?lastI //=. by rewrite -E /= eqxx in xDy. 127 | - move/upath_rconsE : (U) => /(_ xDy) => -[P _]. 128 | apply/cons_subset; split; last exact: rpath_sub P. 129 | destruct p; simpl in *. by rewrite E eqxx in xDy. 130 | case/upath_consE : U => /=. by rewrite /edge_rel/=; case: (x \in A). 131 | Qed. 132 | 133 | Lemma sub_face_clink { G : hypermap } : @subrel G (frel face) clink. 134 | Proof. by move => u v /eqP ?; apply/clinkP; right. Qed. 135 | 136 | Lemma path_take_nth (T : eqType) (e : rel T) x s n : 137 | n < size s -> path e x s -> e (last x (take n s)) (nth x s n). 138 | Proof. 139 | elim: s x n => // a s IH x [|n] /=; first by case (e x a). 140 | rewrite ltnS => ? /andP [_ ?]; by rewrite (set_nth_default a x) ?IH. 141 | Qed. 142 | 143 | Lemma path_take (T : eqType) (e : rel T) x s n : 144 | path e x s -> path e x (take n s). 145 | Proof. by rewrite -{1}[s](cat_take_drop n) cat_path; case/andP. Qed. 146 | 147 | Lemma disjoint_subpath (T : finType) (A B : pred T) (e : rel T) x y (p : seq T) : 148 | x \in A -> y \in B -> path e x (rcons p y) -> [disjoint A & B] -> 149 | exists u v q, [/\ u \in A, v \in B, path e u (rcons q v), 150 | subseq (u:: rcons q v) (x:: rcons p y) & [disjoint q & [predU A & B]]]. 151 | Proof. 152 | have [m Hm] := ubnP (size p); elim: m x y p Hm => // n IH x y p p_n xA xB pth_p disAB. 153 | case: (boolP [disjoint p & [predU A & B]]) => [?|]; first by exists x; exists y; exists p. 154 | case/pred0Pn => z /andP[z_in_p z_in_AB]. 155 | case/splitP def_p : p _ _ / z_in_p pth_p p_n => [p1 p2]. 156 | rewrite rcons_cat cat_path last_rcons => /andP [pth_p1 pth_p2]. 157 | rewrite size_cat size_rcons addSn ltnS => size_p. 158 | have {z_in_AB} [z_in_A|z_in_B] := orP z_in_AB. 159 | - case:(IH z y p2) => //. apply: leq_ltn_trans size_p. exact: leq_addl. 160 | move => u [v] [q] [uA vB Q1 Q2 Q3]; exists u; exists v; exists q. split => //. 161 | apply: subseq_trans Q2 _. rewrite -(cats1 _ z) -catA cat1s -cat_cons. 162 | exact: suffix_subseq. 163 | - case:(IH x z p1) => //. apply: leq_ltn_trans size_p. exact: leq_addr. 164 | move => u [v] [q] [uA vB Q1 Q2 Q3]; exists u; exists v; exists q. split => //. 165 | apply: subseq_trans Q2 _. exact: prefix_subseq. 166 | Qed. 167 | 168 | Lemma last_belast (T : eqType) (x : T) (s : seq T) : 169 | uniq (x :: s) -> last x s \in belast x s = false. 170 | Proof. 171 | elim: s x => //= y s IH x /andP [Hx ?]. rewrite inE IH // orbF. 172 | apply: contraNF Hx => /eqP <-. exact: mem_last. 173 | Qed. 174 | 175 | Lemma last_head_behead (T : eqType) (x : T) (p : seq T) : last (head x p) (behead (rcons p x)) = x. 176 | Proof. case: p => //= ? ?. exact: last_rcons. Qed. 177 | 178 | Lemma last_memE (T : eqType) (x : T) (s : seq T) (a : pred T) : 179 | last x s \in a -> (x \in a) + { y | y \in s & y \in a}. 180 | Proof. 181 | elim/last_ind : s => [|s y _]; first by left. 182 | by rewrite last_rcons; right;exists y => //; rewrite mem_rcons mem_head. 183 | Qed. 184 | 185 | 186 | Lemma index_finv (T : finType) (f : T -> T) x : 187 | findex f x (finv f x) = (order f x).-1. 188 | Proof. by rewrite findex_iter // orderSpred. Qed. 189 | 190 | Lemma bar (T : finType) (f : T -> T) x : 191 | injective f -> findex f (f x) x = (order f (f x)).-1. 192 | Proof. move => inj_f. have := index_finv f (f x). by rewrite finv_f. Qed. 193 | 194 | (** Every face of a two connected loopless plain graph is bounded by a 195 | cycle. In the hypermap representation, this amounts to showing that 196 | distinct nodes on an f-cycle belong to different n-cycles *) 197 | (* TODO: simplify further (use [rot_to_arc] for f-cycle) *) 198 | Lemma two_connected_cyle (G : hypermap) : 199 | avoid_one G -> plain G -> loopless G -> planar G -> 200 | forall x y : G, x != y -> cface x y -> ~~ cnode x y. 201 | Proof. 202 | move => tcG plainG llG planarG x y xDy cf_xy; apply/negP => cn_xy. 203 | wlog [p [path_p uniq_p disj_p]] : x xDy cf_xy cn_xy / 204 | exists p, [/\ fpath (finv node) y (rcons p x), uniq p & [disjoint p & cface x]]. 205 | { move => W. 206 | pose o := orbit (finv node) y; pose a := cface x. 207 | have [o' def_o] : exists o', o = y :: o' by rewrite /o/orbit -orderSpred /=; eexists. 208 | have has_x : has a o'; first (apply/hasP; exists x; last exact: connect0). 209 | suff: x \in o by rewrite def_o inE (negPf xDy). 210 | by rewrite -fconnect_orbit same_fconnect_finv // cnodeC. 211 | case/split_find def_o' : _ _ _ / has_x => [x' p q a_x' hasNp]; subst o'. 212 | have: uniq o by apply: orbit_uniq. 213 | have: fcycle (finv node) o by apply/cycle_orbit/finv_inj. 214 | have cf_x'y: cface x' y by apply: connect_trans cf_xy; rewrite cfaceC. 215 | rewrite def_o /= rcons_path cat_path -!andbA => /andP [path_p _]. 216 | rewrite cat_uniq rcons_uniq -!andbA mem_cat mem_rcons inE !negb_or -!andbA eq_sym. 217 | move => /andP[? /and5P[_ _ _ uniq_p _]]; apply: (W x') => //. 218 | - rewrite cnodeC -same_fconnect_finv //; apply/connectP; exists (rcons p x') => //. 219 | by rewrite last_rcons. 220 | - exists p; split => //; rewrite disjoint_has // (eq_has (_ : cface x' =i cface x)) //. 221 | move=> z; rewrite !inE; apply: (same_connect cfaceC). 222 | by apply: connect_trans cf_x'y _; rewrite cfaceC. } 223 | (* Exibiting the f-cycle *) 224 | have := cycle_orbit faceI x; have := orbit_uniq face x. 225 | have : y \in orbit face x by rewrite -fconnect_orbit. 226 | case def_c : (orbit face x) => [//|x0 c]. 227 | move: (def_c). 228 | have {def_c} -> : x0 = x by move: def_c; rewrite /orbit -orderSpred; case. 229 | move => def_c y_in_c uniq_c cycle_c. 230 | rewrite inE eq_sym (negbTE xDy) /= in y_in_c. 231 | (* Splitting the f-cycle *) 232 | case/splitP def_c' : {1}c _ _ / y_in_c => [c1 c2]. 233 | move: uniq_c. rewrite def_c' /= cat_uniq has_sym has_rcons mem_cat mem_rcons rcons_uniq. 234 | rewrite !inE (negbTE xDy) !negb_or /= -disjoint_has -!andbA disjoint_sym. 235 | case/and5P => x_c1 x_c2 y_c1 uniq_c1 /and3P [y_c2 dis_c1_c2 uniq_c2]. 236 | move: path_p; rewrite rcons_path /= => /andP [path_p /eqP lst_p]. 237 | (* Obtain contour connecting [c1] and [c2] *) 238 | have [u [v] [q] [path_q u_c v_c uniq_q disj_q]]: 239 | exists u v q, [/\ path clink u (rcons q v), u \in c2, v \in c1, uniq q & [disjoint q & [predU cface x & p]]]. 240 | { have [u [u_c1 Hu]] : exists u, u \in c1 /\ ~~ cnode x u. { 241 | destruct c1 as [|a ?]; move: cycle_c cn_xy; rewrite def_c'. 242 | - case/andP => /eqP <- _. by rewrite (negbTE (loopless_face _ _ _)). 243 | - rewrite rcons_cons /= rcons_path => /and3P [/eqP<- _ _]. 244 | exists (face x). by rewrite mem_head loopless_face. } 245 | have [v [v_c2 Hv]] : exists v, v \in c2 /\ ~~ cnode x v. { 246 | elim/last_ind : c2 def_c' cycle_c cn_xy {x_c2 y_c2 dis_c1_c2 uniq_c2} => [|? a _] /= ->. 247 | - rewrite cats0 /= rcons_path last_rcons => /andP [_ /eqP <-]. 248 | by rewrite cnodeC (negbTE (loopless_face _ _ _)). 249 | - rewrite !(rcons_path,cat_path) /= -!andbA last_cat !last_rcons => /and5P [_ _ _ _ /eqP E ?]. 250 | exists (finv face x). by rewrite -E finv_f // mem_rcons mem_head cnodeC loopless_face. } 251 | have uDv : v != u. 252 | { apply: contraTneq dis_c1_c2 => ?; subst. by apply/pred0Pn; exists u. } 253 | have [q [pth_q uniq_q sub_q]] := @connect_inE _ _ _ _ _ uDv (tcG x v u Hv Hu). 254 | have [u0 [v0] [q0] [A B C D E]] := disjoint_subpath v_c2 u_c1 pth_q dis_c1_c2. 255 | exists u0; exists v0; exists q0; split => //. 256 | - apply: subseq_uniq uniq_q. apply: subseq_trans D. 257 | exact: subseq_trans (subseq_rcons _ _) (subseq_cons _ _). 258 | - move/mem_subseq in D. 259 | apply/disjointP => z in_q0; apply/negP; rewrite !inE negb_or fconnect_orbit def_c. 260 | have Nz k : cnode y k -> z != k. 261 | { move => Nyk. have:= connect_trans cn_xy Nyk. 262 | apply contraTneq => <-. by apply/sub_q/D; rewrite !(inE,mem_rcons) in_q0. } 263 | rewrite def_c' !(inE,mem_rcons,mem_cat) !negb_or !Nz 1?cnodeC //= -negb_or orbC. 264 | move: (disjointFr E in_q0); rewrite inE => -> /=. 265 | apply: contraTN (eqxx z) => z_p; apply/Nz. 266 | rewrite -same_fconnect_finv //. 267 | move/path_connect in path_p. by apply/path_p; rewrite !inE z_p. } 268 | case/splitP def_c2 : {1}c2 _ _ / (u_c) => [c21 c22]. 269 | pose mp := rcons p x ++ rcons c1 y ++ rcons c21 u ++ q. 270 | suff: Moebius_path mp by apply/negP; exact: planarP. 271 | move: path_q; rewrite rcons_path => /andP [path_q lst_q]. 272 | have/andP [dis_q_f dis_q_p] : [disjoint q & (x::c)] && [disjoint p & q]. 273 | { move: disj_q. rewrite disjoint_sym disjointU => /andP [A ->]; rewrite andbT disjoint_sym. 274 | by apply: disjointWl A; apply/subsetP => ?; rewrite -def_c -fconnect_orbit. } 275 | rewrite /mp headI /Moebius_path -{2}headI /=. 276 | apply/and3P; split. 277 | - suff: uniq (rcons p x ++ c ++ q). 278 | { apply: subseq_uniq. apply: cat_subseq => //. rewrite catA. apply: cat_subseq => //. 279 | rewrite def_c' def_c2. apply: cat_subseq => //. exact: prefix_subseq. } 280 | rewrite -cats1 -catA [[:: x] ++ _ ++ _]catA cat1s -def_c. 281 | rewrite cat_uniq has_cat negb_or -!disjoint_has uniq_p /=. 282 | rewrite ![[disjoint _ & p]]disjoint_sym dis_q_p (disjointWr _ disj_p). 283 | 2: by apply/subsetP => z; rewrite -fconnect_orbit. 284 | rewrite cat_uniq orbit_uniq -disjoint_has disjoint_sym uniq_q /= andbT. 285 | by rewrite disjoint_sym def_c. 286 | - rewrite !catA cat_path !last_cat last_rcons path_q andbT -catA. 287 | rewrite cat_path last_head_behead (_ : path _ _ _) /=. 288 | + move/(sub_path sub_face_clink) : cycle_c. 289 | by rewrite def_c' def_c2 !rcons_cat catA [in X in X -> _]cat_path => /andP [-> _]. 290 | + move/(sub_path sub_node_clink): path_p lst_p. destruct p as [|z p] => //= /andP [A B] <-. 291 | by rewrite rcons_path B -{1}[last z p](f_finv nodeI) clinkN. 292 | - rewrite 3!last_cat last_rcons. 293 | have -> : node (head x p) = y. 294 | { move: path_p lst_p. destruct p as [|z p]=> /= [_ <-|/andP[/eqP <- _] _]; exact: f_finv. } 295 | suff -> : finv node (last u q) = v. 296 | { by rewrite !mem2_cat (_ : mem2 (rcons c1 y) v y) // -cats1 mem2_cat v_c !inE eqxx. } 297 | case/clinkP: lst_q => [->|def_v]; first by rewrite ?finv_f. 298 | case: notF. (* the last step of [u::rcons q v] cannot be an f-step *) 299 | have: finv face v \in x::c1. 300 | { have : fpath face x c1. 301 | { move: cycle_c. rewrite def_c' -cat1s catA /= rcons_cat cat_path rcons_path. by case: (fpath _ _ c1). } 302 | case/splitP : v_c => [p1 p2 _]. rewrite cat_path !rcons_path last_rcons -andbA /=. 303 | case/and3P => _ /eqP <- _. by rewrite finv_f // -cats1 -catA /= -cat_cons mem_cat mem_last. } 304 | rewrite -{}def_v finv_f //. case/last_memE => [|[z Z1]]. 305 | + rewrite inE (disjointFr dis_c1_c2) // orbF => E. by rewrite -(eqP E) u_c in x_c2. 306 | + rewrite inE; case/predU1P => [?|H]. 307 | * subst z. by rewrite (disjointFl dis_q_f) // mem_head in Z1. 308 | * by rewrite (disjointFl dis_q_f) // def_c' !(inE,mem_rcons,mem_cat) H in Z1. 309 | Qed. 310 | 311 | --------------------------------------------------------------------------------