├── CONTRIBUTORS.md ├── .gitignore ├── Makefile ├── _CoqProject ├── LICENSE ├── dependency-graph.sh ├── .github └── workflows │ └── ci.yml ├── coq-eventstruct.opam ├── theories ├── common │ ├── ilia.v │ ├── wftype.v │ ├── fperm.v │ ├── monoid.v │ ├── inhtype.v │ ├── rewriting_system.v │ ├── order.v │ ├── rel_algebra.v │ ├── rel.v │ ├── ident.v │ └── seq.v ├── lang │ ├── sharedmem.v │ ├── regmachine.v │ └── relaxed.v └── concur │ └── transitionsystem.v ├── README.md └── Styleguide.md /CONTRIBUTORS.md: -------------------------------------------------------------------------------- 1 | * [Vladimir Gladstein](https://github.com/volodeyka) 2 | * [Dmitrii Mikhailovskii](https://github.com/dmitromikh) 3 | * [Evgenii Moiseenko](https://github.com/eupp) 4 | * [Anton Trunov](https://github.com/anton-trunov) -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | CoqMakefile 2 | CoqMakefile.conf 3 | .CoqMakefile.d 4 | *.v.d 5 | *.vo 6 | *.vos 7 | *.vok 8 | .coqdeps.d 9 | *.aux 10 | *.glob 11 | *.cache 12 | *.json 13 | #*# 14 | dependency_graph.dot 15 | dependency_graph.png 16 | 17 | # tex/papers 18 | 19 | *.pdf 20 | *.log 21 | *.out 22 | *.fls 23 | *.*latexmk 24 | *.bbl 25 | *.blg 26 | *.*.gz 27 | *.tex.bak 28 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | # KNOWNTARGETS will not be passed along to CoqMakefile 2 | KNOWNTARGETS := CoqMakefile 3 | # KNOWNFILES will not get implicit targets from the final rule, and so depending on them won’t invoke the submake 4 | # Warning: These files get declared as PHONY, so any targets depending on them always get rebuilt 5 | KNOWNFILES := Makefile _CoqProject 6 | 7 | .DEFAULT_GOAL := invoke-coqmakefile 8 | 9 | CoqMakefile: Makefile _CoqProject 10 | $(COQBIN)coq_makefile -f _CoqProject -o CoqMakefile 11 | 12 | invoke-coqmakefile: CoqMakefile 13 | $(MAKE) --no-print-directory -f CoqMakefile $(filter-out $(KNOWNTARGETS),$(MAKECMDGOALS)) 14 | 15 | .PHONY: invoke-coqmakefile $(KNOWNFILES) 16 | 17 | # This should be the last rule, to handle any targets not declared above 18 | %: invoke-coqmakefile 19 | @true 20 | -------------------------------------------------------------------------------- /_CoqProject: -------------------------------------------------------------------------------- 1 | -R theories eventstruct 2 | 3 | -arg -w -arg -notation-overridden 4 | -arg -w -arg -non-reversible-notation 5 | -arg -w -arg -duplicate-clear 6 | -arg -w -arg -redundant-canonical-projection 7 | -arg -w -arg -notation-incompatible-format 8 | -arg -w -arg -ssr-search-moved 9 | -arg -w -arg -deprecated-ssr-search 10 | -arg -w -arg -ambiguous-paths 11 | 12 | theories/common/utils.v 13 | theories/common/seq.v 14 | theories/common/fperm.v 15 | theories/common/rel_algebra.v 16 | theories/common/wftype.v 17 | theories/common/inhtype.v 18 | theories/common/ident.v 19 | theories/common/ilia.v 20 | theories/common/rewriting_system.v 21 | theories/common/rel.v 22 | theories/common/order.v 23 | theories/common/monoid.v 24 | 25 | theories/concur/lts.v 26 | theories/concur/lposet.v 27 | theories/concur/pomset.v 28 | theories/concur/pomset_lts.v 29 | theories/concur/prime_eventstruct.v 30 | theories/concur/porf_eventstruct.v 31 | theories/concur/transitionsystem.v 32 | 33 | theories/lang/relaxed.v 34 | theories/lang/sharedmem.v 35 | theories/lang/regmachine.v 36 | 37 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2020 JetBrains Research and contributors. 2 | 3 | Permission is hereby granted, free of charge, to any person obtaining a copy 4 | of this software and associated documentation files (the "Software"), to deal 5 | in the Software without restriction, including without limitation the rights 6 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 7 | copies of the Software, and to permit persons to whom the Software is 8 | furnished to do so, subject to the following conditions: 9 | 10 | The above copyright notice and this permission notice shall be included in all 11 | copies or substantial portions of the Software. 12 | 13 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 14 | EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF 15 | MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. 16 | IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, 17 | DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR 18 | OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE 19 | OR OTHER DEALINGS IN THE SOFTWARE. -------------------------------------------------------------------------------- /dependency-graph.sh: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | 3 | # The source code of this script was adapted from the snippet by Guillaume Melquiond: 4 | # https://coq.discourse.group/t/tool-for-drawing-coq-project-dependency-graph/653/16 5 | # 6 | # This script generates a dependency graph file for the project. 7 | # This is done via the following chain of transformations: 8 | # coqdep dot 9 | # _CoqProject (and .v files) ----------> .dot file ----------> .png file 10 | # 11 | # - `coqdep` is a standard utility distributed with Coq system 12 | # - `dot` utility is distributed with `graphviz` utility collection 13 | # One can usually install it using a package manager like homebrew on macOS: 14 | # `brew install graphviz` 15 | 16 | project_file=_CoqProject 17 | name=dependency_graph 18 | 19 | ( echo "digraph interval_deps {" ; 20 | echo "node [shape=ellipse, style=filled, color=black];"; 21 | ( coqdep -f ${project_file} ) | 22 | sed -n -e 's,/,.,g;s/[.]vo.*: [^ ]*[.]v//p' | 23 | while read src dst; do 24 | color=$(echo "$src" | sed -e 's,[a-zA-Z].*,white,') 25 | echo "\"$src\" [fillcolor=$color];" 26 | for d in $dst; do 27 | echo "\"$src\" -> \"${d%.vo}\" ;" 28 | done 29 | done; 30 | echo "}" ) | tred > ${name}.dot 31 | 32 | dot -Gdpi=300 -T png ${name}.dot -o ${name}.png 33 | 34 | # to generate pdf file simply do 35 | # dot -T pdf ${dot_file} -o ${name}.pdf 36 | -------------------------------------------------------------------------------- /.github/workflows/ci.yml: -------------------------------------------------------------------------------- 1 | # This is based on the workflow example from https://github.com/erikmd/docker-coq-github-action-demo 2 | 3 | name: CI 4 | 5 | # Controls when the action will run: 6 | # https://help.github.com/en/actions/configuring-and-managing-workflows/configuring-a-workflow#filtering-for-specific-branches-tags-and-paths 7 | # Triggers the workflow on push events for the master branch only, 8 | # or all pull request events: 9 | on: 10 | push: 11 | branches: 12 | - master 13 | - dev 14 | pull_request: 15 | branches: 16 | - '**' 17 | 18 | # A workflow run is made up of one or more jobs that can run sequentially or in parallel 19 | # This workflow contains two jobs, build and mathcomp: 20 | jobs: 21 | # The type of runner that the job will run on; 22 | # the OS must be GNU/Linux to be able to use the docker-coq-action 23 | build: 24 | runs-on: ubuntu-latest 25 | strategy: 26 | matrix: 27 | image: 28 | - mathcomp/mathcomp:1.14.0-coq-8.14 29 | - mathcomp/mathcomp:1.13.0-coq-8.14 30 | - mathcomp/mathcomp:1.13.0-coq-8.13 31 | - mathcomp/mathcomp-dev:coq-8.14 32 | - mathcomp/mathcomp-dev:coq-dev 33 | max-parallel: 4 34 | fail-fast: false 35 | steps: 36 | - uses: actions/checkout@v2 37 | - uses: coq-community/docker-coq-action@v1 38 | with: 39 | opam_file: './coq-eventstruct.opam' 40 | custom_image: ${{ matrix.image }} 41 | 42 | -------------------------------------------------------------------------------- /coq-eventstruct.opam: -------------------------------------------------------------------------------- 1 | opam-version: "2.0" 2 | maintainer: "Vladimir Gladstein " 3 | version: "dev" 4 | 5 | homepage: "https://github.com/event-structures/event-struct" 6 | dev-repo: "git+https://github.com/event-structures/event-struct.git" 7 | bug-reports: "https://github.com/event-structures/event-struct/issues" 8 | doc: "https://event-structures.github.io/event-struct/" 9 | license: "MIT" 10 | 11 | synopsis: "Formalization of event structures in Coq" 12 | description: """ 13 | A Coq library of formalized theory of event structures with applications to 14 | concurrency semantics. Includes a theory of prime event structures and 15 | operational small-step semantics for their incremental construction. 16 | """ 17 | 18 | build: [make "-j%{jobs}%" ] 19 | install: [make "install"] 20 | depends: [ 21 | "coq" {(>= "8.13" & < "8.15~") | (= "dev")} 22 | "coq-mathcomp-ssreflect" {(>= "1.13.0" & < "1.15.0~") | (= "dev")} 23 | "coq-mathcomp-finmap" {(>= "1.5.1") | (= "dev")} 24 | "coq-mathcomp-tarjan" {(= "dev")} 25 | "coq-mathcomp-zify" {(>= "1.0.0") | (= "dev")} 26 | "coq-relation-algebra" {(>= "1.7.4") | (= "dev")} 27 | "coq-equations" {(>= "1.2") | (= "dev")} 28 | ] 29 | # we pin dev version, because 1.0.0 and dev 30 | # use different module names (Kosaraju.v vs kosaraju.v) 31 | pin-depends: [ 32 | [ "coq-mathcomp-tarjan.dev" "git+https://github.com/math-comp/tarjan/"] 33 | ] 34 | conflicts: [ 35 | "coq-equations" {(= "dev+HoTT")} 36 | ] 37 | tags: [ 38 | "keyword:concurrency" 39 | "keyword:event structures" 40 | "keyword:weak memory models" 41 | "keyword:operational semantics" 42 | "category:Computer Science/Concurrency/Weak Memory Models" 43 | "logpath:eventstruct" 44 | ] 45 | authors: [ 46 | "Vladimir Gladstein " 47 | "Dmitrii Mikhailovskii " 48 | "Evgenii Moiseenko " 49 | "Anton Trunov " 50 | ] 51 | -------------------------------------------------------------------------------- /theories/common/ilia.v: -------------------------------------------------------------------------------- 1 | From mathcomp Require Import ssreflect ssrfun ssrbool ssrnat seq path. 2 | From mathcomp Require Import finmap choice eqtype order zify. 3 | From eventstruct Require Import utils order wftype ident. 4 | 5 | Open Scope ident_scope. 6 | 7 | Lemma ecnode_prop_eq {E : identType} (x y : E) : 8 | x = y <-> encode x = encode y. 9 | Proof. by split=> [-> //|/encode_inj->]. Qed. 10 | 11 | Ltac encode_indets := 12 | multimatch goal with 13 | | E : identType |- context [@eq_op ?E ?x ?y ] => 14 | lazymatch type of x with 15 | | nat => fail 16 | | _ => rewrite -[x == y](inj_eq encode_inj) 17 | end 18 | | E : identType |- (@eq ?E ?x _) => 19 | lazymatch type of x with 20 | | nat => fail 21 | | _ => try apply/encode_inj 22 | end 23 | | E : identType |- context [@eq ?E ?x ?y] => 24 | lazymatch type of x with 25 | | nat => fail 26 | | _ => rewrite [x = y]ecnode_prop_eq 27 | end 28 | | E : identType, e := _ |- _ => 29 | lazymatch type of e with 30 | | ?E => rewrite ?/e 31 | end 32 | end. 33 | 34 | Lemma le_identE {E : identType} (e1 e2 : E) : 35 | e1 <=^i e2 = (encode e1 <= encode e2). 36 | Proof. by []. Qed. 37 | 38 | Lemma lt_identE {E : identType} (e1 e2 : E) : 39 | e1 <^i e2 = (encode e1 < encode e2). 40 | Proof. by []. Qed. 41 | 42 | Open Scope type_scope. 43 | 44 | Definition identE {E : identType} := 45 | (@encode0 E, @encode1 E, @encode_fresh E, @encode_iter E, 46 | @in_nfresh E, @le_identE E, @lt_identE E). 47 | 48 | Ltac push_ident_context := ( 49 | match goal with 50 | | H : context [ encode \i0 ] |- _ => move: H; try clear H 51 | | H : context [ encode \i1 ] |- _ => move: H; try clear H 52 | | H : context [ encode (fresh _) ] |- _ => move: H; try clear H 53 | | H : context [ encode (iter _ fresh _) ] |- _ => move: H; try clear H 54 | | H : context [ _ \in nfresh _ _ ] |- _ => move: H; try clear H 55 | | H : context [ _ <=^i _ ] |- _ => move: H; try clear H 56 | | H : context [ _ <^i _ ] |- _ => move: H; try clear H 57 | | E : identType, H : context [@eq_op ?E ?x _] |- _ => move: H; try clear H 58 | | E : identType, H : context [@eq ?E ?x _] |- _ => move: H; try clear H 59 | end). 60 | 61 | Ltac encodify := (repeat progress push_ident_context); (repeat progress encode_indets); rewrite ?identE //=. 62 | 63 | Ltac ilia := encodify; lia. -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # Mechanized Theory of Event Structures 2 | 3 | ![GitHub Actions][github-actions-badge] 4 | 5 | [github-actions-badge]: https://github.com/event-structures/event-struct/workflows/CI/badge.svg 6 | 7 | A Coq library with the formalized theory of event structures and non-interleaving concurrency. 8 | Currently includes a theory of the following semantic domains and their relationships: 9 | 10 | - labelled transition systems 11 | - pomset languages 12 | - prime event structures 13 | 14 | Also features several applications of the theory. 15 | 16 | - Formalization of several basic consistency models 17 | parametrized by the abstract datatype, defined according to the paper 18 | ["Causal Consistency: Beyond Memory" by Matthieu Perrin, Achour Mostefaoui, Claude Jard (PPoPP 2016)](https://core.ac.uk/download/pdf/52993336.pdf) 19 | 20 | - Incremental construction of prime event structures 21 | build from program-order and reads-from relations. 22 | 23 | The library is under active development. 24 | Therefore the API is unstable and might be subject to further modifications. 25 | 26 | ## Description of Files 27 | 28 | For a more detailed description, see the documentation in the headers of source files. 29 | 30 | - `common` - common definitions, lemmas, and notations 31 | 32 | - `utils.v` - miscellaneous 33 | - `seq.v` - various additions to seq theory from mathcomp 34 | - `rel.v` - additional facts about decidable binary relations 35 | - `rel_algebra.v` - variuos additions to relation-algebra package 36 | - `order.v` - various additions to porder theory from mathcomp 37 | - `wftype.v` - interface for types with well-founded partial order 38 | - `inhtype.v` - interface for inhabited type, that is a type with one distinguished inhabitant 39 | - `ident.v` - interface for types that can be used as identifiers 40 | - `monoid.v` - theory of monoids and partial monoids 41 | - `rewriting_system.v` - a piece of rewriting systems theory 42 | 43 | - `concur` - semantic domains for concurrency 44 | 45 | - `lts.v` - labelled transition systems and (linear) traces 46 | - `lposet.v` - labelled partially ordered sets 47 | - `pomset.v` - pomsets as quotient types 48 | - `pomset_lts.v` - a connection between pomset languages and labelled transition systems 49 | - `prime_eventstruct.v` - prime event structures 50 | - `porf_eventstruct.v` - prime event structure built from program-order and reads-from relations 51 | - `transitionsystem.v` - incremental construction of event structure 52 | 53 | - `lang` - syntax and semantics of concurrent languages and systems 54 | 55 | - `relaxed.v` - relaxed memory models parametrized by an abstract datatype 56 | - `sharedmem.v` - shared memory abstract datatype 57 | - `regmachine.v` - simple parallel register machine with shared memory 58 | -------------------------------------------------------------------------------- /theories/common/wftype.v: -------------------------------------------------------------------------------- 1 | From mathcomp Require Import ssreflect ssrfun ssrbool ssrnat. 2 | From mathcomp Require Import eqtype choice order. 3 | Require Import Equations.Prop.Loader. 4 | 5 | (******************************************************************************) 6 | (* This file contains the definitions of: *) 7 | (* wfType d == the structure for types with *) 8 | (* well-founded partial order. *) 9 | (* well_founded_bool r <-> r is a decidable well-founded relation. *) 10 | (* wfb <-> wfType's order relation is well-founded. *) 11 | (* wfb_ind <-> well-founded induction principle for wfType. *) 12 | (* This file also contains canonical instance of wfType for nat. *) 13 | (******************************************************************************) 14 | 15 | Set Implicit Arguments. 16 | Unset Strict Implicit. 17 | Unset Printing Implicit Defensive. 18 | 19 | Section WfBool. 20 | 21 | Context {T : Type} (r : rel T). 22 | 23 | Inductive acc_bool (x : T) := 24 | acc_bool_intro of (forall y : T, r y x -> acc_bool y). 25 | 26 | Definition well_founded_bool := forall x, acc_bool x. 27 | 28 | End WfBool. 29 | 30 | Open Scope order_scope. 31 | 32 | Module WellFounded. 33 | 34 | Section ClassDef. 35 | 36 | Record mixin_of T0 (b : Order.POrder.class_of T0) 37 | (T := Order.POrder.Pack tt b) := Mixin { 38 | _ : well_founded_bool (<%O : rel T); 39 | }. 40 | 41 | Set Primitive Projections. 42 | 43 | Record class_of (T : Type) := Class { 44 | base : Order.POrder.class_of T; 45 | mixin : mixin_of base; 46 | }. 47 | 48 | Unset Primitive Projections. 49 | 50 | Local Coercion base : class_of >-> Order.POrder.class_of. 51 | 52 | Structure type (disp : unit) := Pack { sort; _ : class_of sort }. 53 | 54 | Local Coercion sort : type >-> Sortclass. 55 | 56 | Variables (T : Type) (disp : unit) (cT : type disp). 57 | 58 | Definition class := let: Pack _ c as cT' := cT return class_of cT' in c. 59 | Definition clone c of phant_id class c := @Pack disp T c. 60 | 61 | Definition pack := 62 | fun bT b & phant_id (@Order.POrder.class disp bT) b => 63 | fun m => Pack disp (@Class T b m). 64 | 65 | Definition eqType := @Equality.Pack cT class. 66 | Definition choiceType := @Choice.Pack cT class. 67 | Definition porderType := @Order.POrder.Pack disp cT class. 68 | End ClassDef. 69 | 70 | Module Exports. 71 | 72 | Notation wfType := type. 73 | Coercion base : class_of >-> Order.POrder.class_of. 74 | Coercion mixin : class_of >-> mixin_of. 75 | Coercion sort : type >-> Sortclass. 76 | Coercion eqType : type >-> Equality.type. 77 | Coercion choiceType : type >-> Choice.type. 78 | Coercion porderType : type >-> Order.POrder.type. 79 | Canonical eqType. 80 | Canonical choiceType. 81 | Canonical porderType. 82 | Notation WfType disp T m := (@pack T disp _ _ id m). 83 | 84 | End Exports. 85 | 86 | End WellFounded. 87 | 88 | Export WellFounded.Exports. 89 | 90 | 91 | Section WfInduction. 92 | 93 | Context {disp : unit} {T : wfType disp}. 94 | 95 | Lemma wfb : well_founded_bool (<%O : rel T). 96 | Proof. by case: T=> ? [] ? []. Qed. 97 | 98 | Lemma wfb_ind (P : T -> Type) : 99 | (forall n, (forall m, m < n -> P m) -> P n) -> 100 | forall n, P n. 101 | Proof. by move=> accP M; elim: (wfb M) => ?? /accP. Qed. 102 | 103 | End WfInduction. 104 | 105 | Global Instance wf_wfType {disp : unit} {T : wfType disp} : 106 | Equations.Prop.Classes.WellFounded (<%O : rel T). 107 | Proof. by apply: wfb_ind; constructor. Qed. 108 | 109 | 110 | (* Canonical well-founded order for nat *) 111 | 112 | Import Order.NatOrder. 113 | 114 | Lemma nat_well_founded_bool: well_founded_bool (<%O : rel nat). 115 | Proof. by elim/ltn_ind=> n IHn; constructor=> m /IHn. Qed. 116 | 117 | Definition nat_wfMixin := @WellFounded.Mixin nat _ nat_well_founded_bool. 118 | Canonical nat_wfType := Eval hnf in WfType nat_display nat nat_wfMixin. 119 | -------------------------------------------------------------------------------- /Styleguide.md: -------------------------------------------------------------------------------- 1 | # Code Style Guide 2 | 3 | ### General Rules 4 | 5 | * Maximal line length should not exceed 80 characters. 6 | 7 | ### Naming conventions 8 | 9 | * Prefer `snake_case` for the names of function arguments, inductive datatypes, definitions, and lemmas. 10 | 11 | * Prefer `CamelCase` for the names of hypothesis, variables inside sections, modules, and sections. 12 | 13 | ```Coq 14 | Module Foo. 15 | 16 | Section Bar. 17 | 18 | Variable Hb : bool. 19 | 20 | Definition lt_zero x := x < 0. 21 | 22 | Inductive tri_bool := 23 | | tri_true 24 | | tri_false 25 | | tri_unknown 26 | 27 | Lemma lt_zero_lt_one x (HLtZ : lt_zero x) : 28 | x < 1. 29 | Proof. admit. Admitted. 30 | 31 | End Bar. 32 | 33 | End Foo. 34 | 35 | ``` 36 | 37 | * Use the following conventions for naming variables. 38 | 39 | * For names of **events** use `e`, `e'`, `e1`, `e2`, `e3` etc. 40 | If it is known from the context that event has a specific type 41 | (i.e. it is a read, write or fence) use the corresponding names 42 | to highlight that: `r`, `w`, `f` etc. 43 | 44 | * For names of **labels** use `l`, `l'`, `l1`, `l2`, `l3` etc. 45 | If it is known from the context that label has a specific type 46 | (i.e. it is a read, write or fence label) add the corresponding suffix 47 | to highlight that and use names: `lr`, `lw`, `lf` etc. 48 | 49 | * Use the last letters of latin alphabet for names 50 | of **memory locations (variables)**: `x`, `y`, `z`. 51 | 52 | * Use the first letters of latin alphabet for names 53 | of **values**: `a`, `b`, `c`, etc. 54 | 55 | * Prefer short names for binary relations, in the style of weak memory papers 56 | (ideally, two to four letters in length). 57 | Give the full name in a comment near the definition of the property. 58 | 59 | ```Coq 60 | (* Causality relation *) 61 | Definition ca := connect ica. 62 | ``` 63 | 64 | * Use the following common prefixes and suffixes. 65 | 66 | * `o` prefix for **option-valued** functions, 67 | e.g. `omap`, `obind` from `ssrfun.v`. 68 | 69 | * `f` prefix for **functional** (computational) version of a relation, 70 | e.g. `fpred`, `frf`, etc. 71 | 72 | * `s` prefix for **strict** (irreflexive) version of some partial order, 73 | e.g. `sca` for strict causality. 74 | 75 | * `i` prefix for **immediate**, non-transitive version of a relation, 76 | e.g. `ica`, `icf`, etc. 77 | 78 | * To name a lemma stating a property of some function or relation 79 | use name of function/relation followed by the name of property, e.g. 80 | `ca_trans`, `cf_irrefl`, etc. 81 | 82 | ### Indentation and Spaces 83 | 84 | * Use two spaces to indent a new block (do not use tabs). 85 | 86 | * Always indent a content of the `Module` and `Section` (see example above). 87 | 88 | * Start a proof on a new line and indent a content of the `Proof` block, 89 | except when the proof is short and can fit into one line. 90 | 91 | ```Coq 92 | (* one line proof *) 93 | Lemma lt_zero_lt_one x : x < 0 -> x < 1. 94 | Proof. ssrlia. Qed. 95 | 96 | (* multi line proof *) 97 | Lemma le_or_gt_zero x : 98 | {x <= 0} + {x > 0}. 99 | Proof. 100 | tac1. 101 | tac2. 102 | tac3. 103 | Qed. 104 | ``` 105 | 106 | * When the lemma statement does not fit into single line, 107 | put some arguments (assumptions) on the new line 108 | and indent them to the first argument on the previous line. 109 | In this case also put the conclusion on the new line, 110 | and indent it with two spaces. 111 | In such a way that it would be easier to visually 112 | separate the conclusion from the assumptions. 113 | An example is given below. 114 | 115 | ```Coq 116 | Lemma upd_ord_max {T : nat -> Type} {n} 117 | (f : forall m : 'I_n, T m) (x : T n) : 118 | upd f x ord_max = x. 119 | ``` 120 | 121 | * View intro patterns should be separated by spaces, e.g. `move /eqP /andP`. 122 | 123 | * Binary operators should be surrounded by spaces: `t : T`, `a := 2 + 2`, `A -> B` etc. 124 | The **statement of the lemma** is **not an exception**. 125 | That is always surround `:` in the statement of lemma by spaces 126 | (see examples above). 127 | There are some exceptions to this rule mentioned below. 128 | 129 | * SSReflect tacticals, i.e. `:`, `=>`, etc, 130 | should not be separated from the preceding tactic: 131 | `move=>`, `case:`. 132 | 133 | * The `;` tactical should not be separated from the preceding tactic: `apply Hx; auto`. 134 | 135 | * When using goal selectors, do not separate goal numbers by spaces 136 | and do not put spaces before `:`. 137 | 138 | ```Coq 139 | apply Hx. 140 | 1,2,3: omega. 141 | all: congruence. 142 | ``` 143 | 144 | * Separate conjuncts by single space. Also surround disjuncts separator `|` by spaces. 145 | But do not put spaces after opening bracket `[` or before closing bracket `]`. 146 | 147 | ```Coq 148 | case: HAnd=> [HA HB]. 149 | ``` 150 | 151 | ```Coq 152 | case: HOr=> [HA | HB]. 153 | ``` 154 | 155 | ```Coq 156 | case: HExist=> [x Hx]. 157 | ``` 158 | 159 | ```Coq 160 | case: HOption=> [|H]. 161 | ``` 162 | 163 | * Same rules apply when using `[|]` to handle subgoals by different tactics. 164 | 165 | ```Coq 166 | apply Hx; [apply Hy | apply Hz]. 167 | ``` 168 | 169 | ```Coq 170 | apply Hx; [apply Hy |]. 171 | ``` 172 | 173 | * When tactics used to handle subgoals do not fit into one line, 174 | use the indentation style as in the example below. 175 | 176 | ```Coq 177 | apply Hx; 178 | [ apply Ha 179 | | apply Hb 180 | | apply Hc 181 | ]. 182 | ``` 183 | 184 | ### Goal bookkeeping 185 | 186 | * Use curly brackets `{}` instead of bullets `+`, `-`, `*`, etc in order to focus on the subgoal. 187 | 188 | * Put a space after opening bracket `{` and before closing bracket `}`. 189 | 190 | * When selecting a subgoal with brackets always start the subgoal's proof on a new line and use indentation. 191 | 192 | * Do not leave opening `{` or closing bracket `}` alone on a line. 193 | 194 | * Do not focus the last subgoal (rule of thumb: there're no two `}` on the line and there's no `}` preceding `Qed.`). 195 | 196 | ```Coq 197 | apply Hx. 198 | { ssrlia. } 199 | { apply Ha. 200 | apply Hb. } 201 | apply Hy. 202 | ``` 203 | 204 | * Avoid references to the autogenerated names like `H0` when possible. 205 | 206 | ### Proof's style 207 | 208 | * Do not use long one-liners in proofs. Do not abuse `;` tactical. 209 | In particular, do not try to put several proof steps into one line. 210 | Instead, each proof step should end with `.` and be held on a separate line. 211 | These rules are necessary for proof maintenance and modification. 212 | Otherwise, it becomes harder to go through proofs in interactive mode 213 | and, on modifications, find the exact place where proof breaks. 214 | -------------------------------------------------------------------------------- /theories/lang/sharedmem.v: -------------------------------------------------------------------------------- 1 | From mathcomp Require Import ssreflect ssrfun ssrbool ssrnat seq. 2 | From mathcomp Require Import eqtype choice finfun finmap tuple. 3 | From eventstruct Require Import utils inhtype ident lts relaxed. 4 | 5 | Set Implicit Arguments. 6 | Unset Strict Implicit. 7 | Unset Printing Implicit Defensive. 8 | 9 | Local Open Scope order_scope. 10 | Local Open Scope fset_scope. 11 | Local Open Scope ident_scope. 12 | 13 | Module SharedMem. 14 | 15 | Section Def. 16 | Context {dA dV : unit} {Addr : inhType dA} {Val : inhType dV}. 17 | 18 | Local Notation null := (inh : Addr). 19 | Local Notation v0 := (inh : Val). 20 | 21 | Definition state := 22 | { fsfun Addr -> Val for fun x => v0 }. 23 | 24 | Variant label := 25 | | Read of Addr & Val 26 | | Write of Addr & Val 27 | | Bot 28 | . 29 | 30 | Definition typ : label -> Lab.typ := 31 | fun l => match l with 32 | | Read _ _ => Lab.Read 33 | | Write _ _ => Lab.Write 34 | | Bot => Lab.Undef 35 | end. 36 | 37 | Definition addr : label -> Addr := 38 | fun l => match l with 39 | | Read x _ => x 40 | | Write x _ => x 41 | | Bot => null 42 | end. 43 | 44 | Definition value : label -> Val := 45 | fun l => match l with 46 | | Read _ v => v 47 | | Write _ v => v 48 | | Bot => v0 49 | end. 50 | 51 | End Def. 52 | 53 | Arguments state {_ _} _ _ . 54 | Arguments label {_ _} _ _ . 55 | 56 | Section Encode. 57 | Context {dA dV : unit} {Addr : inhType dA} {Val : inhType dV}. 58 | 59 | Definition enc_lab : (label Addr Val) -> Addr * Val + Addr * Val + unit := 60 | fun l => match l with 61 | | Read x v => inl (inl (x, v)) 62 | | Write x v => inl (inr (x, v)) 63 | | Bot => inr tt 64 | end. 65 | 66 | Definition dec_lab : Addr * Val + Addr * Val + unit -> (label Addr Val) := 67 | fun l => match l with 68 | | inl (inl (x, v)) => Read x v 69 | | inl (inr (x, v)) => Write x v 70 | | inr _ => Bot 71 | end. 72 | 73 | Lemma enc_dec_labK : 74 | cancel enc_lab dec_lab. 75 | Proof. by case. Qed. 76 | 77 | End Encode. 78 | 79 | Module Export Exports. 80 | Section Exports. 81 | Context {dA dV : unit} {A : inhType dA} {V : inhType dV}. 82 | 83 | Definition label_eqMixin := 84 | CanEqMixin (@enc_dec_labK _ _ A V). 85 | Canonical label_eqType := 86 | Eval hnf in EqType _ label_eqMixin. 87 | 88 | Definition label_choiceMixin := 89 | CanChoiceMixin (@enc_dec_labK _ _ A V). 90 | Canonical label_choiceType := 91 | Eval hnf in ChoiceType _ label_choiceMixin. 92 | 93 | End Exports. 94 | End Exports. 95 | 96 | 97 | Module Export LTS. 98 | Section LTS. 99 | Context {dA dV : unit} {Addr : inhType dA} {Val : inhType dV}. 100 | Local Notation state := (state Addr Val). 101 | Local Notation label := (label Addr Val). 102 | Implicit Types (m : state) (l : label). 103 | 104 | Definition read_trans l m m' := 105 | let x := addr l in 106 | let v := value l in 107 | (typ l == Lab.Read) && (m x == v) && (m' == m). 108 | 109 | Definition write_trans l m m' := 110 | let x := addr l in 111 | let v := value l in 112 | (typ l == Lab.Write) && (m' == [fsfun m with x |-> v]). 113 | 114 | Definition ltrans l m m' := 115 | (read_trans l m m') || (write_trans l m m'). 116 | 117 | Definition enabled l m := 118 | match l with 119 | | Read x v => m x == v 120 | | Write x v => true 121 | | Bot => false 122 | end. 123 | 124 | Lemma enabledP l m : 125 | reflect (exists m', ltrans l m m') (enabled l m). 126 | Proof. 127 | rewrite /ltrans /read_trans /write_trans /enabled. 128 | case: l=> [x v | x v |]; try constructor=> //=; last first. 129 | - by move=> [[]]. 130 | - by exists ([fsfun m with x |-> v]). 131 | case: (m x == v)=> //=; constructor; last by move=> []. 132 | by exists m; rewrite eqxx. 133 | Qed. 134 | 135 | End LTS. 136 | 137 | Module Export Exports. 138 | Section Exports. 139 | Context {dA dV : unit} {A : inhType dA} {V : inhType dV}. 140 | 141 | Definition ltsMixin := 142 | let S := (state A V) in 143 | let L := (label A V) in 144 | @LTS.LTS.Mixin S L _ _ _ enabledP. 145 | Definition ltsType := 146 | Eval hnf in (LTSType _ _ ltsMixin). 147 | 148 | End Exports. 149 | End Exports. 150 | 151 | End LTS. 152 | 153 | Export LTS.Exports. 154 | 155 | 156 | Module Export Label. 157 | Section Label. 158 | Context {dA dV : unit} {Addr : inhType dA} {Val : inhType dV}. 159 | Local Notation label := (label Addr Val). 160 | Implicit Types (ls : {fset label}) (l : label). 161 | 162 | Definition rf : rel label := 163 | fun w r => match w, r with 164 | | Write x a, Read y b => (x == y) && (a == b) 165 | | _ , _ => false 166 | end. 167 | 168 | Definition com ws r := 169 | let w := odflt Bot (fset_pick ws) in 170 | (#|` ws | == 1) && (rf w r). 171 | 172 | Definition cf_typ l1 l2 := 173 | match (typ l1), (typ l2) with 174 | | Lab.Read , Lab.Write => true 175 | | Lab.Write, Lab.Read => true 176 | | Lab.Write, Lab.Write => true 177 | | _ , _ => false 178 | end. 179 | 180 | Definition cf l1 l2 := 181 | (cf_typ l1 l2) && (addr l1 == addr l2). 182 | 183 | Definition is_write l := 184 | typ l == Lab.Write. 185 | 186 | Definition is_read l := 187 | typ l == Lab.Read. 188 | 189 | Lemma is_writeP w : 190 | reflect (exists ws r, com ws r /\ w \in ws) (is_write w). 191 | Proof. 192 | apply/(equivP idP); split; rewrite /com /rf. 193 | - move=> isW; exists [fset w]. 194 | move: w isW; case=> //= x v _. 195 | exists (Read x v); rewrite inE; split=> //=. 196 | by rewrite fset_pick1 cardfs1 /= !eqxx. 197 | move=> /= [ws] [r] [] /andP[] /cardfs1P[w'] ->. 198 | rewrite fset_pick1 inE /=. 199 | by move=> /[swap] /eqP<-; case: w. 200 | Qed. 201 | 202 | Lemma is_readP r : 203 | reflect (exists ws, com ws r) (is_read r). 204 | Proof. 205 | apply/(equivP idP); split; rewrite /com /rf. 206 | - case: r=> // x v _. 207 | exists [fset (Write x v)]. 208 | by rewrite fset_pick1 cardfs1 /= !eqxx. 209 | move=> [ws] /andP[] /cardfs1P[w] ->. 210 | rewrite fset_pick1 /=. 211 | by case: w; case: r. 212 | Qed. 213 | 214 | Lemma bot_nwrite : 215 | ~~ is_write Bot. 216 | Proof. done. Qed. 217 | 218 | Lemma bot_nread : 219 | ~~ is_read Bot. 220 | Proof. done. Qed. 221 | 222 | End Label. 223 | 224 | Module Export Exports. 225 | Section Exports. 226 | Context {dA dV : unit} {A : inhType dA} {V : inhType dV}. 227 | 228 | Definition inhMixin := @Inhabited.Mixin (label A V) _ Bot. 229 | Canonical inhType := Eval hnf in InhType (label A V) Bottom.disp inhMixin. 230 | 231 | Definition labMixin := 232 | @Lab.Lab.Mixin (label A V) _ com cf is_write is_read 233 | is_writeP is_readP bot_nwrite bot_nread. 234 | Canonical labType := 235 | Lab.Lab.Pack (Lab.Lab.Class labMixin). 236 | 237 | End Exports. 238 | End Exports. 239 | 240 | End Label. 241 | 242 | End SharedMem. 243 | 244 | Export SharedMem.Exports. 245 | Export SharedMem.LTS.Exports. 246 | Export SharedMem.Label.Exports. 247 | -------------------------------------------------------------------------------- /theories/common/fperm.v: -------------------------------------------------------------------------------- 1 | From mathcomp Require Import ssreflect ssrfun ssrbool ssrnat. 2 | From mathcomp Require Import eqtype choice seq fintype finfun finmap zify. 3 | From eventstruct Require Import utils seq. 4 | 5 | Set Implicit Arguments. 6 | Unset Strict Implicit. 7 | Unset Printing Implicit Defensive. 8 | 9 | Local Open Scope fset_scope. 10 | Local Open Scope fmap_scope. 11 | 12 | Declare Scope perm_scope. 13 | Delimit Scope perm_scope with perm. 14 | 15 | Local Open Scope perm_scope. 16 | 17 | Section FsFunInjb. 18 | Context {T : choiceType}. 19 | Implicit Types (f : {fsfun T -> T}) (X : {fset T}). 20 | 21 | Lemma fsinj_bij f : 22 | injective f -> bijective f. 23 | Proof. 24 | move=> injf; apply/inj_surj_bij=> // x. 25 | pose S := finsupp f. 26 | have fS : forall a : S, f (val a) \in S. 27 | - by move: injf=> /(fsinjP 1 0) /= []. 28 | pose ff : S -> S := (fun x => Sub (f (val x)) (fS x)). 29 | have injff: injective ff. 30 | - move=> {}x y; rewrite /ff /=. 31 | by move=> /sub_inj/injf/val_inj. 32 | pose gg : S -> S := invF injff. 33 | case: (finsuppP f x)=> [xnin | xin]. 34 | - by exists x; apply/fsfun_dflt. 35 | exists (val (gg (Sub x xin))). 36 | suff->: f (val (gg (Sub x xin))) = val (ff (gg (Sub x xin))). 37 | - by rewrite /gg f_invF. 38 | by rewrite /ff /=. 39 | Qed. 40 | 41 | End FsFunInjb. 42 | 43 | 44 | Module Export FPerm. 45 | 46 | Section Def. 47 | Context (T : choiceType). 48 | 49 | Structure fPerm : Type := mkPerm { 50 | fperm_val :> { fsfun T -> T for id }; 51 | _ : fsinjectiveb fperm_val; 52 | }. 53 | 54 | Canonical fperm_subType := Eval hnf in [subType for fperm_val]. 55 | 56 | Implicit Types (f : fPerm) (X : {fset T}). 57 | 58 | Lemma fperm_inj f : injective f. 59 | Proof. exact/fsinjectiveP/valP. Qed. 60 | 61 | Lemma fperm_bij f : bijective f. 62 | Proof. exact/fsinj_bij/fperm_inj. Qed. 63 | 64 | Lemma fperm_surj f : surjective f. 65 | Proof. exact/bij_surj/fperm_bij. Qed. 66 | 67 | Definition fperm_inv f := preim_of (fperm_surj f). 68 | 69 | Definition fperm0 : fPerm := 70 | Sub [fsfun] (introT fsinjectiveP (fsfun0_inj (@inj_id T))). 71 | 72 | (* The idea of implementation is due to Arthur Azevedo de Amorim 73 | * https://github.com/arthuraa/extructures/blob/master/theories/fperm.v 74 | * TODO: it would be nice to unify mathcomp/finmap & extructures eventually. 75 | *) 76 | Definition mkfperm_fun (f : T -> T) X x := 77 | let Y1 := (f @` X) `\` X in 78 | let Y2 := X `\` (f @` X) in 79 | if x \in Y1 then nth x Y2 (index x Y1) else f x. 80 | 81 | Definition mkfperm_fsfun (f : T -> T) X : {fsfun T -> T} := 82 | [fsfun x in X `|` (f @` X) => mkfperm_fun f X x]. 83 | 84 | Definition mkfperm (f : T -> T) X : fPerm := 85 | odflt fperm0 (insub (mkfperm_fsfun f X)). 86 | 87 | End Def. 88 | 89 | Module Export Syntax. 90 | 91 | Notation "{ 'fperm' T }" := (@fPerm T) 92 | (at level 0, format "{ 'fperm' T }") : type_scope. 93 | 94 | Notation "[ 'fperm' ]" := (fperm0) 95 | (at level 0, format "[ 'fperm' ]") : fun_scope. 96 | 97 | Notation "[ 'fperm' x 'in' X => F ]" := (mkfperm (fun x => F) X) 98 | (at level 0, x at level 99, format "[ 'fperm' x 'in' X => F ]") 99 | : fun_scope. 100 | 101 | End Syntax. 102 | 103 | Section Instances. 104 | 105 | Definition fperm_eqMixin (T : choiceType) := 106 | Eval hnf in [eqMixin of {fperm T} by <:]. 107 | Canonical fperm_eqType (T : choiceType) := 108 | Eval hnf in EqType {fperm T} (fperm_eqMixin T). 109 | 110 | Definition fperm_choiceMixin (T : choiceType) := 111 | Eval hnf in [choiceMixin of {fperm T} by <:]. 112 | Canonical fperm_choiceType (T : choiceType) := 113 | Eval hnf in ChoiceType {fperm T} (fperm_choiceMixin T). 114 | 115 | Definition fperm_countMixin (T : countType) := 116 | Eval hnf in [countMixin of {fperm T} by <:]. 117 | Canonical fperm_countType (T : countType) := 118 | Eval hnf in CountType {fperm T} (fperm_countMixin T). 119 | 120 | Canonical fperm_subCountType (T : countType) := 121 | Eval hnf in [subCountType of {fperm T}]. 122 | 123 | End Instances. 124 | 125 | Section Theory. 126 | Context (T : choiceType). 127 | Implicit Types (f : {fperm T}) (X : {fset T}). 128 | 129 | Lemma fperm_invK f : cancel f (fperm_inv f). 130 | Proof. exact/f_preim_of/fperm_inj. Qed. 131 | 132 | Lemma inv_fpermK f : cancel (fperm_inv f) f. 133 | Proof. exact/preim_of_f. Qed. 134 | 135 | Lemma fperm_inv_inj f : injective (fperm_inv f). 136 | Proof. exact/can_inj/inv_fpermK. Qed. 137 | 138 | End Theory. 139 | 140 | Section MkFPermTheory. 141 | Context (T : choiceType). 142 | Implicit Types (f : T -> T) (X : {fset T}). 143 | 144 | Lemma mkfpermE f X : {in X &, injective f} -> 145 | {in X, mkfperm f X =1 f}. 146 | Proof. 147 | move=> in_injf x xin. 148 | rewrite /mkfperm insubT /= => [|_]; last first. 149 | - by rewrite /mkfperm_fsfun /mkfperm_fun fsfunE !inE xin. 150 | apply/fsinjectiveP/(fsinjP 2 0)=> /=. 151 | exists (X `|` (f @` X)). 152 | - exact/finsupp_sub. 153 | clear x xin. 154 | pose Y1 := (f @` X) `\` X. 155 | pose Y2 := X `\` (f @` X). 156 | pose D := X `|` (f @` X). 157 | have szY : size Y1 = size Y2. 158 | - by rewrite !cardfsD fsetIC card_in_imfset. 159 | have nY1_X x : x \in D -> x \notin Y1 -> x \in X. 160 | - case/fsetUP=> //; by rewrite in_fsetD => ->; rewrite andbT negbK. 161 | have nth_Y2 x : x \in D -> x \in Y1 -> nth x Y2 (index x Y1) \in Y2. 162 | - move=> ??; by rewrite mem_nth // -szY index_mem. 163 | split; last first. 164 | - case=> /= x; rewrite /mkfperm_fsfun /mkfperm_fun fsfunE. 165 | move=> /[dup] xD ->; case: ifP. 166 | + by move=> /(nth_Y2 x xD); rewrite !inE=> /andP[_ ->]. 167 | by move=> /negP/negP/(nY1_X x xD) ?; rewrite inE (in_imfset _ f). 168 | move=> x y xD yD; rewrite /mkfperm_fsfun /mkfperm_fun !fsfunE xD yD. 169 | case: ifP; case: ifP. 170 | - move: (@uniqP _ y Y2 (fset_uniq Y2))=> nth_injY2. 171 | move=> /[dup] yin + /[dup] xin; rewrite -!index_mem=> ysz xsz. 172 | rewrite (set_nth_default y x); last by rewrite -szY. 173 | move=> /nth_injY2; rewrite !inE -szY=> idx_eq. 174 | by move: (idx_eq xsz ysz); apply/index_inj. 175 | - move=> /negP/negP /(nY1_X y yD) /(in_imfset imfset_key f) /= fy. 176 | by move=> /(nth_Y2 x xD) /[swap] ->; rewrite inE=> /andP[/negP]. 177 | - move=> /[swap] /negP/negP /(nY1_X x xD) /(in_imfset imfset_key f) /= fx. 178 | by move=> /(nth_Y2 y yD) /[swap] <-; rewrite inE=> /andP[/negP]. 179 | move=> /negP/negP /(nY1_X y yD) yX /negP/negP /(nY1_X x xD) xX. 180 | by move=> /(in_injf _ _ xX yX). 181 | Qed. 182 | 183 | Lemma fperm_invE f g X : {on f @` X, cancel f & g} -> {in f @` X, cancel g f} -> 184 | {in f @` X, fperm_inv (mkfperm f X) =1 g}. 185 | Proof. 186 | move=> fK gK y /imfsetP[x] /= xX ->. 187 | rewrite fK ?(in_imfset _ f) //. 188 | suff->: f x = [fperm x in X => f x] x. 189 | - by rewrite fperm_invK. 190 | rewrite mkfpermE //. 191 | exact/can_in_inj/imfset_can_in/fK. 192 | Qed. 193 | 194 | End MkFPermTheory. 195 | 196 | End FPerm. 197 | -------------------------------------------------------------------------------- /theories/common/monoid.v: -------------------------------------------------------------------------------- 1 | From mathcomp Require Import ssreflect ssrfun ssrbool ssrnat seq eqtype choice. 2 | From RelationAlgebra Require Import monoid. 3 | From eventstruct Require Import utils. 4 | 5 | (******************************************************************************) 6 | (* This file provides a theory of (homogeneous) monoids and partial monoids. *) 7 | (* *) 8 | (* Monoid.m T == a type of monoidal structures over elements *) 9 | (* of type T. Consists of binary associative *) 10 | (* operation and a neutral element (unit). *) 11 | (* Monoid.mType d == a type equipped with canonical monoidal structure. *) 12 | (* *) 13 | (* Monoid.pm d == a type of monoidal structures with partial *) 14 | (* operation over elements of type T. *) 15 | (* Inherits from ordinary monoidal structure. *) 16 | (* In addition, contains a orthogonality relation *) 17 | (* which determines pairs of elements whose *) 18 | (* composition is defined. *) 19 | (* Monoid.pmType d == a type equipped with canonical partial *) 20 | (* monoidal structure. *) 21 | (******************************************************************************) 22 | 23 | Set Implicit Arguments. 24 | Unset Strict Implicit. 25 | Unset Printing Implicit Defensive. 26 | 27 | Declare Scope monoid_scope. 28 | Delimit Scope monoid_scope with monoid. 29 | 30 | Local Open Scope monoid_scope. 31 | 32 | Reserved Notation "\0" (at level 0). 33 | Reserved Notation "x \+ y" (at level 40, left associativity). 34 | Reserved Notation "x ⟂ y" (at level 20, no associativity). 35 | 36 | Module Monoid. 37 | 38 | Module Monoid. 39 | Section ClassDef. 40 | 41 | Record mixin_of (T : Type) := Mixin { 42 | zero : T; 43 | plus : T -> T -> T; 44 | _ : associative plus; 45 | _ : left_id zero plus; 46 | _ : right_id zero plus; 47 | }. 48 | 49 | Set Primitive Projections. 50 | Record class_of (T : Type) := Class { 51 | mixin : mixin_of T; 52 | }. 53 | Unset Primitive Projections. 54 | 55 | Structure type (disp : unit) := Pack { sort; _ : class_of sort }. 56 | 57 | Local Coercion sort : type >-> Sortclass. 58 | 59 | Variables (T : Type) (disp : unit) (cT : type disp). 60 | 61 | Definition class := let: Pack _ c as cT' := cT return class_of (sort cT') in c. 62 | 63 | Definition pack c := @Pack disp T c. 64 | 65 | Definition clone c of phant_id class c := @Pack disp T c. 66 | Definition clone_with disp' c of phant_id class c := @Pack disp' T c. 67 | 68 | End ClassDef. 69 | 70 | Module Exports. 71 | Coercion mixin : class_of >-> mixin_of. 72 | Coercion sort : type >-> Sortclass. 73 | End Exports. 74 | 75 | End Monoid. 76 | 77 | Notation m := Monoid.class_of. 78 | Notation mType := Monoid.type. 79 | 80 | Import Monoid.Exports. 81 | 82 | Module Import MonoidDef. 83 | Section MonoidDef. 84 | 85 | Context {disp : unit} {M : mType disp}. 86 | 87 | Definition zero : M := Monoid.zero (Monoid.class M). 88 | Definition plus : M -> M -> M := Monoid.plus (Monoid.class M). 89 | 90 | End MonoidDef. 91 | End MonoidDef. 92 | 93 | Prenex Implicits zero plus. 94 | 95 | Module Export MonoidSyntax. 96 | Notation "\0" := (zero) : monoid_scope. 97 | Notation "x \+ y" := (plus x y) : monoid_scope. 98 | End MonoidSyntax. 99 | 100 | Module Export MonoidTheory. 101 | Section MonoidTheory. 102 | 103 | Context {disp : unit} {M : mType disp}. 104 | 105 | Lemma plusA (x y z : M) : 106 | x \+ y \+ z = x \+ (y \+ z). 107 | Proof. by case: M x y z => ? [[]]. Qed. 108 | 109 | Lemma plus0m (x : M) : 110 | \0 \+ x = x. 111 | Proof. by move: x; case: M=> ? [[]]. Qed. 112 | 113 | Lemma plusm0 (x : M) : 114 | x \+ \0 = x. 115 | Proof. by move: x; case: M=> ? [[]]. Qed. 116 | 117 | End MonoidTheory. 118 | End MonoidTheory. 119 | 120 | Module PartialMonoid. 121 | Section ClassDef. 122 | 123 | Record mixin_of (T0 : Type) (b : Monoid.class_of T0) 124 | (T := Monoid.Pack tt b) := Mixin { 125 | orth : rel T; 126 | _ : orth zero zero; 127 | _ : forall x, orth x zero = orth zero x; 128 | _ : forall x y, orth x y -> orth x zero && orth y zero; 129 | _ : forall x y z, orth (plus x y) z = orth x (plus y z); 130 | }. 131 | 132 | Set Primitive Projections. 133 | Record class_of (T : Type) := Class { 134 | base : Monoid.class_of T; 135 | mixin : mixin_of base; 136 | }. 137 | Unset Primitive Projections. 138 | 139 | Local Coercion base : class_of >-> Monoid.class_of. 140 | 141 | Structure type (disp : unit) := Pack { sort; _ : class_of sort }. 142 | 143 | Local Coercion sort : type >-> Sortclass. 144 | 145 | Variables (T : Type) (disp : unit) (cT : type disp). 146 | 147 | Definition class := let: Pack _ c as cT' := cT return class_of (sort cT') in c. 148 | 149 | Definition pack := 150 | fun bE b & phant_id (@Monoid.class disp bE) b => 151 | fun m => Pack disp (@Class T b m). 152 | 153 | Definition mType := @Monoid.Pack disp cT class. 154 | End ClassDef. 155 | 156 | Module Exports. 157 | Coercion base : class_of >-> Monoid.class_of. 158 | Coercion mixin : class_of >-> mixin_of. 159 | Coercion sort : type >-> Sortclass. 160 | Coercion mType : type >-> Monoid.type. 161 | Canonical mType. 162 | End Exports. 163 | 164 | End PartialMonoid. 165 | 166 | Notation pm := PartialMonoid.class_of. 167 | Notation pmType := PartialMonoid.type. 168 | 169 | Import PartialMonoid.Exports. 170 | 171 | Module Import PartialMonoidDef. 172 | Section PartialMonoidDef. 173 | 174 | Context {disp : unit} {M : pmType disp}. 175 | 176 | Definition orth : rel M := PartialMonoid.orth (PartialMonoid.class M). 177 | 178 | Definition valid : pred M := fun x => orth x zero. 179 | 180 | End PartialMonoidDef. 181 | End PartialMonoidDef. 182 | 183 | Prenex Implicits orth valid. 184 | 185 | Module Export PartialMonoidSyntax. 186 | Notation "x ⟂ y" := (orth x y) : monoid_scope. 187 | End PartialMonoidSyntax. 188 | 189 | Module Export PartialMonoidTheory. 190 | Section PartialMonoidTheory. 191 | 192 | Context {disp : unit} {M : pmType disp}. 193 | 194 | Lemma orth0 : 195 | orth \0 (\0 : M). 196 | Proof. by case: M=> ? [? []]. Qed. 197 | 198 | Lemma valid0 : 199 | valid (\0 : M). 200 | Proof. by case: M=> ? [? []]. Qed. 201 | 202 | Lemma orth_sym0 (x : M) : 203 | x ⟂ \0 = \0 ⟂ x. 204 | Proof. by move: x; case: M=> ? [? []]. Qed. 205 | 206 | Lemma orth_valid (x y : M) : 207 | x ⟂ y -> valid x * valid y. 208 | Proof. by move: x y; case: M=> ? [? [??? H ???]] /H /andP [? ?]. Qed. 209 | 210 | Lemma orthA (x y z : M) : 211 | (x \+ y) ⟂ z = x ⟂ (y \+ z). 212 | Proof. by move: x y z; case: M=> ? [? []]. Qed. 213 | 214 | Lemma orth_valid_plus (x y : M) : 215 | x ⟂ y = valid (x \+ y). 216 | Proof. by rewrite /valid -[y in LHS]plusm0 orthA. Qed. 217 | 218 | End PartialMonoidTheory. 219 | End PartialMonoidTheory. 220 | 221 | End Monoid. 222 | 223 | Export Monoid.MonoidDef. 224 | Export Monoid.MonoidSyntax. 225 | Export Monoid.MonoidTheory. 226 | 227 | Export Monoid.PartialMonoidDef. 228 | Export Monoid.PartialMonoidSyntax. 229 | Export Monoid.PartialMonoidTheory. 230 | -------------------------------------------------------------------------------- /theories/common/inhtype.v: -------------------------------------------------------------------------------- 1 | From mathcomp Require Import ssreflect ssrfun ssrbool ssrnat seq fintype order. 2 | From mathcomp Require Import eqtype choice fingraph path. 3 | From eventstruct Require Import utils. 4 | 5 | (******************************************************************************) 6 | (* This file provides a theory of inhabited types, i.e. types with one *) 7 | (* distinguished inhabitant. *) 8 | (* ?|T| == propositional assertion that type T has an inhabitant. *) 9 | (* ??|T| == boolean assertion that finite type T has an inhabitant. *) 10 | (* inhType d == inhabited type. *) 11 | (* inh : T == distinguished inhabitant of the type T. *) 12 | (* botType == special kind of inhabited types where the *) 13 | (* distinguished inhabitant represets bottom *) 14 | (* (i.e. undefined value). *) 15 | (* bot : T == bottom of the type T. *) 16 | (* {homo bot f} <-> f is a homomorphism between types with bottom: *) 17 | (* f bot = bot. *) 18 | (* *) 19 | (* We also provide canonical instance of inhType for the following types: *) 20 | (* - nat with inhabitant 0; *) 21 | (* - product type T * U with inhabitant (inh : T, inh : U); *) 22 | (* *) 23 | (******************************************************************************) 24 | 25 | 26 | Set Implicit Arguments. 27 | Unset Strict Implicit. 28 | Unset Printing Implicit Defensive. 29 | 30 | (* TODO: add scope? *) 31 | Notation "?| T |" := (inhabited T) 32 | (at level 0, T at level 99, format "?| T |"). 33 | 34 | (* TODO: add scope? *) 35 | Notation "??| A |" := (~~ pred0b A) 36 | (at level 0, A at level 99, format "??| A |"). 37 | 38 | Section Theory. 39 | Implicit Types (aT rT : Type) (fT : finType). 40 | 41 | Lemma nihn_inh_fun aT rT : 42 | ~ ?|aT| -> ?|aT -> rT|. 43 | Proof. 44 | move=> H; constructor. 45 | have fT: (forall x : aT, False). 46 | - move=> x; apply/H; constructor; exact/x. 47 | by refine (fun x => match fT x with end). 48 | Qed. 49 | 50 | Lemma inh_impl aT rT : 51 | (aT -> rT) -> ?|aT| -> ?|rT|. 52 | Proof. move=> f [x]; exists; exact/(f x). Qed. 53 | 54 | Lemma inh_iff aT rT : 55 | (aT -> rT) -> (rT -> aT) -> ?|aT| <-> ?|rT|. 56 | Proof. by move=> f g; split; apply/inh_impl. Qed. 57 | 58 | Lemma fin_inhP fT : 59 | reflect ?|fT| ??|fT|. 60 | Proof. 61 | apply/(equivP pred0Pn). 62 | split; move=> [] //. 63 | by move=> x; exists x. 64 | Qed. 65 | 66 | Lemma sub_fin_inhP fT (P : pred fT) (S : subType P) : 67 | reflect ?|S| ??|P|. 68 | Proof. 69 | apply/(equivP pred0Pn). 70 | split=> [[x Px] | [x]] //. 71 | - exists; exact/(Sub x Px). 72 | exists (val x); exact/(valP x). 73 | Qed. 74 | 75 | 76 | Variables (T : Type) (R : T -> T -> Type) (r : rel T). 77 | Hypothesis (InhP : forall x y, reflect ?|R x y| (r x y)). 78 | Hypothesis (Refl : forall x, R x x). 79 | Hypothesis (Sym : forall x y, R x y -> R y x). 80 | Hypothesis (Trans : forall x y z, R x y -> R y z -> R x z). 81 | 82 | Lemma is_inh_refl : reflexive r. 83 | Proof. move=> ?; apply/InhP; exists; exact/Refl. Qed. 84 | 85 | Lemma is_inh_sym : symmetric r. 86 | Proof. move=> ??; apply/idP/idP=> /InhP[A]; apply/InhP; exists; exact/Sym. Qed. 87 | 88 | Lemma is_inh_trans : transitive r. 89 | Proof. move=> ??? /InhP[A] /InhP[B]; apply/InhP; exists; exact/(Trans A B). Qed. 90 | 91 | End Theory. 92 | 93 | 94 | Module Inhabited. 95 | Section ClassDef. 96 | 97 | Record mixin_of T0 (b : Choice.class_of T0) 98 | (T := Choice.Pack b) := Mixin { 99 | inh : T 100 | }. 101 | 102 | Set Primitive Projections. 103 | Record class_of (T : Type) := Class { 104 | base : Choice.class_of T; 105 | mixin : mixin_of base; 106 | }. 107 | Unset Primitive Projections. 108 | 109 | Local Coercion base : class_of >-> Choice.class_of. 110 | 111 | Structure type (disp : unit) := Pack { sort; _ : class_of sort }. 112 | 113 | Local Coercion sort : type >-> Sortclass. 114 | 115 | Variables (T : Type) (disp : unit) (cT : type disp). 116 | 117 | Definition class := let: Pack _ c as cT' := cT return class_of cT' in c. 118 | Definition clone c of phant_id class c := @Pack disp T c. 119 | 120 | Definition pack := 121 | fun bT b & phant_id (Choice.class bT) b => 122 | fun m => Pack disp (@Class T b m). 123 | 124 | Definition eqType := @Equality.Pack cT class. 125 | Definition choiceType := @Choice.Pack cT class. 126 | End ClassDef. 127 | 128 | Module Export Exports. 129 | Coercion base : class_of >-> Choice.class_of. 130 | Coercion sort : type >-> Sortclass. 131 | Coercion eqType : type >-> Equality.type. 132 | Coercion choiceType : type >-> Choice.type. 133 | Canonical eqType. 134 | Canonical choiceType. 135 | Notation inhType := type. 136 | Notation InhType T d m := (@pack T d _ _ id m). 137 | Notation "[ 'inhType' 'of' T 'for' cT ]" := (@clone T _ cT _ id) 138 | (at level 0, format "[ 'inhType' 'of' T 'for' cT ]") : form_scope. 139 | Notation "[ 'inhType' 'of' T ]" := [inhType of T for _] 140 | (at level 0, format "[ 'inhType' 'of' T ]") : form_scope. 141 | End Exports. 142 | 143 | Module Export Def. 144 | Section Def. 145 | Context {disp : unit} {T : inhType disp}. 146 | 147 | Definition inh : T := (inh (mixin (class T))). 148 | 149 | End Def. 150 | 151 | Section Homo. 152 | Context {dispT dispU : unit} {T : inhType dispT} {U : inhType dispU}. 153 | Implicit Types (f : T -> U). 154 | 155 | Definition homo_inh f : bool := 156 | (f inh == inh). 157 | 158 | End Homo. 159 | End Def. 160 | 161 | Module Export Syntax. 162 | Notation "{ 'homo' 'inh' f }" := (homo_inh f) 163 | (at level 0, f at level 99, format "{ 'homo' 'inh' f }") : type_scope. 164 | End Syntax. 165 | 166 | End Inhabited. 167 | 168 | Export Inhabited.Exports. 169 | Export Inhabited.Def. 170 | Export Inhabited.Syntax. 171 | 172 | 173 | Module Bottom. 174 | 175 | Lemma disp : unit. 176 | Proof. exact: tt. Qed. 177 | 178 | Module Export Exports. 179 | Notation botType := (@Inhabited.type disp). 180 | Notation BotType T m := (@Inhabited.pack T disp _ _ id m). 181 | End Exports. 182 | 183 | Module Export Def. 184 | Section Def. 185 | Context {T : botType}. 186 | Definition bot : T := @inh _ T. 187 | End Def. 188 | End Def. 189 | 190 | Module Export Syntax. 191 | (* TODO: enforce that f is a function from/to botType ? *) 192 | Notation "{ 'homo' 'bot' f }" := (homo_inh f) 193 | (at level 0, f at level 99, format "{ 'homo' 'bot' f }") : type_scope. 194 | End Syntax. 195 | 196 | End Bottom. 197 | 198 | Export Bottom.Exports. 199 | Export Bottom.Def. 200 | Export Bottom.Syntax. 201 | 202 | 203 | Definition nat_inhMixin := @Inhabited.Mixin nat _ 0. 204 | Canonical nat_inhType := Eval hnf in InhType nat tt nat_inhMixin. 205 | 206 | Definition prod_inhMixin {dT dU} (T : inhType dT) (U : inhType dU) := 207 | @Inhabited.Mixin _ _ (inh : T, inh : U). 208 | Canonical prod_inhType {dT dU dTU} (T : inhType dT) (U : inhType dU) := 209 | Eval hnf in InhType (T * U) dTU (prod_inhMixin T U). 210 | 211 | -------------------------------------------------------------------------------- /theories/lang/regmachine.v: -------------------------------------------------------------------------------- 1 | From mathcomp Require Import ssreflect ssrfun ssrbool ssrnat seq. 2 | From mathcomp Require Import eqtype choice finfun finmap tuple. 3 | From eventstruct Require Import utils porf_eventstruct inhtype. 4 | From eventstruct Require Import transitionsystem ident. 5 | 6 | (*******************************************************************************) 7 | (* Here we want to define big-step semaintics of simple register machine in *) 8 | (* terms of porf_eventstruct *) 9 | (* This file contains definition of: *) 10 | (* instr == regmachine instructions *) 11 | (* seqprog == sequence on instructions ie. one thread of program *) 12 | (* parprog == consurent program (contains several threads) *) 13 | (* thrd_state == state of one thread: pair of our place in program (ie. line *) 14 | (* number) and map from registers to values *) 15 | (* init_state == initial state of one thread : pair of 0 default map that *) 16 | (* maps all registers to default value *) 17 | (* config == configuration of program: pair of porf_eventstruct *) 18 | (* corresponding to our program in current state and map form *) 19 | (* elements of this event structure to corresponding thread states *) 20 | (* thrd_sem == if we are in some thread state we can make one step in program *) 21 | (* and obtain side effect (action on shared locals) and a new thread state *) 22 | (* But if we want to read from shared memory, in general we can do it in *) 23 | (* defferent ways. So as a read-from-shared-memory-side effect we return *) 24 | (* Read x __ ie. read with hole instead of read value. And as a mapping *) 25 | (* from registers to values we return somehow codded function hole *) 26 | (* ltr_thrd_sem == version of thrd_sem as labeled relation *) 27 | (* es_seq == takes event structure `es`, location `x`, predsessor event *) 28 | (* `pr` and returns sequence of `es + Read x v`, where v runs on all *) 29 | (* values `v` that we can read in location `x` *) 30 | (* ces_seq_aux == all dom_consistent exec_eventstructures from es_seq. In *) 31 | (* other words if `es_seq` returns all event structures that we can *) 32 | (* obtain adding new element to our old event structure, then *) 33 | (* `ces_seq_aux` is the sequence of only `dom_consistent` event *) 34 | (* structures from `es_seq` *) 35 | (* ces_seq == ces_seq_aux mapped by Consist (doing so we are obtaining *) 36 | (* cexec_eventstructures form consistentent exec_eventstructures) *) 37 | (* add_hole == takes `es`, label with hole `l` (look thrd_sem), *) 38 | (* predsessor event `pr` and return seq `es + l` where l runs on all labels *) 39 | (* that can be obtained by filling the hole in `l` *) 40 | (* fresh_tid == returns smallest number of thread that wasn't started in *) 41 | (* the current configuration *) 42 | (* eval_step == takes config `c`, event `pr` and retunrs seq of *) 43 | (* configurations `c'` that can be reach form `c` making a step *) 44 | (* in thread state corresponding to `pr` in `c` *) 45 | (*******************************************************************************) 46 | 47 | Set Implicit Arguments. 48 | Unset Strict Implicit. 49 | Unset Printing Implicit Defensive. 50 | 51 | Section RegMachine. 52 | 53 | Open Scope fmap_scope. 54 | Open Scope exec_eventstruct_scope. 55 | 56 | Import Label.Syntax. 57 | 58 | Context {E : identType} {dV : unit} {Val : inhType dV}. 59 | 60 | (*Notation n := (@n val).*) 61 | (*Notation porf_event_struct := (porf_eventstruct E Val). 62 | Notation prime_porf_event_struct := (prime_porf_eventstruct E Val).*) 63 | 64 | (*Notation lab := (@lab val).*) 65 | Notation __ := (tt). 66 | 67 | (* Registers --- thread local variables *) 68 | Definition Reg := nat. 69 | 70 | (* Thread identifiers *) 71 | Definition Tid := nat. 72 | 73 | 74 | (* Instruction Set *) 75 | Inductive instr := 76 | | WriteReg of Val & Reg 77 | | ReadLoc of Reg & Loc 78 | | WriteLoc of Val & Loc 79 | | CJmp of Reg & Addr 80 | | Fork of Tid & Addr 81 | | Join of Tid 82 | | Exit. 83 | 84 | Definition prog := seq instr. 85 | 86 | Context (pgm : prog). 87 | 88 | Definition empty_prog : prog := [::]. 89 | 90 | Record thrd_state := Thrd_state { 91 | ip : nat; 92 | regmap :> {fsfun Reg -> Val with inh} 93 | }. 94 | 95 | Definition eq_thrd_state st st' := 96 | (ip st == ip st') && (regmap st == regmap st'). 97 | 98 | Lemma eqthrd_stateP : Equality.axiom eq_thrd_state. 99 | Proof. 100 | by move=> [??] [??]; apply: (iffP andP)=> /= [[/eqP + /eqP]|[]] => <-<-. 101 | Qed. 102 | 103 | Canonical thrd_state_eqMixin := EqMixin eqthrd_stateP. 104 | Canonical thrd_state_eqType := 105 | Eval hnf in EqType thrd_state thrd_state_eqMixin. 106 | 107 | Definition state0 : thrd_state := {| ip := 0; regmap := [fsfun with inh] |}. 108 | 109 | Import Label.Syntax. 110 | 111 | Notation Lab := (@Lab Val Val). 112 | 113 | Definition ltr_thrd_sem (l : Lab) st1 st2 : bool := 114 | let ip1 := ip st1 in 115 | let ip2 := ip st2 in 116 | let r1 := regmap st1 in 117 | let r2 := regmap st1 in 118 | (ip1 <= size pgm) && 119 | match l, nth Exit pgm (ip st1) with 120 | | Idle , WriteReg v r => 121 | [&& ip2 == ip1.+1 & r2 == [fsfun r1 with r |-> v]] 122 | | Read x a , ReadLoc r y => 123 | [&& ip2 == ip1.+1, x == y & r2 == [fsfun r1 with r |-> a]] 124 | | Write x a , WriteLoc b y => 125 | [&& ip2 == ip1.+1, x == y, a == b & r2 == r1] 126 | | Idle , CJmp r n => 127 | [&& ip2 == if r1 r != inh then n else ip1.+1 & r2 == r1] 128 | | ThreadEnd _ , Exit => 129 | [&& ip2 == size pgm & r2 == r1] 130 | | ThreadFork j m, Fork i n => 131 | [&& ip2 == ip1.+1, i == j, n == m & r2 == r1] 132 | | ThreadStart _ n, _ => 133 | [&& ip2 == n & r2 == r1] 134 | | ThreadJoin j , Join i => 135 | [&& ip2 == ip1.+1, i == j & r2 == r1] 136 | | Eps , _ => st2 == st1 137 | | Init , _ => st2 == st1 138 | | _ , _ => false 139 | end. 140 | 141 | Definition label := (Lab * thrd_state * thrd_state)%type. 142 | 143 | Inductive tr_label := Tr st of ltr_thrd_sem st.1.1 st.1.2 st.2. 144 | 145 | Arguments Tr {_}. 146 | 147 | Coercion label_of (l : tr_label) := 148 | let '(Tr st _) := l in st. 149 | 150 | Canonical tr_subType := [subType for label_of]. 151 | 152 | Definition tr_eqMixin := Eval hnf in [eqMixin of tr_label by <:]. 153 | Canonical tr_eqType := Eval hnf in EqType tr_label tr_eqMixin. 154 | 155 | Lemma label_inj : injective (label_of). 156 | Proof. exact: val_inj. Qed. 157 | 158 | Definition lab_po_synch : rel tr_label := 159 | fun (l1 l2 : tr_label) => l1.2 == l2.1.2. 160 | 161 | Definition lab_rf_synch : rel tr_label := 162 | fun (l1 l2 : tr_label) => 163 | let: (lb1, st1, _) := val l1 in 164 | let: (lb2, st2, _) := val l2 in 165 | (lb1 \>> lb2) && 166 | if lb1 is ThreadFork _ _ then 167 | st1 == st2 168 | else true. 169 | 170 | Lemma ltr_sem_eps : ltr_thrd_sem Eps state0 state0. 171 | Proof. exact/eq_refl. Qed. 172 | 173 | Lemma ltr_sem_init : ltr_thrd_sem Init state0 state0. 174 | Proof. exact/eq_refl. Qed. 175 | 176 | Definition label_labMixin := 177 | @Lab.Mixin 178 | tr_label 179 | _ 180 | lab_po_synch 181 | lab_rf_synch 182 | (@Tr (Eps, state0, state0) ltr_sem_eps) 183 | (@Tr (Init, state0, state0) ltr_sem_eps) 184 | erefl 185 | (eq_refl _) 186 | erefl 187 | (eq_refl _) 188 | erefl. 189 | 190 | Canonical label_labType := Eval hnf in LabType tr_label label_labMixin. 191 | 192 | Notation porf_eventstruct := (@porf_eventstruct E label_labType). 193 | Notation prime_porf_eventstruct := (@prime_porf_eventstruct E label_labType). 194 | 195 | End RegMachine. 196 | 197 | -------------------------------------------------------------------------------- /theories/lang/relaxed.v: -------------------------------------------------------------------------------- 1 | From Coq Require Import Relations. 2 | From RelationAlgebra Require Import lattice monoid rel boolean kat_tac. 3 | From mathcomp Require Import ssreflect ssrbool ssrfun ssrnat seq tuple. 4 | From mathcomp Require Import eqtype choice order generic_quotient. 5 | From mathcomp Require Import fintype finfun finset fingraph finmap zify. 6 | From eventstruct Require Import utils rel rel_algebra inhtype ident order. 7 | From eventstruct Require Import lts lposet pomset pomset_lts. 8 | 9 | Set Implicit Arguments. 10 | Unset Strict Implicit. 11 | Unset Printing Implicit Defensive. 12 | 13 | Local Open Scope order_scope. 14 | Local Open Scope fset_scope. 15 | Local Open Scope ident_scope. 16 | Local Open Scope lposet_scope. 17 | Local Open Scope pomset_scope. 18 | 19 | Module Lab. 20 | 21 | Module Lab. 22 | Section ClassDef. 23 | Record mixin_of (T0 : Type) (b : Inhabited.class_of T0) 24 | (T := Inhabited.Pack Bottom.disp b) := Mixin { 25 | com : {fset T} -> T -> bool; 26 | cf : rel T; 27 | is_write : pred T; 28 | is_read : pred T; 29 | _ : forall w, reflect (exists ws r, com ws r /\ w \in ws) (is_write w); 30 | _ : forall r, reflect (exists ws, com ws r ) (is_read r); 31 | _ : ~~ is_write bot; 32 | _ : ~~ is_read bot; 33 | }. 34 | 35 | Set Primitive Projections. 36 | Record class_of (T : Type) := Class { 37 | base : Inhabited.class_of T; 38 | mixin : mixin_of base; 39 | }. 40 | Unset Primitive Projections. 41 | 42 | Local Coercion base : class_of >-> Inhabited.class_of. 43 | 44 | Structure type := Pack { sort; _ : class_of sort }. 45 | 46 | Local Coercion sort : type >-> Sortclass. 47 | 48 | Variables (T : Type) (cT : type). 49 | 50 | Definition class := let: Pack _ c as cT' := cT return class_of cT' in c. 51 | Definition clone c of phant_id class c := @Pack T c. 52 | 53 | Definition pack := 54 | fun b bT & phant_id (@Inhabited.class Bottom.disp bT) b => 55 | fun m => Pack (@Class T b m). 56 | 57 | Definition eqType := @Equality.Pack cT class. 58 | Definition choiceType := @Choice.Pack cT class. 59 | Definition botType := @Inhabited.Pack Bottom.disp cT class. 60 | End ClassDef. 61 | 62 | Module Exports. 63 | Coercion base : class_of >-> Inhabited.class_of. 64 | Coercion mixin : class_of >-> mixin_of. 65 | Coercion sort : type >-> Sortclass. 66 | Coercion eqType : type >-> Equality.type. 67 | Coercion choiceType : type >-> Choice.type. 68 | Coercion botType : type >-> Inhabited.type. 69 | Canonical eqType. 70 | Canonical choiceType. 71 | Canonical botType. 72 | Notation labType := type. 73 | Notation LabType T m := (@pack T _ _ id m). 74 | End Exports. 75 | 76 | End Lab. 77 | 78 | Export Lab.Exports. 79 | 80 | Variant typ := Read | Write | ReadWrite | Undef. 81 | 82 | Definition eq_typ : rel typ := 83 | fun t1 t2 => match t1, t2 with 84 | | Read , Read => true 85 | | Write , Write => true 86 | | ReadWrite, ReadWrite => true 87 | | Undef , Undef => true 88 | | _ , _ => false 89 | end. 90 | 91 | Lemma eq_typP : Equality.axiom eq_typ. 92 | Proof. by case; case; constructor. Qed. 93 | 94 | Module Export Def. 95 | Section Def. 96 | Context {L : labType}. 97 | Implicit Types (l : L). 98 | 99 | Definition com : {fset L} -> L -> bool := Lab.com (Lab.class L). 100 | 101 | Definition cf : rel L := Lab.cf (Lab.class L). 102 | 103 | Definition is_write : pred L := Lab.is_write (Lab.class L). 104 | Definition is_read : pred L := Lab.is_read (Lab.class L). 105 | 106 | Canonical typ_eqMixin := EqMixin eq_typP. 107 | Canonical typ_eqType := Eval hnf in EqType typ typ_eqMixin. 108 | 109 | Definition lab_typ l : typ := 110 | if is_read l && ~~ is_write l then 111 | Read 112 | else if is_write l && ~~ is_read l then 113 | Write 114 | else if is_read l && is_write l then 115 | ReadWrite 116 | else Undef. 117 | 118 | End Def. 119 | End Def. 120 | 121 | Module Export Syntax. 122 | Notation "ls '|-' l" := (com ls l) (at level 90). 123 | Notation "l1 '\#' l2" := (cf l1 l2) (at level 90). 124 | End Syntax. 125 | 126 | Module Export Theory. 127 | Section Theory. 128 | Context (L : labType). 129 | Implicit Types (l r w: L). 130 | 131 | Lemma is_writeP w : 132 | reflect (exists ws r, com ws r /\ w \in ws) (is_write w). 133 | Proof. by move: w; case L=> ? [? []]. Qed. 134 | 135 | Lemma is_readP r : 136 | reflect (exists ws, com ws r) (is_read r). 137 | Proof. by move: r; case L=> ? [? []]. Qed. 138 | 139 | Lemma bot_nwrite : 140 | ~~ is_write (bot : L). 141 | Proof. by case L=> ? [? []]. Qed. 142 | 143 | Lemma bot_nread : 144 | ~~ is_read (bot : L). 145 | Proof. by case L=> ? [? []]. Qed. 146 | 147 | End Theory. 148 | End Theory. 149 | 150 | End Lab. 151 | 152 | Export Lab.Lab.Exports. 153 | Export Lab.Def. 154 | Export Lab.Syntax. 155 | Export Lab.Theory. 156 | 157 | 158 | Module Export ThrdPomset. 159 | 160 | Notation thrd_pomset E L Tid := 161 | (@pomset E (prod_inhType Tid L)). 162 | 163 | Notation thrd_pomlang E L Tid := 164 | (@pomlang E (prod_inhType Tid L)). 165 | 166 | Section Def. 167 | Context {E : identType} {L : labType}. 168 | Context {Tid : identType}. 169 | (* data-type semantics *) 170 | Context (DS : ltsType L). 171 | (* thread semantics *) 172 | Context (TS : ltsType L). 173 | Implicit Types (d : DS) (s : TS). 174 | Implicit Types (p q : @thrd_pomset E L Tid). 175 | 176 | Definition fs_tid p e := 177 | fst (fs_lab p e). 178 | 179 | Definition fs_tids p := 180 | [fset (fs_tid p e) | e in finsupp p]. 181 | 182 | Definition fs_dlab p e := 183 | snd (fs_lab p e). 184 | 185 | Definition fs_typ p e := 186 | lab_typ (fs_dlab p e). 187 | 188 | Definition dlab_defined p := 189 | [forall e : finsupp p, fs_dlab p (val e) != bot]. 190 | 191 | Definition lab_prj : Tid * L -> L := snd. 192 | 193 | Definition lts_thrd_pomlang d : thrd_pomlang E L Tid := 194 | fun p => (lts_pomlang d : pomlang E L) (Pomset.relabel lab_prj p). 195 | 196 | Definition respects_com d : thrd_pomlang E L Tid := 197 | fun p => forall e, exists (es : {fset E}), 198 | [/\ (fs_dlab p) @` es |- (fs_dlab p e) 199 | & forall e', e' \in es -> e' <= e :> [Event of p] 200 | ]. 201 | 202 | Definition cf_commute d := forall (u v : seq L) (a b : L), 203 | let Dlang := lts_lang d in 204 | ~ (a \# b) -> (Dlang (u ++ [:: a ; b] ++ v) <-> Dlang (u ++ [:: b ; a] ++ v)). 205 | 206 | Lemma lab_prj_bot : 207 | lab_prj (\i0, bot) = bot. 208 | Proof. done. Qed. 209 | 210 | End Def. 211 | 212 | End ThrdPomset. 213 | 214 | Section ProgramOrder. 215 | Context {E : identType} {L : labType}. 216 | Context {Tid : identType}. 217 | (* thread semantics *) 218 | Context (TS : ltsType L). 219 | Implicit Types (p q : @thrd_pomset E L Tid). 220 | 221 | Definition eq_tid p : rel E := 222 | fun e1 e2 => fs_tid p e1 == fs_tid p e2. 223 | 224 | Arguments eq_tid p : clear implicits. 225 | 226 | Lemma eqtid_refl p : reflexive (eq_tid p). 227 | Proof. by rewrite /eq_tid. Qed. 228 | 229 | Lemma eqtid_sym p : symmetric (eq_tid p). 230 | Proof. by rewrite /eq_tid. Qed. 231 | 232 | Lemma eqtid_trans p : transitive (eq_tid p). 233 | Proof. by rewrite /eq_tid=> ??? /eqP-> /eqP->. Qed. 234 | 235 | Definition po p : thrd_pomset E L Tid := 236 | Pomset.inter_rel (eq_tid p) (@eqtid_refl p) (@eqtid_trans p) p. 237 | 238 | Definition po_spec p := 239 | {in (fs_tids p), forall t, exists (s0 : TS), 240 | let es := [fset e | e in finsupp p & (fs_tid p e == t)] in 241 | let pt := Pomset.restrict (mem es) p in 242 | (lts_pomlang s0 : pomlang E L) (Pomset.relabel lab_prj pt) 243 | }. 244 | 245 | End ProgramOrder. 246 | 247 | 248 | Section SeqCst. 249 | Context {E : identType} {L : labType}. 250 | Context {Tid : identType}. 251 | (* data-type semantics *) 252 | Context (DS : ltsType L). 253 | (* thread semantics *) 254 | Context (TS : ltsType L). 255 | 256 | Implicit Types (d : DS) (s : TS). 257 | Implicit Types (p q : @thrd_pomset E L Tid). 258 | 259 | Definition seq_cst d p := 260 | eq (po p) \supports (lts_thrd_pomlang d). 261 | 262 | End SeqCst. 263 | 264 | (* TODO: better name? *) 265 | Section ValueRelab. 266 | Context {E : identType} {L : labType}. 267 | Context {Tid : identType}. 268 | (* data-type semantics *) 269 | Context (DS : ltsType L). 270 | (* thread semantics *) 271 | Context (TS : ltsType L). 272 | Implicit Types (p : @thrd_pomset E L Tid). 273 | 274 | (* checks that f is a value-relabeling of pomset p w.r.t. set of events es *) 275 | Definition relab_mod p (es : {fset E}) (f : Tid * L -> L) := 276 | let lab e := fs_lab p (val e) in 277 | let dlab e := fs_dlab p (val e) in 278 | [&& (* types of all events are preserved (i.e. reads/writes are preserved) *) 279 | [forall e : finsupp p, lab_typ (f (lab e)) == lab_typ (dlab e)] 280 | , (* conflict relation is preserved *) 281 | [forall e1 : finsupp p, forall e2 : finsupp p, 282 | (f (lab e1) \# f (lab e2)) == ((dlab e1) \# (dlab e2)) 283 | ] 284 | & (* labels of all events not in es are preserved *) 285 | [forall e : finsupp p, (val e \notin es) ==> (f (lab e) == dlab e)] 286 | ]. 287 | 288 | End ValueRelab. 289 | 290 | 291 | Section CausalCst. 292 | Context {E : identType} {L : labType}. 293 | Context {Tid : identType}. 294 | (* data-type semantics *) 295 | Context (DS : ltsType L). 296 | (* thread semantics *) 297 | Context (TS : ltsType L). 298 | 299 | Implicit Types (d : DS) (s : TS). 300 | Implicit Types (p : @thrd_pomset E L Tid). 301 | 302 | (* Causally relabeled threaded pomset language of data-structure DS. 303 | * Pomset p belongs to this language if 304 | * for every event e of p, the restriction of p onto prefix of e 305 | * is equiavelnt to relabeling of some q \in (lang DS) such that this relabeling 306 | * (1) preserves labels of all events from the thread of e 307 | * and all writes events (i.e. non-reads); 308 | * (2) preserves types (i.e. reads/writes) of all events. 309 | *) 310 | Definition causal d p := 311 | {in (finsupp p), forall e, exists f, 312 | let rst := pideal (e : [Event of p]) in 313 | let ro := 314 | [fset e' in finsupp p | (fs_typ p e' == Lab.Read) && ~~ (eq_tid p e e')] 315 | in 316 | let p_rlb := Pomset.relabel f p in 317 | let p_rst := Pomset.restrict (mem rst) p_rlb in 318 | [/\ relab_mod p ro f 319 | & eq (p_rst) \supports (lts_pomlang d : pomlang E L) 320 | ] 321 | }. 322 | 323 | Definition causal_cst d p := 324 | eq (po p) \supports (causal d). 325 | 326 | 327 | End CausalCst. 328 | 329 | 330 | Section PipeCst. 331 | Context {E : identType} {L : labType}. 332 | Context {Tid : identType}. 333 | (* data-type semantics *) 334 | Context (DS : ltsType L). 335 | (* thread semantics *) 336 | Context (TS : ltsType L). 337 | 338 | Implicit Types (d : DS) (s : TS). 339 | Implicit Types (p : @thrd_pomset E L Tid). 340 | 341 | Definition pipe_cst d p := 342 | {in (fs_tids p), forall t, exists f, 343 | let prv := 344 | [fset e' in finsupp p | (fs_tid p e' == t) || ~~ is_read (fs_dlab p e')] 345 | in 346 | let po_rlb := Pomset.relabel f (po p) in 347 | [/\ relab_mod p prv f 348 | & eq po_rlb \supports (lts_pomlang d : pomlang E L) 349 | ] 350 | }. 351 | 352 | End PipeCst. 353 | -------------------------------------------------------------------------------- /theories/common/rewriting_system.v: -------------------------------------------------------------------------------- 1 | From RelationAlgebra Require Import lattice monoid rel kat_tac kat kleene. 2 | From mathcomp Require Import ssreflect ssrbool ssrfun eqtype choice. 3 | From eventstruct Require Import utils rel_algebra. 4 | 5 | (*****************************************************************************) 6 | (* exlaberal theory of rewriting systems *) 7 | (* inspired by "Term Rewriting and All That" *) 8 | (* Fisrt section called Commutation. Here the theory of exlaberal rewriting *) 9 | (* systems with two rewriting rules derived: *) 10 | (* We define several properties of rewriting systems and prove some *) 11 | (* relationships between them *) 12 | (* diamond_commute (~>) (>>) == ∀ s1 s2 s3 *) 13 | (* s1 ~> s2 *) 14 | (* v v *) 15 | (* v v *) 16 | (* s3 ~> s4 - exists *) 17 | (* *) 18 | (* strong_commute (~>) (>>) == ∀ s1 s2 s3 *) 19 | (* s1 ~> s2 *) 20 | (* v v *) 21 | (* v v *) 22 | (* ⋮ ⋮ *) 23 | (* v v *) 24 | (* v v *) 25 | (* s3 ~> s4 - exists *) 26 | (* commute (~>) (>>) == ∀ s1 s2 s3 *) 27 | (* s1 ~> ... ~> s2 *) 28 | (* v v *) 29 | (* v v *) 30 | (* ⋮ ⋮ *) 31 | (* v v *) 32 | (* v v *) 33 | (* s3 ~> ... ~> s4 - exists *) 34 | (* diamond_confluent (~>) == diamond_commute (~>) (~>) *) 35 | (* confluence (~>) == commute (~>) (~>) *) 36 | (* dcomm_comm <-> commuting_diamond_prop (~>) (>>)*) 37 | (* implies commute (~>) (>>) *) 38 | (* dconfl_confl <-> diamond_confluent (~>) implies *) 39 | (* confluence (~>) *) 40 | (* In the EqvRewriting we have the exlaberal theory of the rewriting system *) 41 | (* with some equivalence relation. *) 42 | (* eqv_diamond_confluent (~>) (~~) == version of the diamond property for *) 43 | (* the rewriting systems with equivalence: it states *) 44 | (* that s1 ~> s2 and s1 ~> s3 implies existance of *) 45 | (* some s4 and s4' s.t. s2 ~> s4, s3 ~> s4' and *) 46 | (* s4 ~~ s4'. *) 47 | (* eqv_confluent (~>) (~~) == the confluence principle for the *) 48 | (* rewriting systems with an equivalence relation: *) 49 | (* s1 ~>⁺ s2 | *) 50 | (* | ==> exists s4 ~~ s4' s.t. s2 ~>⁺ s4 and s3 ~>⁺ s4'*) 51 | (* s1 ~>⁺ s3 | *) 52 | (* confl_eqv <-> diamond_commute (~>) (~~) with *) 53 | (* eqv_diamond_confluent (~>) (~~) implies *) 54 | (* eqv_confluent (~>) (~~) *) 55 | (* In the EqvLabRewriting we proved the analogue of Commuation Union Lemma *) 56 | (* Originally this lemma states that if one have two relations ~> and >> and *) 57 | (* they statisfy diamond_commute (~>) (>>), then (~> ∪ >>) is confluent. *) 58 | (* But want to exlaberalize this lemma in two steps: *) 59 | (* 1) let us have an arbitrary number of relations -- we model it by *) 60 | (* consindering one labeling relation: r : L -> hrel S S, where L is an *) 61 | (* arbitrary label Type *) 62 | (* 2) let us parametrize this lemma with some equivalence relation *) 63 | (* Let L and S be some types and r : L -> hrel S S *) 64 | (* eqv_diamond_commute (~>) (>>) (~~) == version of the diamond property for *) 65 | (* the rewriting systems with equivalence: it states *) 66 | (* that s1 ~> s2 and s1 ~> s3 implies existance of *) 67 | (* some s4 and s4' s.t. s2 ~> s4, s3 ~> s4' and *) 68 | (* that s1 ~> s2 and s1 >> s3 implies existance of *) 69 | (* some s4 and s4' s.t. s2 ~> s4, s3 >> s4' and *) 70 | (* exlab r s1 s2 == ∃ l, s.t. r l s1 s2 holds *) 71 | (* eqv_diamoind_commute r e <-> if forall two labels l₁ l₂ we now *) 72 | (* that eqv_diamond_commute (r l1) (r l2) (~~) and *) 73 | (* diamond_commute (exlab r) (~~) than exlab r is *) 74 | (* conluent w.r.t (~~) i.e eqv_confluent (exlab r) (~~)*) 75 | (* Consider we have some labeled relation r (statisfying all properties *) 76 | (* above), and some equivalence ~~. If r has type L -> hrel S S, and T is a *) 77 | (* S's subType, forall relation rel : hrel S S we can define *) 78 | (* sub rel == contranction of rel to the sub-type T *) 79 | (* so clearly we can define a labeled rewriting system with an equivalence *) 80 | (* relation structure on T (with relations `sub ∘ r` and `sub (~~)`). *) 81 | (* The question is: when such subsystem is confluent? In the SubRewriting *) 82 | (* section we are trying to answer on this question. *) 83 | (* Let T : subType p, for some p : pred S, with s1, s2,... we will denote the*) 84 | (* variables of type S, and with t1, t2,... we will denote the variables *) 85 | (* of type T *) 86 | (* eqv_restpect_p (~~) <-> if t ~~ s then p s holds *) 87 | (* r_respects_p (r) <-> if for some labels l1, l2, r l2 t1 t2, *) 88 | (* r l1 t1 t3, then for all s s.t. r l2 t3 s we have *) 89 | (* that p s holds *) 90 | (* sub_eqv_comm_union r (~~) <-> it two properties above holds than *) 91 | (* eqv_confluent (exlab (sub ∘ r)) (sub ~~) *) 92 | (*****************************************************************************) 93 | 94 | Local Open Scope rel_scope. 95 | 96 | Section Commutation. 97 | 98 | Context {S : Type} (r1 r2 : hrel S S). 99 | 100 | Definition diamond_commute := forall s1 s2 s3, 101 | r1 s1 s2 -> r2 s1 s3 -> exists2 s4, r2 s2 s4 & r1 s3 s4. 102 | 103 | Definition strong_commute := forall s1 s2 s3, 104 | r1 s1 s2 -> r2^+ s1 s3 -> exists2 s4 : S, r2^+ s2 s4 & r1 s3 s4. 105 | 106 | Definition commute := forall s1 s2 s3, 107 | r1^+ s1 s2 -> r2^+ s1 s3 -> exists2 s4, r2^+ s2 s4 & r1^+ s3 s4. 108 | 109 | Lemma dcomm_scomm : 110 | diamond_commute -> strong_commute. 111 | Proof. 112 | move=> diamond s1 s2 s3 + str; move: str s2. 113 | suff: (r2^+ \<= (fun s1 s3 => forall s2 : S, r1 s1 s2 -> exists2 s4 : S, r2^+ s2 s4 & r1 s3 s4)). 114 | - exact. 115 | apply/itr_ind_l1=> {s1 s3} [?? /diamond d ? /d[x /(itr_ext r2) *]|s1 s3 /=]. 116 | - by exists x. 117 | move=> [? /diamond d IH ? /d[x ? /IH[y *]]]; exists y=> //. 118 | apply/(itr_cons r2); by exists x. 119 | Qed. 120 | 121 | Lemma dcomm_comm : 122 | diamond_commute -> commute. 123 | Proof. 124 | move=> d s1 s2 s3. 125 | move: s3=> /[swap]. 126 | suff: (r1^+ \<= (fun s1 s2 => forall s3, r2^+ s1 s3 -> exists2 s4, r2^+ s2 s4 & r1^+ s3 s4)). 127 | - exact. 128 | apply/itr_ind_l1=> {s1 s2} [?? s ? |s1 s2 /= [s5 /(dcomm_scomm d) c IH s3 /c]]. 129 | - case/(dcomm_scomm d _ _ _ s)=> x ? /(itr_ext r1) ?; by exists x. 130 | case=> s6 /IH[s4 *]; exists s4=> //; apply/(itr_cons r1); by exists s6. 131 | Qed. 132 | 133 | End Commutation. 134 | 135 | Arguments dcomm_scomm {_ _ _}. 136 | Arguments dcomm_comm {_ _ _}. 137 | 138 | 139 | Section Confluence. 140 | 141 | Context {S : Type} (r : hrel S S). 142 | 143 | Definition diamond_confluent := forall s1 s2 s3, 144 | r s1 s2 -> r s1 s3 -> exists2 s4, r s2 s4 & r s3 s4. 145 | 146 | Definition confluent := forall s1 s2 s3, 147 | r^+ s1 s2 -> r^+ s1 s3 -> exists2 s4, r^+ s2 s4 & r^+ s3 s4. 148 | 149 | Lemma dconfl_confl : diamond_confluent -> confluent. 150 | Proof. exact/dcomm_comm. Qed. 151 | 152 | End Confluence. 153 | 154 | Arguments dconfl_confl {_ _}. 155 | 156 | Section EqvRewriting. 157 | 158 | Context {S : Type} (r e : hrel S S). 159 | 160 | Hypothesis eqv_trans : Transitive e. 161 | Hypothesis eqv_symm : Symmetric e. 162 | Hypothesis eqv_refl : 1 \<= e. 163 | 164 | Definition eqv_diamond_confluent := forall s1 s2 s3, 165 | r s1 s2 -> r s1 s3 -> 166 | exists s4 s4', [/\ r s2 s4, r s3 s4' & e s4 s4']. 167 | 168 | Definition eqv_confluent := forall s1 s2 s3, 169 | r^+ s1 s2 -> r^+ s1 s3 -> 170 | exists s4 s4', [/\ r^+ s2 s4, r^+ s3 s4' & e s4 s4']. 171 | 172 | Hypothesis edconfl : eqv_diamond_confluent. 173 | Hypothesis edcomm : diamond_commute e r. 174 | 175 | Lemma dcomm_rw_rw_eqv : diamond_commute r (r ⋅ e). 176 | Proof. 177 | move=> s1 s2 s3 /= /edconfl D [s3' {D}/D[s4'' [s4' [? R ? /edcomm]]]]. 178 | case/(_ _ R)=> x ??; exists x=> //; exists s4''=> //; exact/(eqv_trans _ s4'). 179 | Qed. 180 | 181 | Lemma scomm_rw_eqv : strong_commute e r. 182 | Proof. 183 | move=> s1 s2 s3 /[swap]. 184 | have: e^+ \== e. 185 | - apply/(antisym _ _ _ (itr_ext e))/itr_ind_l1=> // [??[?]]; exact/eqv_trans. 186 | move=> E /(dcomm_comm edcomm) H /E /H [x ??]; exists x=> //; exact/E. 187 | Qed. 188 | 189 | Lemma rw_eqv_itr : (r ⋅ e)^+ \== r^+ ⋅ e. 190 | Proof. 191 | apply/(antisym (r ⋅ e)^+ )=> [|s1 s2 [x ]]. 192 | apply/itr_ind_l1=> [|s1 s3 [s2 [x + /eqv_symm R [y /scomm_rw_eqv-/(_ _ R)]]]]. 193 | - exact/(dot_leq (itr_ext r) (leq_Reflexive e)). 194 | move=> s [s5 ? /eqv_symm/eqv_trans t/t ?]; exists s5=> //. 195 | apply/(itr_cons r); by exists x. 196 | suff: (r^+ \<= (fun s1 x => e x s2 -> (r ⋅ e)^+ s1 s2)). 197 | - exact. 198 | apply/itr_ind_l1=> {s1 x} [s1 x ?? |s1 x /= [y ? /[apply] ?]]. 199 | - apply/(itr_ext (r ⋅ e)); by exists x. 200 | apply/(itr_cons (r ⋅ e)); do ? exists y=> //; exact/eqv_refl. 201 | Qed. 202 | 203 | Theorem confl_eqv : eqv_confluent. 204 | Proof. 205 | move=> s1 s2 s3. 206 | move/(dcomm_comm dcomm_rw_rw_eqv) => /[swap]/[dup] _ rs. 207 | have: (r^+ ⋅ e) s1 s3. 208 | - by exists s3=> //; apply/eqv_refl. 209 | move/rw_eqv_itr=> R /(_ _ R)[x]. 210 | by case/rw_eqv_itr=> y; exists y, x. 211 | Qed. 212 | 213 | End EqvRewriting. 214 | 215 | Section EqvRRewriting. 216 | 217 | Context {S : Type} (r e : hrel S S). 218 | 219 | Hypothesis eqv_trans : Transitive e. 220 | Hypothesis eqv_symm : Symmetric e. 221 | Hypothesis eqv_refl : 1 \<= e. 222 | 223 | Definition eqv_rdiamond_confluent := forall s1 s2 s3, 224 | r s1 s2 -> r s1 s3 -> 225 | exists s4 s4', [/\ r^? s2 s4, r^? s3 s4' & e s4 s4']. 226 | 227 | Definition eqv_rconfluent := forall s1 s2 s3, 228 | r^* s1 s2 -> r^* s1 s3 -> 229 | exists s4 s4', [/\ r^* s2 s4, r^* s3 s4' & e s4 s4']. 230 | 231 | Hypothesis edconfl : eqv_rdiamond_confluent. 232 | Hypothesis edcomm : diamond_commute e r. 233 | 234 | Theorem rconfl_eqv : eqv_rconfluent. 235 | Proof. 236 | suff: eqv_confluent (r^?) e. 237 | - move=> C ???; rewrite !(str_itr r _ _) !(itr_qmk r _ _). 238 | move=>/C/[apply][[s4 [s4' [*]]]]; exists s4, s4'. 239 | by split=> //; rewrite !(str_itr r _ _) !(itr_qmk r _ _). 240 | apply/confl_eqv=> //. 241 | - move=> s1 s2 s3 [-> [->| ?]|R [<-|/(edconfl _ _ _ R)]] //. 242 | - exists s3, s3; split; by [left|left|apply/eqv_refl]. 243 | - exists s3, s3; split; by [right|left|apply/eqv_refl]. 244 | exists s2, s2; split; by [left|right|apply/eqv_refl]. 245 | move=> ? s2 ? E [<-|/edcomm-/(_ _ E)[s4 *]]. 246 | - exists s2=> //; by left. 247 | exists s4=> //; by right. 248 | Qed. 249 | 250 | 251 | End EqvRRewriting. 252 | 253 | Definition exlab {T L : Type} (r : L -> hrel T T) : hrel T T := 254 | fun t1 t2 => exists l, r l t1 t2. 255 | 256 | 257 | Section EqvLabRewriting. 258 | 259 | Context {S L : Type} (r : L -> hrel S S) (e : hrel S S). 260 | 261 | Hypothesis eqv_trans : Transitive e. 262 | Hypothesis eqv_symm : Symmetric e. 263 | Hypothesis eqv_refl : 1 \<= e. 264 | 265 | Definition eqv_diamond_commute (r r2 e : hrel S S) := forall s1 s2 s3, 266 | r s1 s2 -> r2 s1 s3 -> 267 | exists s4 s4', [/\ r2 s2 s4, r s3 s4' & e s4 s4']. 268 | 269 | Definition eqv_rdiamond_commute (r r2 e : hrel S S) := forall s1 s2 s3, 270 | r s1 s2 -> r2 s1 s3 -> 271 | exists s4 s4', [/\ r2^? s2 s4, r^? s3 s4' & e s4 s4']. 272 | 273 | 274 | Hypothesis ledrr : forall l1 l2, (eqv_rdiamond_commute (r l1) (r l2) e). 275 | Hypothesis leder : diamond_commute e (exlab r). 276 | 277 | Lemma rexlab : exlab (fun l => (r l)^?) \<= (exlab r)^?. 278 | Proof. move=> ?? /= [l [->|]]; [left|right] =>//; by exists l. Qed. 279 | 280 | 281 | Theorem eqv_comm_union : eqv_rconfluent (exlab r) e. 282 | Proof. 283 | apply/rconfl_eqv => // ???[l1 /ledrr C [l2 /C [s4 [s4' [*]]]]]. 284 | - exists s4, s4'; do ? split=> //; apply/rexlab; by [exists l2| exists l1]. 285 | Qed. 286 | 287 | End EqvLabRewriting. 288 | 289 | Section EqRewritng. 290 | 291 | Context {S : Type}. 292 | 293 | Global Instance dcomm_weq: Proper 294 | ((weq : relation (hrel S S)) ==> (weq : relation (hrel S S)) ==> iff) 295 | diamond_commute. 296 | Proof. 297 | move=> r1 r2 e12 r3 r4 e34; split=> D x y z /e12 + /e34; 298 | by move=> /D/[apply] [[z']] /e34 ? /e12 ?; exists z'. 299 | Qed. 300 | 301 | Global Instance eq_rconfl_weq: Proper 302 | ((weq : relation (hrel S S)) ==> (weq : relation (hrel S S)) ==> iff) 303 | eqv_rconfluent. 304 | Proof. 305 | move=> r1 r2 e12 r3 r4 e34; split=> C x y z; 306 | move=> /(str_weq e12) + /(str_weq e12); 307 | move=> /C/[apply] [[y' [z' []]]] ?? /e34 ?; 308 | exists y', z'; split=> //; exact/(str_weq e12). 309 | Qed. 310 | 311 | End EqRewritng. 312 | 313 | Section SubRewriting. 314 | 315 | Local Open Scope ra_terms. 316 | 317 | Context {S: eqType} {L : Type}. 318 | 319 | (* rst --- restriction of a relation to a subset *) 320 | Definition rst (p : rel.dset S) (r : hrel S S) : hrel S S := 321 | r \& (p \x p). 322 | 323 | (* TODO: develop a more general theory of `rst` which would subsume 324 | * the following lemmas, and formulate it in terms of KA. 325 | * In particular, the following lemmas might be useful. 326 | * - rst p r \<= p × p 327 | * - (rst p r)^+ \<= rst p r^+ 328 | * - p \<= p' -> r \<= r' -> rst p r \<= rst p' r' (a Proper lemma) 329 | *) 330 | 331 | Lemma rst_p {p r x1 x2} : rst p r x1 x2 -> p x2. 332 | Proof. by case=> ?/andP[]. Qed. 333 | 334 | Lemma rst_itr_p {p r x1 x2} : (rst p r)^+ x1 x2 -> p x2. 335 | Proof. by rewrite itr_str_r=> [[??/rst_p]]. Qed. 336 | 337 | Lemma rst_str_p {p r x1 x2} : (rst p r)^* x1 x2 -> p x1 -> p x2. 338 | Proof. by rewrite str_itr=> [[->|/rst_itr_p]]. Qed. 339 | 340 | Context (p : rel.dset S) (r : L -> hrel S S) (e : hrel S S). 341 | 342 | Implicit Types (s : S) (l : L). 343 | 344 | Hypothesis eqv_trans : Transitive e. 345 | Hypothesis eqv_symm : Symmetric e. 346 | Hypothesis eqv_refl : 1 \<= e. 347 | 348 | Hypothesis ledrr : forall l1 l2, eqv_rdiamond_commute (r l1) (r l2) e. 349 | Hypothesis leder : diamond_commute e (exlab r). 350 | 351 | Definition eqv_respect_p := [p] ⋅ e \<= e ⋅ [p]. 352 | 353 | Definition r_respect_p := forall l1 l2 s1 s2 s3 s, 354 | s2 != s3 -> 355 | rst p (r l1) s1 s2 -> 356 | rst p (r l2) s1 s3 -> 357 | r l2 s2 s -> p s. 358 | 359 | Hypothesis eqv_p : eqv_respect_p. 360 | Hypothesis eqv_r : r_respect_p. 361 | 362 | Lemma r_exlab l: r l \<= exlab r. 363 | Proof. by exists l. Qed. 364 | 365 | Lemma rst_exlab : rst p (exlab r) \== exlab (rst p \o r). 366 | Proof. by move=> ??; split=> [[[l]]|[l[]]] /=; last split=> //; exists l. Qed. 367 | 368 | Lemma rsub l : rst p ((r l)^?) \<= ((rst p \o r) l)^? . 369 | Proof. by move=> ?? [[-> ? | ??]]; [left | right]. Qed. 370 | 371 | Lemma eqv_rr {l1 l2 s1 s2 s3 s}: 372 | s2 != s3 -> 373 | rst p (r l1) s1 s2 -> 374 | rst p (r l2) s1 s3 -> 375 | (r l2)^? s2 s -> p s. 376 | Proof. by move=> N /[dup][[? /andP[?? /eqv_r/[apply] H [<-|/(H _ N)]]]]. Qed. 377 | 378 | Theorem sub_eqv_comm_union : eqv_rconfluent (rst p (exlab r)) e. 379 | Proof. 380 | rewrite rst_exlab. 381 | apply/eqv_comm_union=> //. 382 | - move=> l1 l2 ? s2 s3; case: (boolP (s2 == s3))=> [/eqP->|N]. 383 | - exists s3, s3; split; [| |exact/eqv_refl]; by left. 384 | move=> /[dup] /(eqv_rr N) R[/ledrr] E /andP[??] /[dup]/R P[/E[s4 [x]]]. 385 | case=> /[dup] /P ps4 ?? /[dup] ?. 386 | have/eqv_p[??[->??/andP[??]]]: ([p] ⋅ e) s4 x by exists s4. 387 | exists s4, x; do ? split=> //; apply/rsub; split=> //; exact/andP. 388 | move=> s1 s2 s /= /[dup] ? /leder E [? [/r_exlab /E [x [l ?? /andP[??]]]]]. 389 | have/eqv_p[??[->?]]: ([p] ⋅ e) s x by exists s. 390 | have/eqv_p[??[->?]]: ([p] ⋅ e) s1 s2 by exists s1. 391 | exists x=> //; exists l; split=> //; exact/andP. 392 | Qed. 393 | 394 | End SubRewriting. 395 | 396 | Section SubTypeRewriting. 397 | 398 | Context {S : eqType} {L T : Type} (f : T -> S). 399 | 400 | Definition relpreim r : hrel T T := 401 | fun x y => r (f x) (f y). 402 | 403 | Context (p : rel.dset S) (r : hrel S S) (e : hrel S S) . 404 | 405 | Hypothesis im : forall x, p x -> exists y, f y = x. 406 | Hypothesis p_f : forall x, p (f x). 407 | Hypothesis f_inj : injective f. 408 | Hypothesis confl : eqv_rconfluent (rst p r) e. 409 | 410 | Lemma relpreim_itr: (relpreim (rst p r))^* \== relpreim (rst p r)^*. 411 | Proof. 412 | apply/(antisym ((relpreim (rst p r))^*)); rewrite /relpreim. 413 | - apply/str_ind_l1=> [??->|??]; first exact/(str_refl (rst p r)). 414 | by case=> x ??; apply/(str_cons (rst p r)); exists (f x). 415 | move=> a b H. move: {-2}(f b) {-2}(f a) H (erefl (f a)) (erefl (f b))=> f1 f2. 416 | move: a=> /[swap]. 417 | suff: (rst p r)^* \<= 418 | (fun f2 f1 => forall a, f a = f2 -> f b = f1 -> ((relpreim (rst p r))^* a b)). 419 | - exact. 420 | apply/str_ind_l1=> [??-> ? <- /f_inj->|??[? /[dup]]]. 421 | - exact/(str_refl (relpreim(rst p r))). 422 | move/(@rst_p _ p); case/im=> x <- ? /(_ _ erefl) H ? E /H ?. 423 | apply/(str_cons (relpreim (rst p r))). 424 | by exists x=> //; rewrite /relpreim E. 425 | Qed. 426 | 427 | Arguments p_f {_}. 428 | 429 | Lemma confl_sub : eqv_rconfluent (relpreim r) (relpreim e). 430 | Proof. 431 | have->: relpreim r \== relpreim (rst p r). 432 | - by move=> ?? /=; rewrite /rst /relpreim /= ?p_f; split=> // [[]]. 433 | move=> ??? /=. 434 | rewrite ?(relpreim_itr _ _) /relpreim=> /confl/[apply]. 435 | case=> ? [?[/[dup] /(rst_str_p)/(_ p_f)/im[s4 <- ?]]]. 436 | move/[dup]/(rst_str_p)/(_ p_f)/im=>[s4'<- ?]. 437 | exists s4, s4'; split=> //=; by rewrite relpreim_itr. 438 | Qed. 439 | 440 | End SubTypeRewriting. 441 | 442 | Section Terminal. 443 | 444 | Context {S : Type} (r e : hrel S S). 445 | 446 | Hypothesis confl : eqv_rconfluent r e. 447 | Hypothesis edcomm : diamond_commute e r. 448 | 449 | Hypothesis eqv_trans : Transitive e. 450 | Hypothesis eqv_symm : Symmetric e. 451 | Hypothesis eqv_refl : 1 \<= e. 452 | 453 | Hypothesis e_r : e \& r^+ \<= bot. 454 | 455 | (* We use categorical meaning of initial/terminal element *) 456 | Definition initial s0 := forall s, r^* s0 s. 457 | Definition terminal st := forall s, (r^* ⋅ e) s st. 458 | 459 | Context s0 (init : initial s0). 460 | 461 | Lemma terminal_max : maximal r \== terminal. 462 | Proof. 463 | rewrite maximal_str=> st; split=> [/[swap] s M|/[swap] s /(_ s) /[swap]]. 464 | - case: (confl _ _ _ (init st) (init s))=> s' [s'' [/M-> ??]]. 465 | by exists s''=> //; exact/eqv_symm. 466 | rewrite {1}str_itr=> [[]] // /[swap][[s']]. 467 | rewrite str_itr=> [[-> |?]] /eqv_symm*; exfalso; first exact/(e_r st s'). 468 | apply/(e_r st s'); split=> //; apply/(itr_trans r); by exists s. 469 | Qed. 470 | 471 | End Terminal. 472 | -------------------------------------------------------------------------------- /theories/common/order.v: -------------------------------------------------------------------------------- 1 | From RelationAlgebra Require Import lattice boolean. 2 | From mathcomp Require Import ssreflect ssrbool ssrnat ssrfun. 3 | From mathcomp Require Import eqtype choice order seq tuple path div. 4 | From mathcomp Require Import fintype finfun fingraph finmap. 5 | From eventstruct Require Import utils seq. 6 | 7 | Set Implicit Arguments. 8 | Unset Strict Implicit. 9 | Unset Printing Implicit Defensive. 10 | 11 | Import Order.Theory. 12 | 13 | Local Open Scope fset_scope. 14 | Local Open Scope order_scope. 15 | 16 | (******************************************************************************) 17 | (* Auxiliary definitions and lemmas about partial orders. *) 18 | (* *) 19 | (******************************************************************************) 20 | 21 | Section POrderUtils. 22 | Context {disp : unit} {T : porderType disp}. 23 | Implicit Types (x y z : T). 24 | 25 | Lemma le_ge_incomp x y : 26 | [|| (x <= y), (x >= y) | (x >< y)]. 27 | Proof. 28 | case: (x <= y)/idP=> //=. 29 | case: (y <= x)/idP=> //=. 30 | rewrite !negb_or=> /negP ? /negP ?; exact/andP. 31 | Qed. 32 | 33 | Lemma le_gt_incomp x y : 34 | [|| (x <= y), (x > y) | (x >< y)]. 35 | Proof. 36 | move: (le_ge_incomp x y)=> /or3P[->||->] //. 37 | rewrite le_eqVlt=> /orP[/eqP->|->] //. 38 | by rewrite le_refl. 39 | Qed. 40 | 41 | End POrderUtils. 42 | 43 | 44 | Section Closure. 45 | Context {disp : unit} {T : porderType disp}. 46 | Implicit Types (x y z : T) (X : pred T). 47 | 48 | Definition dw_closed (X : pred T) : Prop := 49 | (* ca · [X] \<= [X] · ca; *) 50 | forall x y, x <= y -> X y -> X x. 51 | 52 | Lemma eq_dw_closed X Y : 53 | X =1 Y -> dw_closed X <-> dw_closed Y. 54 | Proof. move=> e; split=> dw ??; [rewrite -?e | rewrite ?e]; exact/dw. Qed. 55 | 56 | End Closure. 57 | 58 | Section POrderMorph. 59 | Context {dispT : unit} {dispU : unit}. 60 | Context {T : porderType dispT} {U : porderType dispU}. 61 | Implicit Types (f : T -> U). 62 | Implicit Types (x y z : T). 63 | 64 | (* Definition monotone f := { homo f : x y / x <= y}. *) 65 | (* Definition antimonotone f := {ahomo f : x y / x <= y}. *) 66 | (* Definition reflecting f := { mono f : x y / x <= y}. *) 67 | 68 | Lemma le_homo_lt_img f x y : 69 | {homo f : x y / x <= y} -> (f x < f y) -> (x < y) || (x >< y). 70 | Proof. 71 | case lt_xy: (x < y)=> //= fmon lt_fxy. 72 | apply/negP=> /orP []. 73 | - rewrite le_eqVlt lt_xy orbF. 74 | by move: lt_fxy=> /[swap] /eqP<-; rewrite ltxx. 75 | move=> /fmon le_fyx. 76 | move: (lt_le_asym (f x) (f y)). 77 | by move=> /andP; apply; split=> //. 78 | Qed. 79 | 80 | Lemma lt_homo_le_img f x y : 81 | {homo f : x y / x < y} -> (f x <= f y) -> (x <= y) || (x >< y). 82 | Proof. 83 | move=> fmon le_fxy. 84 | move: (le_gt_incomp x y)=> /or3P[-> | | ->] //. 85 | move=> /fmon lt_fyx; exfalso. 86 | move: (lt_le_asym (f y) (f x)). 87 | by move=> /andP; apply; split=> //. 88 | Qed. 89 | 90 | Lemma le_homo_mono f : {homo f : x y / x <= y} -> {ahomo f : x y / x <= y} -> 91 | {mono f : x y / x <= y}. 92 | Proof. 93 | move=> fmon frefl x y. 94 | apply/idP/idP; [exact/frefl | exact/fmon]. 95 | Qed. 96 | 97 | Lemma cancel_le_ahomo_homo f g : cancel g f -> 98 | {ahomo f : x y / x <= y} -> {homo g : x y / x <= y}. 99 | Proof. by move=> K fmon x y le_xy; apply/fmon; rewrite !K. Qed. 100 | 101 | Lemma le_mono_incomp f : 102 | {mono f : x y / x <= y} -> { mono f : x y / x >< y }. 103 | Proof. 104 | move=> femb x y; apply: negbLR. 105 | by rewrite !negbK /Order.comparable !femb. 106 | Qed. 107 | 108 | Lemma le_homo_bij_total f : bijective f -> {homo f : x y / x <= y} -> 109 | total (<=%O : rel T) -> total (<=%O : rel U). 110 | Proof. 111 | case=> g Kf Kg fmon tot x y. 112 | by move: (tot (g x) (g y))=> /orP[] /fmon; rewrite !Kg=> ->. 113 | Qed. 114 | 115 | (* TODO: equivalent to mathcomp.ssreflect.order.le_mono *) 116 | Lemma lt_homo_total_mono f : {homo f : x y / x < y} -> total (<=%O : rel T) -> 117 | { mono f : e1 e2 / e1 <= e2 }. 118 | Proof. 119 | move=> fmon tot x y. 120 | apply/idP/idP; last exact/ltW_homo. 121 | move=> /(lt_homo_le_img fmon)=> /orP[] //. 122 | by rewrite /Order.comparable; move: (tot x y) ->. 123 | Qed. 124 | 125 | Lemma dw_closed_preim f P : 126 | {homo f : x y / x <= y} -> dw_closed P -> dw_closed (preim f P). 127 | Proof. move=> fmon dw_clos=> x y /fmon; exact/dw_clos. Qed. 128 | 129 | End POrderMorph. 130 | 131 | Section FinPOrderMorph. 132 | Context {dispT : unit} {dispU : unit}. 133 | Context {T : finPOrderType dispT} {U : finPOrderType dispU}. 134 | Implicit Types (f : T -> U) (g : U -> T). 135 | Implicit Types (x y z : T). 136 | 137 | Lemma inj_le_homo_mono f g : injective f -> injective g -> 138 | {homo f : x y / x <= y} -> {homo g : x y / x <= y} -> {mono f : x y / x <= y}. 139 | Proof. 140 | move=> finj ginj fmon gmon. 141 | move=> e1 e2; apply/idP/idP; last exact/fmon. 142 | pose h := g \o f. 143 | have hmon: {homo h : x y / x <= y}. 144 | - by move=> ?? /fmon /gmon. 145 | have : injective h by exact/inj_comp. 146 | move=> /cycle_orbit cyc. 147 | pose o1 := order h e1. 148 | pose o2 := order h e2. 149 | pose o := lcmn o1 o2. 150 | have {2}<-: iter ((o %/ o1) * o1) h e1 = e1. 151 | - rewrite iter_mul_eq /o1 //. 152 | apply/(iter_order_cycle (cyc e1)); exact/in_orbit. 153 | have {2}<-: iter ((o %/ o2) * o2) h e2 = e2. 154 | - rewrite iter_mul_eq /o2 //. 155 | apply/(iter_order_cycle (cyc e2)); exact/in_orbit. 156 | rewrite !divnK; last first. 157 | - exact/dvdn_lcml. 158 | - exact/dvdn_lcmr. 159 | have: o = lcmn o1 o2 by done. 160 | case o=> [|{}o]; last first. 161 | - rewrite !iterSr=> ??; apply/homo_iter=> //; exact/gmon. 162 | move=> /esym /eqP. 163 | rewrite eqn0Ngt lcmn_gt0 negb_and ?/o1 ?/o2. 164 | move: (order_gt0 h e1) (order_gt0 h e2). 165 | by move=> ++ /orP[/negP|/negP]. 166 | Qed. 167 | 168 | End FinPOrderMorph. 169 | 170 | Module Export MaxSup. 171 | Section Def. 172 | Context {disp : unit} {T : porderType disp}. 173 | Implicit Types (s : seq T) (x : T). 174 | 175 | (* TODO: generalize to arbitary pred? *) 176 | Definition is_sup s x := 177 | (x \in s) && all (fun y => y <= x) s. 178 | 179 | (* TODO: generalize to arbitary pred? *) 180 | Definition is_max s x := 181 | (x \in s) && all (fun y => ~~ (x < y)) s. 182 | 183 | Definition max_seq x s := 184 | foldr Order.max x s. 185 | 186 | End Def. 187 | 188 | Section Theory. 189 | Context {disp : unit} {T : orderType disp}. 190 | Implicit Types (s : seq T) (x : T). 191 | 192 | Lemma is_supP s x : 193 | reflect (x \in s /\ {in s, forall y, y <= x}) (is_sup s x). 194 | Proof. exact/(andPP idP allP). Qed. 195 | 196 | Lemma is_maxP s x : 197 | reflect (x \in s /\ {in s, forall y, ~~ (x < y)}) (is_max s x). 198 | Proof. exact/(andPP idP allP). Qed. 199 | 200 | Lemma is_sup_in s x : 201 | is_sup s x -> x \in s. 202 | Proof. by move=> /is_supP[]. Qed. 203 | 204 | Lemma is_sup_uniq X x y : 205 | is_sup X x -> is_sup X y -> x = y. 206 | Proof. 207 | case/is_supP=> i l. 208 | case/is_supP=> /l /[swap]/(_ _ i) lxy *. 209 | by apply/le_anti; rewrite lxy. 210 | Qed. 211 | 212 | Lemma is_sup0 x : 213 | ~~ is_sup [::] x. 214 | Proof. done. Qed. 215 | 216 | Lemma is_sup_eq s1 s2 : 217 | s1 =i s2 -> is_sup s1 =1 is_sup s2. 218 | Proof. by move=> e x; rewrite /is_sup e (eq_all_r e). Qed. 219 | 220 | Lemma is_sup1 x y : 221 | (is_sup [:: x] y) = (x == y). 222 | Proof. 223 | rewrite /is_sup inE /= andbT andb_idr eq_sym //. 224 | by move=> /eqP->; rewrite lexx. 225 | Qed. 226 | 227 | Lemma max_seq_in d s : 228 | max_seq d s \in d :: s. 229 | Proof. 230 | elim: s=> [|x s] //=; rewrite !inE //. 231 | by case: leP; rewrite ?eqxx //= => + /orP[|] ->. 232 | Qed. 233 | 234 | Lemma max_seq_dflt_le d s : 235 | d <= max_seq d s. 236 | Proof. 237 | elim s=> //= x {}s IH. 238 | apply/(le_trans IH). 239 | by rewrite le_maxr lexx. 240 | Qed. 241 | 242 | Lemma max_seq_in_le d s x : 243 | x \in s -> x <= max_seq d s. 244 | Proof. 245 | elim s=> //= y {}s IH. 246 | rewrite inE le_maxr=> /orP[/eqP->|/IH->] //=. 247 | by rewrite lexx. 248 | Qed. 249 | 250 | Lemma max_seq_all d s x : 251 | d <= x -> all (<=%O^~ x) s = (max_seq d s <= x). 252 | Proof. 253 | move=> led; apply/idP/idP. 254 | - move: (max_seq_in d s); rewrite inE=> /orP[/eqP->|] //. 255 | by move=> /[swap] /allP; apply. 256 | elim s=> //= y {}s IH. 257 | by rewrite le_maxl=> /andP[->] /IH ->. 258 | Qed. 259 | 260 | Lemma max_seq_all_dflt d s : 261 | all (<=%O^~ d) s = (max_seq d s == d). 262 | Proof. 263 | rewrite (@max_seq_all d) le_eqVlt orb_idr //. 264 | move=> /ltW ?; apply/eqP/le_anti/andP; split=> //. 265 | exact/max_seq_dflt_le. 266 | Qed. 267 | 268 | Lemma is_sup_max_seqE d s x : 269 | is_sup s x -> max_seq d s = Order.max d x. 270 | Proof. 271 | move=> /is_supP[xin lex]. 272 | apply/le_anti/andP; split; case: (leP d)=> // xd; last 2 first. 273 | - exact/max_seq_in_le. 274 | - exact/max_seq_dflt_le. 275 | - rewrite -max_seq_all //; exact/allP. 276 | rewrite le_eqVlt -max_seq_all_dflt. 277 | apply/orP; left; apply/allP=> y /lex. 278 | move=> /le_trans; apply; exact/ltW. 279 | Qed. 280 | 281 | Lemma is_sup_le_max_seqE d s x : 282 | d <= x -> is_sup s x -> max_seq d s = x. 283 | Proof. move=> dx supx; rewrite -(max_r dx); exact/is_sup_max_seqE. Qed. 284 | 285 | Lemma max_seq_sup d s x : 286 | max_seq d s \in s -> is_sup s (max_seq d s). 287 | Proof. move=> max_in; apply/is_supP; split=> //; exact/max_seq_in_le. Qed. 288 | 289 | Lemma is_supE d s x : 290 | d <= x -> (is_sup s x) = (x \in s) && (max_seq d s == x). 291 | Proof. 292 | move=> dx; apply/idP/idP; last first. 293 | - move=> /andP[] /[swap] /eqP<-; exact/max_seq_sup. 294 | move=> /[dup] /is_sup_in -> /(is_sup_max_seqE d) -> /=. 295 | by rewrite max_r. 296 | Qed. 297 | 298 | Section WithBottom. 299 | Context {d : T}. 300 | Hypothesis (dbot : forall x, d <= x). 301 | 302 | Lemma max_seq_inNnil s : 303 | s != [::] -> max_seq d s \in s. 304 | Proof. 305 | elim: s=> // x s IH /= _. 306 | case: (s == [::])/eqP=> [->|/eqP nl] /=. 307 | - rewrite max_l ?inE //. 308 | by case: leP; rewrite ?inE ?eqxx ?IH. 309 | Qed. 310 | 311 | Lemma max_set_eq s1 s2 : 312 | s1 =i s2 -> max_seq d s1 = max_seq d s2. 313 | Proof. 314 | move=> eqm; case: (s1 == [::])/idP. 315 | - move=> /[dup] + /eqP ->. 316 | by rewrite (eq_mem0 eqm)=> /eqP->. 317 | move=> /negP; rewrite (eq_mem0 eqm)=> neq. 318 | apply/is_sup_le_max_seqE=> //. 319 | apply/is_supP; split. 320 | - by rewrite eqm; apply/max_seq_inNnil. 321 | by move=> x; rewrite eqm=> /max_seq_in_le. 322 | Qed. 323 | 324 | Lemma is_sup_NnilE s x : 325 | s != [::] -> is_sup s x = (max_seq d s == x). 326 | Proof. 327 | rewrite (@is_supE d) // => neq. 328 | apply/idP/idP=> [/andP[? ->]|/eqP<-] //. 329 | rewrite eqxx andbT; exact/max_seq_inNnil. 330 | Qed. 331 | 332 | End WithBottom. 333 | 334 | Section Monotone. 335 | Variables (f : T -> T) (s : seq T) (x : T). 336 | 337 | Hypothesis (finj : injective f). 338 | Hypothesis (fmon : {mono f : x y / x <= y}). 339 | 340 | Lemma is_sup_mon : 341 | is_sup [seq f y | y <- s] (f x) = is_sup s x. 342 | Proof. 343 | rewrite /is_sup mem_map // all_map. 344 | apply/andb_id2l=> _; apply/eq_all. 345 | move=> y /=; exact/fmon. 346 | Qed. 347 | 348 | End Monotone. 349 | End Theory. 350 | 351 | End MaxSup. 352 | 353 | 354 | Section DwSurjective. 355 | Context {dispT : unit} {T : porderType dispT}. 356 | Context {dispU : unit} {U : porderType dispU}. 357 | Implicit Types (f : T -> U) (P : pred T) (Q : pred U). 358 | Implicit Types (x y z : T). 359 | 360 | (* TODO: consult literature to find relevant theory *) 361 | Definition dw_surjective f := 362 | forall x, {in (<= f x), surjective f}. 363 | 364 | Definition dw_surjective_le f := 365 | forall x, {in (<= f x), surjective [rst f | (<= x) : pred T] }. 366 | 367 | Lemma eq_dw_surj f : 368 | dw_surjective f -> forall g, f =1 g -> dw_surjective g. 369 | Proof. by move=> fdw g eqf x y; rewrite -?eqf=> /fdw [z] <-; exists z. Qed. 370 | 371 | Lemma surj_dw_surj f : 372 | surjective f -> dw_surjective f. 373 | Proof. by move=> fsurj x y _; move: (fsurj y)=> [z] <-; exists z. Qed. 374 | 375 | Lemma eq_dw_surj_le f : 376 | dw_surjective_le f -> forall g, f =1 g -> dw_surjective_le g. 377 | Proof. 378 | move=> fdw g eqf x y; rewrite -?eqf=> /fdw [z] <-; exists z. 379 | by rewrite /rst /= eqf. 380 | Qed. 381 | 382 | Lemma dw_surj_leW f : 383 | dw_surjective_le f -> dw_surjective f. 384 | Proof. by move=> dwf x y /dwf[z] <-; rewrite /rst /=; exists (val z). Qed. 385 | 386 | Lemma ahomo_dw_surj_le f : 387 | {ahomo f : x y / x <= y} -> dw_surjective f -> dw_surjective_le f. 388 | Proof. 389 | move=> lef dwf x y /=. 390 | rewrite inE=> /[dup] /dwf[z] <-. 391 | by move=> /lef lez; exists (Sub z lez). 392 | Qed. 393 | 394 | Lemma dw_surj_le_in_ahomo_in f P : dw_surjective_le f -> dw_closed P -> 395 | {in P &, injective f} -> {in P &, {ahomo f : x y / x <= y}}. 396 | Proof. 397 | move=> dwf dwX injf x y xin yin. 398 | move=> /dwf[[z]] /= zin. 399 | rewrite /rst /= => /injf <- //. 400 | by apply/dwX/yin. 401 | Qed. 402 | 403 | Lemma dw_surj_le_inj_ahomo f : 404 | dw_surjective_le f -> injective f -> {ahomo f : x y / x <= y}. 405 | Proof. 406 | move=> dwf injf x y. 407 | apply/(@dw_surj_le_in_ahomo_in f predT)=> //. 408 | move=>> ??; exact/injf. 409 | Qed. 410 | 411 | Lemma dw_surj_le_closed f (X : pred T) (Y : pred U) : 412 | dw_surjective_le f -> {in Y, surjective f} -> (preim f Y) =1 X -> 413 | dw_closed X -> dw_closed Y. 414 | Proof. 415 | move=> fdw fsurj fpreim dwX x y. 416 | move=> /[swap] /[dup] /fsurj [y'] <-. 417 | move=> /[swap] /fdw=> [[]] [x'] /= + <-. 418 | rewrite /rst /= => /dwX. 419 | by rewrite -fpreim -fpreim. 420 | Qed. 421 | 422 | End DwSurjective. 423 | 424 | 425 | Module DwFinPOrder. 426 | 427 | Module Export DwFinPOrder. 428 | Section ClassDef. 429 | 430 | Record mixin_of (T0 : Type) 431 | (b : Order.POrder.class_of T0) 432 | (* TODO: parametrize by disp? *) 433 | (T := Order.POrder.Pack tt b) := Mixin { 434 | pideal : T -> {fset T}; 435 | _ : forall x y : T, x \in (pideal y) = (x <= y); 436 | }. 437 | 438 | Set Primitive Projections. 439 | Record class_of (T : Type) := Class { 440 | base : Order.POrder.class_of T; 441 | mixin : mixin_of base; 442 | }. 443 | Unset Primitive Projections. 444 | 445 | Local Coercion base : class_of >-> Order.POrder.class_of. 446 | 447 | Structure type := Pack { sort; _ : class_of sort }. 448 | 449 | Local Coercion sort : type >-> Sortclass. 450 | 451 | Variables (T : Type) (cT : type). 452 | 453 | Definition class := let: Pack _ c as cT' := cT return class_of (sort cT') in c. 454 | Definition clone c of phant_id class c := @Pack T c. 455 | 456 | Definition pack := 457 | fun bT b & phant_id (@Order.POrder.class tt bT) b => 458 | fun m => Pack (@Class T b m). 459 | 460 | Definition eqType := @Equality.Pack cT class. 461 | Definition choiceType := @Choice.Pack cT class. 462 | Definition porderType := @Order.POrder.Pack tt cT class. 463 | End ClassDef. 464 | End DwFinPOrder. 465 | 466 | Module Export Exports. 467 | Coercion base : class_of >-> Order.POrder.class_of. 468 | Coercion mixin : class_of >-> mixin_of. 469 | Coercion sort : type >-> Sortclass. 470 | Coercion eqType : type >-> Equality.type. 471 | Coercion choiceType : type >-> Choice.type. 472 | Coercion porderType : type >-> Order.POrder.type. 473 | Notation dwFinPOrderType := type. 474 | Canonical eqType. 475 | Canonical choiceType. 476 | Canonical porderType. 477 | Notation DwFinPOrderType T m := (@pack T _ _ id m). 478 | End Exports. 479 | 480 | Module Export Def. 481 | Section Def. 482 | Context {T : dwFinPOrderType}. 483 | Implicit Types (x : T) (X : {fset T}). 484 | 485 | Definition pideal : T -> {fset T} := 486 | DwFinPOrder.pideal (DwFinPOrder.class T). 487 | 488 | Definition fin_ideal X : {fset T} := 489 | \bigcup_(x <- X) (pideal x). 490 | 491 | Definition up_clos : pred T -> pred T := 492 | fun P x => [exists y : pideal x, P (val y)]. 493 | 494 | Definition dw_closedb X := 495 | [forall x : fin_ideal X, val x \in X]. 496 | 497 | End Def. 498 | 499 | Section Homo. 500 | Context {T : dwFinPOrderType} {U : dwFinPOrderType}. 501 | Implicit Types (f : T -> U). 502 | 503 | Definition homo_pideal f := 504 | forall x, pideal (f x) `<=` f @` (pideal x). 505 | 506 | End Homo. 507 | End Def. 508 | 509 | Module Export Syntax. 510 | Notation "{ 'homo' 'pideal' f }" := (homo_pideal f) 511 | (at level 0, f at level 99, format "{ 'homo' 'pideal' f }") : order_scope. 512 | End Syntax. 513 | 514 | Module Export Theory. 515 | Section Theory. 516 | Context {T : dwFinPOrderType}. 517 | Implicit Types (x y : T) (X : {fset T}). 518 | Implicit Types (P Q : pred T). 519 | 520 | Lemma pidealE x y : 521 | x \in (pideal y) = (x <= y). 522 | Proof. by move: x y; case: T=> [? [? []]]. Qed. 523 | 524 | (* TODO: rename? *) 525 | Lemma pidealx x : 526 | x \in pideal x. 527 | Proof. by rewrite pidealE. Qed. 528 | 529 | Lemma fin_idealP X x : 530 | reflect (exists2 y, y \in X & x <= y) (x \in fin_ideal X). 531 | Proof. 532 | apply/equivP; first exact/bigfcupP. 533 | by apply/exists2_equiv=> y; rewrite ?andbT ?pidealE. 534 | Qed. 535 | 536 | Lemma dw_closedP X : 537 | reflect (dw_closed (mem X)) (dw_closedb X). 538 | Proof. 539 | apply/equivP; first apply/(fset_forallP); split. 540 | - move=> inX x y le_xy Xy. 541 | by apply/inX/fin_idealP; exists y. 542 | by move=> dwX x /fin_idealP [y] /dwX; apply. 543 | Qed. 544 | 545 | Lemma up_closP P x : 546 | reflect (exists2 y, y <= x & y \in P) (x \in up_clos P). 547 | Proof. 548 | apply/(equivP idP). 549 | rewrite /up_clos !unfold_in /=; split. 550 | - move=> /existsP /= [y]; move: (valP y). 551 | by rewrite pidealE=> ??; exists (val y). 552 | move=> [y] le_yx Py; apply/existsP. 553 | have: y \in pideal x by rewrite pidealE. 554 | by move=> yi; exists (Sub y yi). 555 | Qed. 556 | 557 | (* Kuratowski closure axioms *) 558 | 559 | Lemma up_clos0 : 560 | up_clos (pred0 : pred T) =1 pred0. 561 | Proof. 562 | move=> x; apply/idP=> /=. 563 | by move=> /up_closP[y]. 564 | Qed. 565 | 566 | Lemma up_clos_ext P : 567 | {subset P <= up_clos P}. 568 | Proof. by move=> x Px; apply/up_closP; exists x. Qed. 569 | 570 | Lemma up_clos_idemp P : 571 | up_clos (up_clos P) =1 up_clos P. 572 | Proof. 573 | move=>>; apply/idP/idP; last exact/up_clos_ext. 574 | case/up_closP=>> l /up_closP[x] /le_trans/(_ l) *. 575 | apply/up_closP; by exists x. 576 | Qed. 577 | 578 | Lemma up_closU P Q : 579 | up_clos ([predU P & Q]) =1 [predU (up_clos P) & (up_clos Q)]. 580 | Proof. 581 | move=> x; apply/idP/idP=> /=. 582 | - move=> /up_closP[y] le_yx; rewrite inE. 583 | by move=> /orP[] ?; apply/orP; [left | right]; apply/up_closP; exists y. 584 | move=> /orP[] /up_closP[y] le_xy y_in; apply/up_closP; exists y=> //=. 585 | all: by rewrite !inE y_in ?orbT. 586 | Qed. 587 | 588 | (* ************************* *) 589 | 590 | Lemma up_clos_subs P Q : 591 | {subsumes P <= Q : x y / y <= x } <-> {subset (up_clos P) <= (up_clos Q)}. 592 | Proof. 593 | split=> [subs x | sub x]; last first. 594 | - move: up_clos_ext=> /[apply] x_in. 595 | by move: (sub x x_in)=> /up_closP[y] ??; exists y. 596 | move=> /up_closP[y] le_yx Py. 597 | apply/up_closP; move: (subs y Py)=> [z] z_in le_zy. 598 | exists z=> //; exact/(le_trans le_zy). 599 | Qed. 600 | 601 | End Theory. 602 | End Theory. 603 | 604 | (* TODO: better naming convention *) 605 | Module Export AuxTheory. 606 | Section AuxTheory. 607 | Context {T U V : dwFinPOrderType}. 608 | Implicit Types (f : T -> U) (g : U -> V). 609 | 610 | Lemma homo_pidealE {T1 U1 : dwFinPOrderType} (f : T1 -> U1) : 611 | { homo pideal f } <-> dw_surjective_le f. 612 | Proof. 613 | split=> [homf x y | subs]. 614 | - rewrite inE -pidealE=> yin. 615 | move: (homf x)=> /fsubsetP /(_ y yin). 616 | move=> /imfsetP=> [[]] z /= + ->. 617 | by rewrite pidealE=> zle; exists (Sub z zle). 618 | move=> x; apply/fsubsetP=> y. 619 | rewrite pidealE=> yle. 620 | move: (subs x y yle)=> [[z]] /= zle. 621 | rewrite /rst /= => <-. 622 | apply/imfsetP; exists z=> //=. 623 | by rewrite pidealE. 624 | Qed. 625 | 626 | Lemma homo_pideal_comp g f : 627 | {homo pideal g} -> {homo pideal f} -> {homo pideal (g \o f)}. 628 | Proof. 629 | rewrite !homo_pidealE=> hg hf x y /=. 630 | move=> /hg [[a]] /=; rewrite /rst /= => + <-. 631 | move=> /hf [[b]] /=; rewrite /rst /= => bin <-. 632 | by exists (Sub b bin). 633 | Qed. 634 | 635 | Lemma dw_closedb_imfsetE f X : injective f -> {homo f : x y / x <= y} -> 636 | dw_surjective_le f -> dw_closedb (f @` X) = dw_closedb X. 637 | Proof. 638 | move=> finj lef fdw. 639 | move: (imfset_preim_eq X finj)=> /eq_dw_closed dw_preim. 640 | apply/idP/idP=> /dw_closedP dw; apply/dw_closedP. 641 | - apply/dw_preim/dw_closed_preim=> //. 642 | apply/(dw_surj_le_closed fdw)=> //. 643 | - by move=> x /imfsetP [y] /= _ ->; exists y. 644 | exact/dw_preim. 645 | Qed. 646 | 647 | End AuxTheory. 648 | End AuxTheory. 649 | 650 | End DwFinPOrder. 651 | 652 | Export DwFinPOrder.Exports. 653 | Export DwFinPOrder.Def. 654 | Export DwFinPOrder.Syntax. 655 | Export DwFinPOrder.Theory. 656 | Export DwFinPOrder.AuxTheory. 657 | -------------------------------------------------------------------------------- /theories/common/rel_algebra.v: -------------------------------------------------------------------------------- 1 | From Coq Require Import Relations. 2 | From mathcomp Require Import ssreflect ssrbool ssrnat ssrfun eqtype. 3 | From mathcomp Require Import seq path fingraph fintype. 4 | From mathcomp.tarjan Require Import extra acyclic kosaraju acyclic_tsorted. 5 | From RelationAlgebra Require Import lattice monoid boolean rel fhrel. 6 | From RelationAlgebra Require Import kleene kat_tac. 7 | 8 | (* ************************************************************************** *) 9 | (* Missing definitions, notations and lemmas for relation-algebra package *) 10 | (* ************************************************************************** *) 11 | 12 | Set Implicit Arguments. 13 | Unset Printing Implicit Defensive. 14 | Unset Strict Implicit. 15 | 16 | Declare Scope rel_scope. 17 | Delimit Scope rel_scope with rel. 18 | 19 | Local Open Scope rel_scope. 20 | 21 | (* ************************************************************************** *) 22 | (* Notations *) 23 | (* ************************************************************************** *) 24 | 25 | (* A notation to differentiate prop & bool valued relations. *) 26 | Notation hRel A B := (hrel A B). 27 | Notation Rel A := (hrel A A). 28 | 29 | (* Non-unicode alternative notations for relation-algebra. *) 30 | Notation "A \== B" := (weq A B) 31 | (at level 70, no associativity) : rel_scope. 32 | Notation "A \<= B" := (leq A B) 33 | (at level 70, no associativity) : rel_scope. 34 | Notation "A \& B" := (cap A B) 35 | (at level 68, left associativity) : rel_scope. 36 | Notation "A \+ B" := (cup A B) 37 | (at level 64, left associativity) : rel_scope. 38 | Notation "A \; B" := (dot A B) 39 | (at level 60, right associativity, format "A \; B") : rel_scope. 40 | Notation "\! A" := (neg A) 41 | (at level 20, right associativity, format "\! A") : rel_scope. 42 | Notation "A ^+" := (itr _ A) 43 | (at level 5, left associativity, format "A ^+") : rel_scope. 44 | Notation "A ^*" := (str _ A) 45 | (at level 5, left associativity, format "A ^*") : rel_scope. 46 | Notation "A ^t" := (cnv _ _ A) 47 | (at level 5, left associativity, format "A ^t") : rel_scope. 48 | Notation "\0" := bot (at level 0) : rel_scope. 49 | Notation "\T" := top (at level 0) : rel_scope. 50 | Notation "\1" := (one _) (at level 0) : rel_scope. 51 | 52 | (* ************************************************************************** *) 53 | (* Utilities *) 54 | (* ************************************************************************** *) 55 | 56 | Section PropUtils. 57 | Context {T : Type}. 58 | Implicit Types (P : T -> Prop). 59 | 60 | Lemma inh_nempty P : 61 | inhabited { x | P x } -> ~ (P \<= \0). 62 | Proof. by move=> [] [] x Hx H; move: (H x Hx)=> //=. Qed. 63 | 64 | End PropUtils. 65 | 66 | (* ************************************************************************** *) 67 | (* Cartesian product for lattice-valued functions *) 68 | (* ************************************************************************** *) 69 | 70 | Section Prod. 71 | Context {T : Type} {L : lattice.ops}. 72 | 73 | Definition cart_prod (p q : T -> L) : T -> T -> L := 74 | fun x y => p x \& q y. 75 | 76 | End Prod. 77 | 78 | Notation "p \x q" := (cart_prod p q) 79 | (at level 60, no associativity) : rel_scope. 80 | 81 | (* ************************************************************************** *) 82 | (* Reflexive closure *) 83 | (* ************************************************************************** *) 84 | 85 | Notation "r ^?" := (\1 \+ r) 86 | (left associativity, at level 5, format "r ^?"): rel_scope. 87 | 88 | Lemma itr_qmk `{laws} `{BKA ≪ l} n (x : X n n) : 89 | x^+^? \== x^?^+. 90 | Proof. by ka. Qed. 91 | 92 | (* TODO: make lemma instance of Proper for rewriting? *) 93 | Lemma qmk_weq `{laws} `{CUP ≪ l} n (x y : X n n): 94 | x \== y -> x^? \== y^?. 95 | Proof. by move => ->. Qed. 96 | 97 | Lemma qmk_str `{laws} `{BKA ≪ l} n (x : X n n) : 98 | x^*^? \== x^*. 99 | Proof. ka. Qed. 100 | 101 | (* ************************************************************************** *) 102 | (* Subtraction (for complemented lattices, i.e. lattices with negation) *) 103 | (* ************************************************************************** *) 104 | 105 | Notation "x \\ y" := (x \& \!y) 106 | (left associativity, at level 45): rel_scope. 107 | 108 | Section SubtractionTheory. 109 | 110 | Context `{monoid.laws} (n : ob X). 111 | Implicit Types (x : X n n). 112 | 113 | (* TODO: introduce a class of lattices/KATs with decidable equality? *) 114 | Hypothesis (eq_dec : 1 \+ \!1 \== (top : X n n)). 115 | 116 | Lemma qmk_sub_one `{CUP+CAP+TOP ≪ l} x : 117 | (x \\ 1)^? \== x^?. 118 | Proof. 119 | apply/weq_spec; split; first by lattice. 120 | by rewrite -[x in _ + x]capxt -eq_dec capcup; lattice. 121 | Qed. 122 | 123 | End SubtractionTheory. 124 | 125 | (* ************************************************************************** *) 126 | (* Morphism instance for pointwise construction on lattices *) 127 | (* ************************************************************************** *) 128 | 129 | Section PWMorph. 130 | 131 | Context {h l : level}. 132 | Context {X Y : lattice.ops}. 133 | Context {L : lattice.laws h Y}. 134 | Context {Hl : l ≪ h}. 135 | 136 | Universe pw. 137 | 138 | Context {Z : Type@{pw}}. 139 | 140 | Instance pw_morph (f : X -> Y) : 141 | @morphism l X Y f -> @morphism l (pw_ops X Z) (pw_ops Y Z) (fun g => f \o g). 142 | Proof. 143 | move=> Hm; constructor; simpl. 144 | - by move=> x y H a /=; apply: fn_leq. 145 | - by move=> x y H a /=; apply: fn_weq. 146 | - by move=> ? x y a /=; apply: fn_cup. 147 | - by move=> ? x y a /=; apply: fn_cap. 148 | - by move=> ? x /=; apply: fn_bot. 149 | - by move=> ? x /=; apply: fn_top. 150 | - by move=> ? x a /=; apply: fn_neg. 151 | Qed. 152 | 153 | End PWMorph. 154 | 155 | (* ************************************************************************** *) 156 | (* Instance of Lattice and KAT for decidable realtions *) 157 | (* ************************************************************************** *) 158 | 159 | (* Adopted from relation-algebra/fhrel.v *) 160 | 161 | Section HrelType. 162 | Variables A B : eqType. 163 | Definition hrel_type := A -> B -> bool. 164 | Definition hrel_of of phant A & phant B := hrel_type. 165 | End HrelType. 166 | 167 | Notation "{ 'hrel' A & B }" := (hrel_of (Phant A) (Phant B)) 168 | (at level 0, format "{ 'hrel' A & B }") : type_scope. 169 | 170 | Section Hrel. 171 | Implicit Types A B : eqType. 172 | 173 | (* Lattice structure is derived via the powerset 174 | * construction on the lattice of booleans. 175 | *) 176 | 177 | Canonical Structure hrel_lattice_ops A B := 178 | lattice.mk_ops {hrel A & B} lattice.leq weq cup cap neg bot top. 179 | 180 | Arguments lattice.leq : simpl never. 181 | Arguments lattice.weq : simpl never. 182 | 183 | Global Instance hrel_lattice_laws A B : 184 | lattice.laws BDL (hrel_lattice_ops A B) := 185 | lower_lattice_laws (H:=pw_laws _). 186 | (* lattice.laws (BL+ONE+CNV) (dhrel_lattice_ops A B) := *) 187 | (* lower_lattice_laws (H:=pw_laws _). *) 188 | 189 | Section MonoidOps. 190 | Variables (A B C : eqType). 191 | 192 | Definition hrel_one : {hrel A & A} := 193 | @eq_op A. 194 | 195 | Definition hrel_cnv (r : {hrel A & B}) : {hrel B & A} := 196 | fun x y => r y x. 197 | 198 | Definition hrel_inj (p : pred A) := 199 | fun x y => (x == y) && p x. 200 | 201 | Definition hrel_dot (r1 : {hrel A & B}) (r2 : {hrel B & C}) : {hrel A & C} := 202 | fun x y => false. 203 | Definition hrel_ldv (r1 : {hrel A & B}) (r2 : {hrel A & C}) : {hrel B & C} := 204 | fun x y => false. 205 | Definition hrel_rdv (r1 : {hrel B & A}) (r2 : {hrel C & A}) : {hrel C & B} := 206 | fun x y => false. 207 | 208 | Definition hrel_itr (r : {hrel A & A}) : {hrel A & A} := 209 | fun x y => false. 210 | Definition hrel_str (r : {hrel A & A}) : {hrel A & A} := 211 | fun x y => false. 212 | 213 | End MonoidOps. 214 | 215 | Canonical hrel_monoid_ops := 216 | monoid.mk_ops eqType hrel_lattice_ops 217 | hrel_dot 218 | hrel_one 219 | hrel_itr 220 | hrel_str 221 | hrel_cnv 222 | hrel_ldv 223 | hrel_rdv. 224 | 225 | (** Ensure that the [dhrel_*] definitions simplify, given enough arguments. *) 226 | Arguments hrel_dot {_ _ _} _ _ /. 227 | Arguments hrel_cnv {_ _} _ _ /. 228 | Arguments hrel_one {_} _ _ /. 229 | Arguments hrel_str {_} _ _ /. 230 | Arguments hrel_ldv {_} _ _ /. 231 | Arguments hrel_rdv {_} _ _ /. 232 | Arguments hrel_inj {_} _ _ _ /. 233 | 234 | (** We obtain the monoid laws using a faithful functor to the hrel model *) 235 | Definition hRel_of (A B : eqType) (r : {hrel A & B}) : hRel A B := fun x y => r x y. 236 | Ltac hRel_prop := do ! move => ?; rewrite /hRel_of /=; to_prop; by firstorder. 237 | 238 | Lemma hRel_of_morphism (A B : eqType) : 239 | morphism BDL (@hRel_of A B). 240 | (* morphism (BDL+ONE+CNV) (@hrel_of A B). *) 241 | Proof. 242 | split; try done; try hRel_prop. 243 | move => e1 e2 H x y; apply/eq_bool_iff; exact: H. 244 | Qed. 245 | 246 | (* We cannot declare the monoid laws instance, since 247 | * we cannot define composition on `dhrel` structure. 248 | * The current design of relation-algebra package 249 | * does not allow an optional composition operation. 250 | * This requires a custom fork: 251 | * git+https://github.com/eupp/relation-algebra#monoid-decoupling 252 | * However, maintaining the custom fork seems to be a bit of a complicated task, 253 | * therefore we postpone it (we hope it will be merged eventually). 254 | * Despite we cannot declare monoid laws instance 255 | * (and thus we cannot use some lemmas from relation-algebra) 256 | * we still can use notations. 257 | *) 258 | 259 | (* Lemma hrel_of_functor : functor (BDL+ONE+CNV) hrel_of. *) 260 | (* Proof. *) 261 | (* apply (@Build_functor (BDL+ONE+CNV) dhrel_monoid_ops hrel_monoid_ops id hrel_of). *) 262 | (* all: try done. all: try hrel_prop. *) 263 | (* apply: hrel_of_morphism. *) 264 | (* Qed. *) 265 | 266 | (* Lemma dhrel_monoid_laws_BDL: monoid.laws (BDL+ONE+CNV) dhrel_monoid_ops. *) 267 | (* Proof. *) 268 | (* eapply (laws_of_faithful_functor hrel_of_functor) => //. *) 269 | (* move => A B e1 e2 H x y. apply/eq_bool_iff. exact: H. *) 270 | (* Qed. *) 271 | 272 | (* Global Instance dhrel_monoid_laws: monoid.laws (BL+ONE+CNV) dhrel_monoid_ops. *) 273 | (* Proof. *) 274 | (* case dhrel_monoid_laws_BDL => *. *) 275 | (* split; try assumption. exact: dhrel_lattice_laws. *) 276 | (* Qed. *) 277 | 278 | Lemma hrel_oneE A a b : (1 : {hrel A & A}) a b = (a == b). 279 | Proof. reflexivity. Qed. 280 | Definition oneE := (hrel_oneE,fhrel_oneE). 281 | 282 | (* The following is required, see fhrel.v for details *) 283 | Definition d_top_def (A B : eqType) of phant A & phant B := 284 | (@top (@mor hrel_monoid_ops A B)). 285 | Notation d_top A B := (d_top_def (Phant A) (Phant B)). 286 | 287 | Definition d_zero_def (A B : eqType) of phant A & phant B := 288 | (@bot (@mor hrel_monoid_ops A B)). 289 | Notation d_zero A B := (d_zero_def (Phant A) (Phant B)). 290 | 291 | Definition d_one_def (A : eqType) of phant A := 292 | (@one hrel_monoid_ops A). 293 | Notation d_one A := (d_one_def (Phant A)). 294 | 295 | Arguments d_top_def A B /. 296 | Arguments d_zero_def A B /. 297 | Arguments d_one_def A /. 298 | 299 | Definition dset : ob hrel_monoid_ops -> lattice.ops := pw_ops bool_lattice_ops. 300 | 301 | Canonical Structure hrel_kat_ops := 302 | kat.mk_ops hrel_monoid_ops dset (@hrel_inj). 303 | 304 | (* Same issue as for monoid laws instance (see above). *) 305 | 306 | (* Global Instance hrel_kat_laws: kat.laws (CUP+BOT+ONE) BL hrel_kat_ops. *) 307 | (* Proof. *) 308 | (* split. *) 309 | (* - by eapply lower_laws. *) 310 | (* - move => A. by eapply lower_lattice_laws. *) 311 | (* - move => A. *) 312 | (* have H : Proper (lattice.leq ==> lattice.leq) (@hrel_inj A). *) 313 | (* + move => e1 e2 H x y /=. by case: (_ == _) => //=. *) 314 | (* split => //=. *) 315 | (* + move => x y. rewrite !weq_spec. by intuition. *) 316 | (* + move => _ f g x y /=. by case: (_ == _); case (f x); case (g x). *) 317 | (* + move => _ x y /=. by rewrite andbF. *) 318 | (* - move => _ _ A x y /=. by rewrite andbT. *) 319 | (* - move => _ _ A p q x y //=. *) 320 | (* Qed. *) 321 | 322 | Section Theory. 323 | 324 | Context {T : eqType}. 325 | 326 | Lemma hrel_eq_dec : 1 \+ \!1 \== (top : {hrel T & T}). 327 | Proof. rewrite /weq => x y /=. case: (x =P y)=> //=. Qed. 328 | 329 | End Theory. 330 | 331 | End Hrel. 332 | 333 | (* ************************************************************************** *) 334 | (* Morphism lemmas for bool/Prop relations. *) 335 | (* ************************************************************************** *) 336 | 337 | (* The following lemmas are more convenient to work with 338 | * than using morphism instances directly. 339 | *) 340 | 341 | Lemma rel_leq_m {A B : eqType} (r1 r2 : {hrel A & B}) : 342 | r1 \<= r2 -> (r1 : hRel A B) \<= (r2 : hRel A B). 343 | Proof. by case (hRel_of_morphism A B)=> H ??????; apply H; solve_lower. Qed. 344 | 345 | Lemma rel_weq_m {A B : eqType} (r1 r2 : {hrel A & B}) : 346 | r1 \== r2 -> (r1 : hRel A B) \== (r2 : hRel A B). 347 | Proof. by case (hRel_of_morphism A B)=> ? H ?????; apply H; solve_lower. Qed. 348 | 349 | Lemma rel_cup_m {A B : eqType} (r1 r2 : {hrel A & B}) : 350 | (r1 \+ r2 : hRel A B) \== (r1 : hRel A B) \+ (r2 : hRel A B). 351 | Proof. by case (hRel_of_morphism A B)=> ?? H ????; apply H; solve_lower. Qed. 352 | 353 | Lemma rel_cap_m {A B : eqType} (r1 r2 : {hrel A & B}) : 354 | (r1 \& r2 : hRel A B) \== (r1 : hRel A B) \& (r2 : hRel A B). 355 | Proof. by case (hRel_of_morphism A B)=> ??? H ???; apply H; solve_lower. Qed. 356 | 357 | Lemma rel_bot_m {A B : eqType} : 358 | ((\0 : {hrel A & B}) : hRel A B) \== (\0 : hRel A B). 359 | Proof. by case (hRel_of_morphism A B)=> ???? H ??; apply H; solve_lower. Qed. 360 | 361 | Lemma rel_top_m {A B : eqType} : 362 | ((\T : {hrel A & B}) : hRel A B) \== (\T : hRel A B). 363 | Proof. by case (hRel_of_morphism A B)=> ????? H ?; apply H; solve_lower. Qed. 364 | 365 | Lemma rel_neg_m {A B : eqType} (r : {hrel A & B}) : 366 | (\!r : hRel A B) \== \!(r : hRel A B). 367 | Proof. move=> x y /=. split. apply /elimN/idP. apply /introN/idP. Qed. 368 | 369 | Lemma rel_sub_m {A B : eqType} (r1 r2 : {hrel A & B}) : 370 | (r1 \\ r2 : hRel A B) \== (r1 : hRel A B) \\ (r2 : hRel A B). 371 | Proof. by rewrite -rel_neg_m rel_cap_m. Qed. 372 | 373 | Lemma rel_one_m {A : eqType} : 374 | ((\1 : {hrel A & A}) : hRel A A) \== (\1 : hRel A A). 375 | Proof. do ! move => ?; rewrite /hrel_of /=; to_prop; by firstorder. Qed. 376 | (* Proof. case hrel_of_functor=> ?? H ?????; apply H; solve_lower. Qed. *) 377 | 378 | Lemma rel_qmk_m {A : eqType} (r : {hrel A & A}) : 379 | (r^? : hRel A A) \== (r : hRel A A)^?. 380 | Proof. by rewrite rel_cup_m rel_one_m. Qed. 381 | 382 | Lemma rel_cnv_m {A : eqType} (r : {hrel A & A}) : 383 | (r^t : hRel A A) \== (r : hRel A A)^t. 384 | Proof. do ! move => ?; rewrite /hRel_of /=; to_prop; by firstorder. Qed. 385 | (* Proof. case hrel_of_functor=> ????? H ??; apply H; solve_lower. Qed. *) 386 | 387 | (* ************************************************************************** *) 388 | (* Missing opportunities for rewriting *) 389 | (* ************************************************************************** *) 390 | 391 | Instance hrel_neg_leq {A B : Type} : 392 | Proper ((@leq (rel.hrel_lattice_ops A B)) --> 393 | (@leq (rel.hrel_lattice_ops A B))) neg. 394 | Proof. rewrite /leq=> x y /= H a b; apply /contra_not/H. Qed. 395 | 396 | Instance hrel_neg_weq {A B : Type} : 397 | Proper (@weq (rel.hrel_lattice_ops A B) ==> 398 | (@weq (rel.hrel_lattice_ops A B))) neg. 399 | Proof. 400 | rewrite /weq=> x y /= H a b. 401 | move: (H a b)=> [Hl Hr]; split; by apply /contra_not. 402 | Qed. 403 | 404 | (* ************************************************************************** *) 405 | (* Connecting reflection lemmas with pointwise equivalence *) 406 | (* ************************************************************************** *) 407 | 408 | Section PwEqvReflect. 409 | 410 | Context {T : eqType}. 411 | Implicit Types (R : relation T) (r : rel T). 412 | 413 | (* TODO: introduce `reflect_rel := forall x y, (R x y) (r x y)` ? *) 414 | 415 | Lemma weq_reflect R r : 416 | R \== r -> forall x y, reflect (R x y) (r x y). 417 | Proof. move=> H x y; apply: equivP; [exact: idP | symmetry; apply H]. Qed. 418 | 419 | Lemma reflect_weq R r : 420 | (forall x y, reflect (R x y) (r x y)) -> R \== r. 421 | Proof. by move=> H x y; apply rwP. Qed. 422 | 423 | End PwEqvReflect. 424 | 425 | (* ************************************************************************** *) 426 | (* Reconciling relation-algebra relation closures with vanilla Coq *) 427 | (* ************************************************************************** *) 428 | 429 | #[export] Hint Resolve r_refl rt_refl : core. 430 | 431 | Arguments clos_refl [A] R x y. 432 | Arguments clos_trans [A] R x y. 433 | Arguments clos_trans_1n [A] R x y. 434 | Arguments clos_trans_n1 [A] R x y. 435 | Arguments clos_refl_trans [A] R x y. 436 | 437 | Section RelClos. 438 | 439 | Context {T : Type}. 440 | Implicit Types (R : hrel T T) (r : rel T). 441 | 442 | (* TODO: consider to reformulate it in terms of relation-algebra 443 | * (or try to just use kat tactics inplace) 444 | *) 445 | Lemma clos_t_rt R x y : 446 | clos_trans R x y -> clos_refl_trans R x y. 447 | Proof. 448 | elim=> [|???? H ??]; first by constructor. 449 | by apply: rt_trans H _. 450 | Qed. 451 | 452 | Lemma clos_rt_crE R : 453 | clos_refl_trans R \== clos_refl (clos_trans R). 454 | Proof. 455 | move=> x y; split. 456 | - elim=> [{}x {}y xy | {}x | {}x {}y z _ xy _ yz] //. 457 | - by apply/r_step/t_step. 458 | - case: xy yz=> [{}y xy [{}z yz|] |] //=; last by apply r_step. 459 | apply/r_step/t_trans; [exact: xy| exact: yz]. 460 | case=> // ?; elim=> [|???? H ??]; first by constructor. 461 | by apply: rt_trans H _. 462 | Qed. 463 | 464 | Lemma clos_r_qmk R : 465 | clos_refl R \== R^?. 466 | Proof. 467 | split; first by case; [right | left]. 468 | case=> [->|]; first exact: r_refl; exact: r_step. 469 | Qed. 470 | 471 | Lemma clos_t1n_itr R : 472 | clos_trans_1n R \== R^+. 473 | Proof. 474 | move=> x y; split. 475 | - elim=> {x y} [x y | x z y] Rxy; first by exists y=> //; exists O. 476 | by move=> ? [z' H' [n it]]; exists z=> //; exists n.+1, z'. 477 | case=> z xz [n]; elim: n x z xz => [x z xz <-| n IHn x z xz /=]. 478 | - by apply/t1n_step. 479 | case=> w zw /IHn - /(_ z zw) ct_zy. 480 | by apply: Relation_Operators.t1n_trans xz ct_zy. 481 | Qed. 482 | 483 | Lemma clos_t_itr R : 484 | clos_trans R \== R^+. 485 | Proof. 486 | move=> x y; rewrite clos_trans_t1n_iff. 487 | by apply: clos_t1n_itr. 488 | Qed. 489 | 490 | Lemma clos_rt_str R : 491 | clos_refl_trans R \== R^*. 492 | Proof. 493 | rewrite str_itr clos_rt_crE clos_r_qmk. 494 | by rewrite clos_t_itr. 495 | Qed. 496 | 497 | Lemma itr_prod (D : T -> Prop) : 498 | (D \x D : hrel T T)^+ \== D \x D. 499 | Proof. 500 | apply/weq_spec; split; last exact/itr_ext. 501 | by apply/itr_ind_l1=> //= x y [] z [] ++ []. 502 | Qed. 503 | 504 | Lemma clos_t_restr R D : 505 | R \<= D \x D -> R^+ \<= D \x D. 506 | Proof. move=> rD; rewrite -itr_prod; exact/itr_leq. Qed. 507 | 508 | (* TODO: this cannot be proven for KA+NEG, 509 | * because hrel does not have NEG 510 | *) 511 | Lemma str_itr_sub_one R : 512 | R^* \\ \1 \== R^+ \\ \1. 513 | Proof. 514 | rewrite str_itr capC capcup. 515 | suff->: !1 \& (1 : hrel T T) \== 0. 516 | - by lattice. 517 | by move=> ?? /=; split=> // [[]]. 518 | Qed. 519 | 520 | (* TODO: also need to reprove this (see qmk_weq), 521 | * because of some techinical issues with typeclass inference 522 | *) 523 | Lemma qmk_weq_rel {U : eqType} (r1 r2 : {hrel U & U}) : 524 | r1 \== r2 -> r1^? \== r2^?. 525 | Proof. by move=> ->. Qed. 526 | 527 | End RelClos. 528 | 529 | 530 | Section FinRel. 531 | Context {T : finType}. 532 | Implicit Types (R : hrel T T) (r : rel T). 533 | 534 | Lemma connect_strE r : 535 | (r : {fhrel T & T})^* \== (connect r). 536 | Proof. done. Qed. 537 | 538 | Lemma connect_strP r x y : 539 | reflect ((r : hRel T T)^* x y) (connect r x y). 540 | Proof. by move=> /=; apply/(equivP idP)/connect_iter. Qed. 541 | 542 | End FinRel. 543 | 544 | (* ************************************************************************** *) 545 | (* Auxiliary definitions and lemmas about binary relations *) 546 | (* ************************************************************************** *) 547 | 548 | Section RelAux. 549 | 550 | Context {T : Type}. 551 | Implicit Types (R : hrel T T) (r : rel T). 552 | 553 | Definition minimal R x := forall y, R y x -> x = y. 554 | 555 | Definition maximal R x := forall y, R x y -> x = y. 556 | 557 | Lemma minimal_maximal R : minimal R \== maximal R°. 558 | Proof. by rewrite /cnv /= /hrel_cnv /minimal /maximal. Qed. 559 | 560 | (* TODO: relax to `leq` ? *) 561 | Instance minimal_weq : 562 | Proper (weq ==> weq) minimal. 563 | Proof. 564 | rewrite /minimal; move=> R1 R2 H x. 565 | by split; move=> + y /H; move=> /[apply]. 566 | Qed. 567 | 568 | Instance maximal_weq : 569 | Proper (weq ==> weq) maximal. 570 | Proof. 571 | move=> R1 R2. rewrite -!minimal_maximal. 572 | by move=> /cnv_weq; apply: minimal_weq. 573 | Qed. 574 | 575 | Lemma minimal_str R : minimal R \== minimal R^*. 576 | Proof. 577 | move=> s; split=> [/[swap] ? /[swap]|/[swap] s' /(_ s') I /(str_ext R)/I //]. 578 | suff: R^* \<= (fun s s' => minimal R s' -> s' = s). 579 | - by move=> /[apply] /[apply]. 580 | apply/str_ind_l1=> ?? // [? ++ /[dup]]. 581 | move=> H /[apply]; move: H=> /[swap] ->. 582 | by move=> /[swap] /[apply]. 583 | Qed. 584 | 585 | Lemma maximal_str R : maximal R \== maximal R^*. 586 | Proof. by rewrite -!minimal_maximal minimal_str -kleene.cnvstr. Qed. 587 | 588 | End RelAux. 589 | -------------------------------------------------------------------------------- /theories/common/rel.v: -------------------------------------------------------------------------------- 1 | From Coq Require Import Relations Relation_Operators. 2 | From RelationAlgebra Require Import lattice monoid rel kat_tac. 3 | From mathcomp Require Import ssreflect ssrbool ssrfun ssrnat zify. 4 | From mathcomp Require Import eqtype choice seq order path. 5 | From mathcomp Require Import fintype finfun fingraph finmap. 6 | From mathcomp.tarjan Require Import extra acyclic kosaraju acyclic_tsorted. 7 | From Equations Require Import Equations. 8 | From eventstruct Require Import utils seq rel_algebra wftype. 9 | 10 | (******************************************************************************) 11 | (* Auxiliary definitions and lemmas about binary decidable relations. *) 12 | (* *) 13 | (* sfrel f == a relation corresponding to non-deterministic function *) 14 | (* (i.e. list-valued function). A generalization of frel. *) 15 | (* Given a function f, sfrel denotes a relation consisting *) 16 | (* of pairs , s.t. x \in f y *) 17 | (* TODO: currently, the direction of the relation is *) 18 | (* reversed compared to frel, we'll fix that later. *) 19 | (* strictify f == given a non-deterministic function, removes all the *) 20 | (* elements equal to the argument of the function. *) 21 | (* It can be used to obtain a strict (i.e. irreflexive) *) 22 | (* relation corresponding to f. *) 23 | (* suffix f == given a well-founded function f and an element x, *) 24 | (* returns a strict suffix of x, i.e. a set { y | x R y } *) 25 | (* where R ::= sfrel f. *) 26 | (* wsuffix f == a weak (reflexive) suffix, i.e. a set { y | x R? y } *) 27 | (* t_closure f == given a well-founded function f returns its *) 28 | (* transitive closure as a decidable relation. *) 29 | (* t_closure f \== (sfrel f)^+ *) 30 | (* rt_closure f == given a well-founded function f returns its *) 31 | (* reflexive-transitive closure as a decidable relation, *) 32 | (* t_closure f \== (sfrel f)^* *) 33 | (******************************************************************************) 34 | 35 | 36 | Set Implicit Arguments. 37 | Unset Strict Implicit. 38 | Unset Printing Implicit Defensive. 39 | 40 | Set Equations Transparent. 41 | 42 | Import Order.LTheory. 43 | Local Open Scope order_scope. 44 | Local Open Scope rel_scope. 45 | 46 | Section Rel. 47 | Context {T : Type}. 48 | Implicit Types (r : rel T). 49 | 50 | Lemma refl_cap r1 r2 : 51 | reflexive r1 -> reflexive r2 -> reflexive (r1 \& r2). 52 | Proof. by move=> refl1 refl2 x /=; apply/andP. Qed. 53 | 54 | Lemma antisym_cap r1 r2 : 55 | antisymmetric r1 -> antisymmetric (r1 \& r2). 56 | Proof. 57 | move=> asym x y /=. 58 | rewrite -andbA=> /and4P[????]. 59 | by apply/asym/andP. 60 | Qed. 61 | 62 | Lemma trans_cap r1 r2 : 63 | transitive r1 -> transitive r2 -> transitive (r1 \& r2). 64 | Proof. 65 | move=> trans1 trans2 z x y /=. 66 | move=> /andP[??] /andP[??]; apply/andP. 67 | by firstorder. 68 | Qed. 69 | 70 | Lemma sub_irrefl r1 r2 : 71 | subrel r1 r2 -> irreflexive r2 -> irreflexive r1. 72 | Proof. by move=> sub irr x; apply/idP=> /sub; rewrite irr. Qed. 73 | 74 | Lemma sub_antisym r1 r2 : 75 | subrel r1 r2 -> antisymmetric r2 -> antisymmetric r1. 76 | Proof. move=> sub anti x y /andP[??]; apply/anti/andP; split; exact/sub. Qed. 77 | 78 | Lemma eq_irrefl r1 r2 : 79 | r1 =2 r2 -> irreflexive r1 <-> irreflexive r2. 80 | Proof. 81 | move=> eqr; split=> irr x. 82 | - rewrite -eqr; exact/irr. 83 | rewrite eqr; exact/irr. 84 | Qed. 85 | 86 | Lemma eq_antisym r1 r2 : 87 | r1 =2 r2 -> antisymmetric r1 <-> antisymmetric r2. 88 | Proof. 89 | move=> eqr; split=> anti x y. 90 | - rewrite -eqr -eqr; exact/anti. 91 | rewrite !eqr; exact/anti. 92 | Qed. 93 | 94 | Lemma eq_trans r1 r2 : 95 | r1 =2 r2 -> transitive r1 <-> transitive r2. 96 | Proof. 97 | move=> eqr; split=> trans z x y. 98 | - rewrite -?eqr; exact/trans. 99 | rewrite ?eqr; exact/trans. 100 | Qed. 101 | 102 | End Rel. 103 | 104 | Section ClosRefl. 105 | Context {T : eqType}. 106 | Implicit Types (r : {hrel T & T}). 107 | 108 | Lemma dhrel_qmkE r : 109 | r^? =2 [rel x y | (x == y) || (r x y)]. 110 | Proof. done. Qed. 111 | 112 | Lemma qmk_refl r : 113 | reflexive r^?. 114 | Proof. by move=> x; rewrite dhrel_qmkE /= eqxx. Qed. 115 | 116 | Lemma qmk_antisym r : 117 | antisymmetric r -> antisymmetric r^?. 118 | Proof. 119 | move=> asym x y; rewrite !dhrel_qmkE /=. 120 | move=> /andP[] /orP[/eqP->|?] // /orP[/eqP->|?] //. 121 | by apply/asym/andP. 122 | Qed. 123 | 124 | Lemma qmk_trans r : 125 | transitive r -> transitive r^?. 126 | Proof. 127 | move=> trans z x y; rewrite !dhrel_qmkE /=. 128 | move=> /orP[/eqP<-|rxz] // /orP[/eqP<-|rzy] //. 129 | apply/orP; right; apply/trans; [exact/rxz|exact/rzy]. 130 | Qed. 131 | 132 | End ClosRefl. 133 | 134 | Section SubRelLift. 135 | Context {T : eqType} {U : Type} {P : pred T} {S : subType P}. 136 | 137 | Lemma sub_rel_lift_qmk (r : {hrel S & S}) : 138 | (sub_rel_lift r : {hrel T & T})^? =2 (sub_rel_lift r^? : {hrel T & T})^?. 139 | Proof. 140 | move=> x y; rewrite !dhrel_qmkE /=. 141 | apply/idP/idP=> [/orP[|]|]. 142 | - by move=> /eqP->; rewrite eqxx. 143 | - move=> /sub_rel_liftP[] x' [] y' [] ? <- <-. 144 | apply/orP; right; apply/sub_rel_liftP. 145 | exists x', y'; split=> //=. 146 | by apply/orP; right. 147 | move=> /orP[/eqP->|]; rewrite ?eqxx //. 148 | move=> /sub_rel_liftP[] x' [] y' [] /= + <- <-. 149 | move=> /orP[/eqP->|]; rewrite ?eqxx //. 150 | move=> ?; apply/orP; right; apply/sub_rel_liftP. 151 | by exists x', y'. 152 | Qed. 153 | 154 | End SubRelLift. 155 | 156 | Section FinGraph. 157 | Context {T : finType}. 158 | Implicit Types (g : rel T). 159 | Implicit Types (gf : T -> seq T). 160 | 161 | Definition irreflexiveb g := 162 | [forall x, ~~ g x x]. 163 | 164 | Definition antisymmetricb g := 165 | [forall x, forall y, g x y && g y x ==> (x == y)]. 166 | 167 | Definition totalb g := 168 | [forall x, forall y, g x y || g y x]. 169 | 170 | Lemma irreflexiveP g : 171 | reflect (irreflexive g) (irreflexiveb g). 172 | Proof. apply/forallPP=> ?; exact/negPf. Qed. 173 | 174 | Lemma antisymmetricP g : 175 | reflect (antisymmetric g) (antisymmetricb g). 176 | Proof. do 2 apply/forallPP=> ?; exact/(implyPP idP)/eqP. Qed. 177 | 178 | Lemma totalP g : 179 | reflect (total g) (totalb g). 180 | Proof. exact/forall2P. Qed. 181 | 182 | Lemma connect_refl g : 183 | reflexive (connect g). 184 | Proof. done. Qed. 185 | 186 | Lemma preacyclicE g : 187 | preacyclic g = antisymmetricb (connect g). 188 | Proof. done. Qed. 189 | 190 | Lemma acyclicE g : 191 | acyclic g = irreflexiveb g && antisymmetricb (connect g). 192 | Proof. done. Qed. 193 | 194 | Lemma acyc_irrefl g : 195 | acyclic g -> irreflexive g. 196 | Proof. 197 | move=> /acyclicP[irr _] x. 198 | move: (irr x)=> /negP ?; exact/negP. 199 | Qed. 200 | 201 | Lemma acyc_antisym g : 202 | acyclic g -> antisymmetric (connect g). 203 | Proof. 204 | move=> /acyclic_symconnect_eq symconE x y. 205 | move: (symconE x y); rewrite /symconnect. 206 | by move=> -> /eqP. 207 | Qed. 208 | 209 | Lemma mem_tseq gf : 210 | tseq gf =i enum T. 211 | Proof. 212 | move: (tseq_correct gf)=> [_ in_tseq]. 213 | apply/subset_eqP/andP; split; apply/subsetP; last first. 214 | - move=> x ?; exact/in_tseq. 215 | by move=> ?; rewrite mem_enum. 216 | Qed. 217 | 218 | Lemma size_tseq gf : 219 | size (tseq gf) = #|T|. 220 | Proof. 221 | rewrite cardT; apply/eqP. 222 | rewrite -uniq_size_uniq. 223 | - exact/tseq_uniq. 224 | - exact/enum_uniq. 225 | move=> ?; exact/esym/mem_tseq. 226 | Qed. 227 | 228 | End FinGraph. 229 | 230 | Section SubFinGraph. 231 | Context {T : choiceType} {fT : {fset T}}. 232 | Implicit Types (g : rel fT). 233 | 234 | Lemma sub_rel_lift_connect g : 235 | (sub_rel_lift g : hrel T T)^* \== (sub_rel_lift (connect g) : hrel T T)^?. 236 | Proof. 237 | move=> x y; split. 238 | - move=> /clos_rt_str; elim. 239 | + move=> {}x {}y /=. 240 | rewrite /sub_rel_lift /=. 241 | case: insubP=> //. 242 | case: insubP=> //. 243 | move=> ???????; right; exact/connect1. 244 | + by move=> {}x /=; left. 245 | move=> ???? [->|xy] ? [<-|yz] /=; [left|right|right|] => //. 246 | right; apply/(sub_rel_lift_trans _ xy yz). 247 | exact/connect_trans. 248 | move=> xy; apply/clos_rt_str. 249 | move: xy; rewrite /sub_rel_lift /=. 250 | move=> [->|]. 251 | - exact/rt_refl. 252 | case: insubP=> //. 253 | case: insubP=> //. 254 | move=> /= y' yIn <- x' xIn <-. 255 | move=> /connect_strP/clos_rt_str; elim. 256 | - move=> /= x'' y'' xy; apply/rt_step. 257 | rewrite !insubT //. 258 | move=> ??; rewrite !sub_val //. 259 | - move=> ?; exact/rt_refl. 260 | move=> ???? xy ? yz; apply/rt_trans; [exact/xy | exact/yz]. 261 | Qed. 262 | 263 | End SubFinGraph. 264 | 265 | Section RelMono. 266 | Context {T U : Type}. 267 | Variables (f : T -> U) (g1 : rel T) (g2 : rel U). 268 | Hypothesis (fbij : bijective f). 269 | Hypothesis (fmon : {mono f : x y / g1 x y >-> g2 x y}). 270 | 271 | Lemma irreflexive_mono : 272 | (irreflexive g1) <-> (irreflexive [rel x y | g2 (f x) (f y)]). 273 | Proof. 274 | split=> irr x /=. 275 | - by rewrite fmon. 276 | rewrite -fmon; exact/irr. 277 | Qed. 278 | 279 | Lemma antisymmetric_mono : 280 | (antisymmetric g1) <-> (antisymmetric [rel x y | g2 (f x) (f y)]). 281 | Proof. 282 | split=> asym x y /=. 283 | - rewrite !fmon; exact/asym. 284 | rewrite -fmon -fmon; exact/asym. 285 | Qed. 286 | 287 | End RelMono. 288 | 289 | Section FinGraphMono. 290 | Context {T U : finType}. 291 | Implicit Types (f : T -> U) (gT : rel T) (gU : rel U). 292 | 293 | Lemma connect_mono f gT gU : bijective f -> 294 | {mono f : x y / gT x y >-> gU x y} -> 295 | {mono f : x y / connect gT x y >-> connect gU x y}. 296 | Proof. 297 | move=> fbij fmon x y; apply/idP/idP; last first. 298 | all: move=> /connect_strP/clos_rt_str/=> crt. 299 | all: apply/connect_strP/clos_rt_str. 300 | - elim: crt=> // [|??? _ + _]; last exact/rt_trans. 301 | move=> {}x {}y; rewrite -fmon; exact/rt_step. 302 | move: fbij=> [g] K K'. 303 | rewrite -[x]K -[y]K. 304 | elim: crt=> // [|??? _ + _]; last exact/rt_trans. 305 | move=> {}x {}y; rewrite -[x]K' -[y]K' fmon=> ?. 306 | by apply/rt_step; rewrite !K. 307 | Qed. 308 | 309 | End FinGraphMono. 310 | 311 | (* TODO: rename? consult theory? unify with strictify? *) 312 | Section IKer. 313 | Context {T : eqType}. 314 | Implicit Type (r : rel T). 315 | 316 | Definition iker r : rel T := 317 | fun x y => (y != x) && r x y. 318 | 319 | Lemma iker_qmk r : 320 | iker (r : {hrel T & T})^? =2 iker r. 321 | Proof. 322 | move=> x y; rewrite /iker dhrel_qmkE /=. 323 | rewrite andb_orr orb_idl //. 324 | by rewrite eq_sym=> /andP[] /negP. 325 | Qed. 326 | 327 | Lemma qmk_iker r : 328 | reflexive r -> (iker r : {hrel T & T})^? =2 r. 329 | Proof. 330 | move=> refl x y ; rewrite dhrel_qmkE /= /iker. 331 | apply/idP/idP=> [/orP[|]|]. 332 | - by move=> /eqP->; rewrite refl. 333 | - by move=> /andP[]. 334 | move=> ->; rewrite andbT. 335 | case: (x == y)/idP=> //. 336 | by rewrite eq_sym=> /negP ->. 337 | Qed. 338 | 339 | Lemma iker_irrefl r : 340 | irreflexive (iker r). 341 | Proof. by move=> x; rewrite /iker eqxx. Qed. 342 | 343 | Lemma iker_antisym r : 344 | antisymmetric r -> antisymmetric (iker r). 345 | Proof. 346 | move=> asym x y /andP[] /andP[??] /andP[??]. 347 | exact/asym/andP. 348 | Qed. 349 | 350 | Lemma iker_trans r : 351 | antisymmetric r -> transitive r -> transitive (iker r). 352 | Proof. 353 | move=> asym trans z x y /andP[/eqP nzx rxz] /andP[/eqP nzy rzy]. 354 | apply/andP; split; last first. 355 | - apply/trans; [exact/rxz|exact/rzy]. 356 | apply/negP=> /eqP eyx. 357 | by apply/nzx/asym/andP; split=> //; rewrite -eyx. 358 | Qed. 359 | 360 | End IKer. 361 | 362 | Section Covering. 363 | Context {T : finType}. 364 | Implicit Types (r : rel T). 365 | 366 | Definition gfun r := 367 | fun x => filter (r x) (enum T). 368 | 369 | Lemma gfun_inE r x y : 370 | y \in (gfun r x) = r x y. 371 | Proof. by rewrite /gfun mem_filter mem_enum inE andbT. Qed. 372 | 373 | Definition cov r : rel T := 374 | [rel x y | [&& (x != y) , (r x y) & ~~ [exists z, r x z && r z y]]]. 375 | 376 | Definition cov_tseq r x y := 377 | let t := tseq (rgraph r) in 378 | let p := [pred z | r x z && r z y] in 379 | let ix := index x t in 380 | let iy := index y t in 381 | ~~ has p (slice ix iy t). 382 | (* [rel x y | index y t - (index x t).+1 == find (r x) (drop (index x t).+1 t)]. *) 383 | 384 | Lemma cov_subrel r : 385 | subrel (cov r) r. 386 | Proof. by move=> ?? /and3P[]. Qed. 387 | 388 | (* TODO: reformulate in terms of relation algebra? *) 389 | Lemma covP r x y : 390 | reflect [/\ x <> y , r x y & ~ exists z, r x z && r z y] (cov r x y). 391 | Proof. 392 | rewrite /cov; apply/(equivP and3P). 393 | split; case=> ???; split=> //; try exact/eqP; 394 | exact/(negPP existsP). 395 | Qed. 396 | 397 | Lemma cov_irrefl r : 398 | irreflexive (cov r). 399 | Proof. by move=> x; apply/negP=> /andP[]; rewrite eq_refl. Qed. 400 | 401 | Lemma cov_sliceP r x y : 402 | let t := tseq (rgraph r) in 403 | let p := [pred z | r x z && r z y] in 404 | let ix := index x t in 405 | let iy := index y t in 406 | (* *) 407 | acyclic r -> reflect (exists z, r x z && r z y) 408 | (has p (slice ix iy t)). 409 | Proof. 410 | move=> /= acyc; apply/(equivP idP); split. 411 | - by move=> /hasP[z] zIn /= ?; exists z. 412 | move=> [z] /andP[rxz rzy]. 413 | apply/hasP; exists z=> //=; last exact/andP. 414 | rewrite in_slice_index; last first. 415 | - exact/tseq_uniq. 416 | - apply/andP; split; last exact/index_size. 417 | apply/(tseq_rel_connect_before acyc). 418 | apply/connect_trans; apply/connect1; [exact/rxz | exact/rzy]. 419 | apply/andP; split. 420 | - move: rxz=> /[dup] rxz. 421 | move=> /connect1/(tseq_rel_connect_before acyc). 422 | by rewrite /before. 423 | move: rzy=> /[dup] rzy. 424 | move=> /connect1/(tseq_rel_connect_before acyc). 425 | rewrite /before leq_eqVlt=> /orP[/eqP|] //. 426 | move=> /index_inj eq_zy; exfalso. 427 | move: (acyc_irrefl acyc)=> irr; move: (irr z). 428 | by rewrite {2}eq_zy ?rzy ?mem_tseq ?mem_enum. 429 | Qed. 430 | 431 | Lemma cov_connect r x y : 432 | acyclic r -> r x y -> connect (cov r) x y. 433 | Proof. 434 | move=> acyc rxy. 435 | pose t := tseq (rgraph r). 436 | pose p := [pred z | r x z && r z y]. 437 | pose ix := index x t. 438 | pose iy := index y t. 439 | pose s := slice ix iy t. 440 | have [n leN] := ubnP (size s). 441 | subst t p ix iy s. 442 | move: x y rxy leN; elim: n=> // n IH x y rxy. 443 | pose t := tseq (rgraph r). 444 | pose p := [pred z | r x z && r z y]. 445 | pose ix := index x t. 446 | pose iy := index y t. 447 | pose s := slice ix iy t. 448 | rewrite -/t -/s -/ix -/iy => sz. 449 | case: (x == y)/idP => [/eqP->|/negP/eqP neq_xy] //. 450 | case: (has p s)/idP; last first. 451 | - move=> hasN; apply/connect1. 452 | apply/covP; split=> //. 453 | by move=> /(cov_sliceP _ _ acyc). 454 | move=> /hasP[z] zIn /andP[rxz rzy]. 455 | pose iz := index z t. 456 | have iy_sz: (iy <= size t)%N. 457 | - by apply/ltnW; rewrite index_mem mem_tseq mem_enum. 458 | have iz_sz: (iz <= size t)%N. 459 | - by apply/ltnW; rewrite index_mem mem_tseq mem_enum. 460 | have : (ix <= iz < iy)%N. 461 | - rewrite -in_slice_index //; last exact/tseq_uniq. 462 | apply/andP; split=> //. 463 | apply/(tseq_rel_connect_before acyc). 464 | apply/connect_trans; apply/connect1; [exact/rxz | exact/rzy]. 465 | move=> /andP[]; rewrite leq_eqVlt=> /orP[/eqP|] // => [+ _|ixz izy]. 466 | - move: rxz=> /[swap] /index_inj ->; rewrite ?mem_tseq ?mem_enum //. 467 | by rewrite (acyc_irrefl acyc). 468 | apply/(@connect_trans _ _ z); apply/IH=> //. 469 | all: rewrite -/ix -/iy -/iz -/t. 470 | all: move: sz; rewrite /s !size_slice //; lia. 471 | Qed. 472 | 473 | Lemma connect_covE r x y : 474 | acyclic r -> connect (cov r) x y = connect r x y. 475 | Proof. 476 | move=> acyc; apply/idP/idP. 477 | - by apply/connect_sub=> {}x {}y /covP[? /connect1]. 478 | apply/connect_sub=> {}x {}y; exact/cov_connect. 479 | Qed. 480 | 481 | Lemma iker_connect r : 482 | connect (iker r) =2 connect r. 483 | Proof. 484 | move=> x y; apply/(sameP (connect_strP _ _ _))/(equivP (connect_strP _ _ _)). 485 | rewrite kleene.str_weq1; first reflexivity. 486 | rewrite -qmk_sub_one; first apply/qmk_weq=> ?? /=. 487 | - rewrite /iker eq_sym. 488 | split=> [[]|/andP[/eqP ?]] * //. 489 | by apply/andP; split=> //; apply/eqP. 490 | move=> a b /=; split=> // ?; case: (a =P b); by (left+right). 491 | Qed. 492 | 493 | End Covering. 494 | 495 | (* TODO: rename to `mrel` and move to `monad.v` ? *) 496 | Definition sfrel {T : eqType} (f : T -> seq T) : {hrel T & T} := 497 | [rel a b | b \in f a]. 498 | 499 | Section Strictify. 500 | Context {T : eqType}. 501 | Implicit Type (f : T -> seq T). 502 | 503 | Definition strictify f : T -> seq T := 504 | fun x => filter^~ (f x) (fun y => x != y). 505 | 506 | Lemma strictify_weq f : 507 | sfrel (strictify f) \== (sfrel f \\ eq_op). 508 | Proof. 509 | move=> x y; rewrite /sfrel /strictify /=. 510 | by rewrite mem_filter andbC. 511 | Qed. 512 | 513 | Lemma strictify_leq f : 514 | sfrel (strictify f) \<= sfrel f. 515 | Proof. by rewrite strictify_weq; lattice. Qed. 516 | 517 | End Strictify. 518 | 519 | Set Strict Implicit. 520 | 521 | Module WfClosure. 522 | 523 | Section WfRTClosure. 524 | 525 | Context {disp : unit} {T : wfType disp}. 526 | 527 | Variable (f : T -> seq T). 528 | 529 | (* Hypothesis descend : forall x y, y \in f x -> y < x. *) 530 | Hypothesis descend : sfrel f \<= (>%O). 531 | 532 | (* A hack to get around a bug in Equations 533 | * (see https://github.com/mattam82/Coq-Equations/issues/241). 534 | * In short, we cannot express this function directly in Equations' syntax 535 | * (we can do it by adding `noind` specifier, but then we cannot use `funelim`). 536 | * Thus we have to "tie a recursive knot" manually. 537 | *) 538 | Definition suffix_aux (x : T) (rec : forall y : T, y < x -> seq T) := 539 | let ys := f x in 540 | let ps := flatten (map^~ (seq_in ys) (fun y => 541 | rec (val y) (descend _ _ (valP y)) 542 | )) in 543 | ys ++ ps. 544 | 545 | (* strict suffix of an element `x`, i.e. a set { y | x R y } *) 546 | Equations suffix (x : T) : seq T by wf x (<%O : rel T) := 547 | suffix x := suffix_aux x suffix. 548 | 549 | (* weak suffix of an element `x`, i.e. a set { y | x R? y } *) 550 | Definition wsuffix (x : T) : seq T := 551 | x :: suffix x. 552 | 553 | (* decidable transitive closure *) 554 | Definition t_closure : {hrel T & T} := 555 | fun x y => y \in suffix x. 556 | 557 | (* decidable reflexive-transitive closure *) 558 | Definition rt_closure : {hrel T & T} := 559 | fun x y => y \in wsuffix x. 560 | 561 | (* ************************************************************************** *) 562 | (* THEORY *) 563 | (* ************************************************************************** *) 564 | 565 | Lemma t_closure_1nP x y : 566 | reflect (clos_trans_1n (sfrel f) x y) (t_closure x y). 567 | Proof. 568 | rewrite /t_closure; funelim (suffix x)=> /=. 569 | apply /(iffP idP); rewrite mem_cat /sfrel /=. 570 | - move=> /orP[|/flatten_mapP[z]] //; first exact: t1n_step. 571 | move=> S /X H. apply: t1n_trans (valP z) _. 572 | by apply: H=> //=; apply: descend (valP z). 573 | move: X=> /[swap] [[?->//|{}y ? /[dup] ? L /[swap]]]. 574 | move=> /[apply] H; apply/orP; right; apply/flatten_mapP. 575 | eexists; first by apply: seq_in_mem L. 576 | by apply /H=> //=; apply: descend. 577 | Qed. 578 | 579 | Lemma t_closureP x y : 580 | reflect (clos_trans (sfrel f) x y) (t_closure x y). 581 | Proof. 582 | apply /(equivP (t_closure_1nP x y)). 583 | symmetry; exact: clos_trans_t1n_iff. 584 | Qed. 585 | 586 | Lemma clos_trans_gt : 587 | clos_trans (sfrel f) \<= (>%O : rel T). 588 | Proof. 589 | move=> ??; rewrite/sfrel /=. 590 | elim=> [y z /descend | x y z _ ] //=. 591 | move=> /[swap] _ /[swap]; exact: lt_trans. 592 | Qed. 593 | 594 | Lemma t_closure_gt : t_closure \<= (>%O : rel T). 595 | Proof. by move=> x y /t_closureP /clos_trans_gt. Qed. 596 | 597 | Lemma t_closure_antisym : antisymmetric t_closure. 598 | Proof. 599 | move=> x y /andP[] /t_closure_gt ? /t_closure_gt ?. 600 | by apply /eqP; rewrite eq_le !ltW. 601 | Qed. 602 | 603 | Lemma t_closure_trans : transitive t_closure. 604 | Proof. 605 | move=> y x z /t_closureP ? /t_closureP ?. 606 | apply /t_closureP /t_trans; eauto. 607 | Qed. 608 | 609 | Lemma rt_closureP x y : 610 | reflect (clos_refl_trans (sfrel f) x y) (rt_closure x y). 611 | Proof. 612 | apply /equivP; last first. 613 | { rewrite clos_rt_crE clos_r_qmk. 614 | apply or_iff_compat_l; symmetry. 615 | apply rwP; exact: t_closureP. } 616 | rewrite /t_closure /rt_closure /wsuffix in_cons eq_sym /=. 617 | by apply predU1P. 618 | Qed. 619 | 620 | Lemma rt_closureE : rt_closure \== t_closure^?. 621 | Proof. 622 | move=> x y /=; rewrite /rt_closure /t_closure /wsuffix. 623 | by rewrite /hrel_one in_cons eq_sym. 624 | Qed. 625 | 626 | Lemma rt_closure_ge : rt_closure \<= (>=%O : rel T). 627 | Proof. 628 | rewrite rt_closureE. 629 | move=> x y /orP[/eqP<-//=|]. 630 | move=> /t_closure_gt; exact: ltW. 631 | Qed. 632 | 633 | Lemma rt_closure_refl x : rt_closure x x. 634 | Proof. rewrite /rt_closure /= /wsuffix; exact/mem_head. Qed. 635 | 636 | Lemma rt_closure_antisym : antisymmetric rt_closure. 637 | Proof. 638 | move=> x y /andP[]. 639 | move=> /rt_closure_ge /= xy /rt_closure_ge /= yx. 640 | by apply /eqP; rewrite eq_le xy yx. 641 | Qed. 642 | 643 | Lemma rt_closure_trans : transitive rt_closure. 644 | Proof. 645 | move=> y x z /rt_closureP xy /rt_closureP ?. 646 | by apply/rt_closureP; apply: rt_trans xy _. 647 | Qed. 648 | 649 | End WfRTClosure. 650 | 651 | End WfClosure. 652 | -------------------------------------------------------------------------------- /theories/common/ident.v: -------------------------------------------------------------------------------- 1 | From mathcomp Require Import ssreflect ssrfun ssrbool ssrnat seq path. 2 | From mathcomp Require Import finmap choice eqtype order zify. 3 | From eventstruct Require Import utils inhtype order wftype. 4 | 5 | (******************************************************************************) 6 | (* This file contains a theory of types that can be used as identifiers. *) 7 | (* Essentially, a type of identifiers is an infinite countable type. *) 8 | (* *) 9 | (* identType == interface for types which behave as identifiers. *) 10 | (* \i0, \i1 == some distinguished identifiers. *) 11 | (* fresh i == allocates a fresh identifier which is guaranteed to *) 12 | (* differ from i. *) 13 | (* nfresh i n == allocates n fresh identifier which are guaranteed to *) 14 | (* differ from i. *) 15 | (* fresh_seq s == allocates a fresh identifier which is guaranteed to *) 16 | (* differ from all identifiers from the list s *) 17 | (* *) 18 | (* Elements of identType also can be converted to natural numbers and back *) 19 | (* from natural numbers. This conversion also induces a total well-founded *) 20 | (* order on identifiers. *) 21 | (* encode i == converts the identifier i into a natural number. *) 22 | (* decode n == converts the natural number n into an identifier. *) 23 | (* x <=^i y == a total well-founded order on identifiers induced *) 24 | (* by the conversion to natural numbers. *) 25 | (* That is x <=^i y iff encode x <= encode y. *) 26 | (* All conventional order notations are defined with *) 27 | (* the suffix _^i as well. *) 28 | (* *) 29 | (* This file also contains canonical instance of identType for nat. *) 30 | (******************************************************************************) 31 | 32 | Set Implicit Arguments. 33 | Unset Strict Implicit. 34 | Unset Printing Implicit Defensive. 35 | 36 | Import Order.LTheory. 37 | Import Order.Theory. 38 | Import Order.TTheory. 39 | Open Scope order_scope. 40 | 41 | Declare Scope ident_scope. 42 | Delimit Scope ident_scope with ident. 43 | 44 | Local Open Scope ident_scope. 45 | 46 | (* Notation for initial identifier *) 47 | Reserved Notation "\i0" (at level 0). 48 | Reserved Notation "\i1" (at level 0). 49 | 50 | (* Notations for canonical order on identifiers *) 51 | Reserved Notation "x <=^i y" (at level 70, y at next level). 52 | Reserved Notation "x >=^i y" (at level 70, y at next level). 53 | Reserved Notation "x <^i y" (at level 70, y at next level). 54 | Reserved Notation "x >^i y" (at level 70, y at next level). 55 | Reserved Notation "x <=^i y :> T" (at level 70, y at next level). 56 | Reserved Notation "x >=^i y :> T" (at level 70, y at next level). 57 | Reserved Notation "x <^i y :> T" (at level 70, y at next level). 58 | Reserved Notation "x >^i y :> T" (at level 70, y at next level). 59 | Reserved Notation "<=^i y" (at level 35). 60 | Reserved Notation ">=^i y" (at level 35). 61 | Reserved Notation "<^i y" (at level 35). 62 | Reserved Notation ">^i y" (at level 35). 63 | Reserved Notation "<=^i y :> T" (at level 35, y at next level). 64 | Reserved Notation ">=^i y :> T" (at level 35, y at next level). 65 | Reserved Notation "<^i y :> T" (at level 35, y at next level). 66 | Reserved Notation ">^i y :> T" (at level 35, y at next level). 67 | Reserved Notation "x >=<^i y" (at level 70, no associativity). 68 | Reserved Notation ">=<^i y" (at level 35). 69 | Reserved Notation ">=<^i y :> T" (at level 35, y at next level). 70 | Reserved Notation "x ><^i y" (at level 70, no associativity). 71 | Reserved Notation "><^i x" (at level 35). 72 | Reserved Notation "><^i y :> T" (at level 35, y at next level). 73 | Reserved Notation "x <=^i y <=^i z" (at level 70, y, z at next level). 74 | Reserved Notation "x <^i y <=^i z" (at level 70, y, z at next level). 75 | Reserved Notation "x <=^i y <^i z" (at level 70, y, z at next level). 76 | Reserved Notation "x <^i y <^i z" (at level 70, y, z at next level). 77 | Reserved Notation "x <=^i y ?= 'iff' c" (at level 70, y, c at next level, 78 | format "x '[hv' <=^i y '/' ?= 'iff' c ']'"). 79 | Reserved Notation "x <=^i y ?= 'iff' c :> T" (at level 70, y, c at next level, 80 | format "x '[hv' <=^i y '/' ?= 'iff' c :> T ']'"). 81 | Reserved Notation "x <^i y ?<= 'if' c" (at level 70, y, c at next level, 82 | format "x '[hv' <^i y '/' ?<= 'if' c ']'"). 83 | Reserved Notation "x <^i y ?<= 'if' c :> T" (at level 70, y, c at next level, 84 | format "x '[hv' <^i y '/' ?<= 'if' c :> T ']'"). 85 | 86 | Module Ident. 87 | Section ClassDef. 88 | 89 | Record mixin_of T0 (b : Countable.class_of T0) 90 | (T := Countable.Pack b) := Mixin { 91 | _ : forall n, @unpickle T n; 92 | _ : injective (@unpickle T) 93 | }. 94 | 95 | Set Primitive Projections. 96 | Record class_of (T : Type) := Class { 97 | base : Countable.class_of T; 98 | mixin : mixin_of base; 99 | }. 100 | Unset Primitive Projections. 101 | 102 | Local Coercion base : class_of >-> Countable.class_of. 103 | 104 | Structure type := Pack { sort; _ : class_of sort }. 105 | 106 | Local Coercion sort : type >-> Sortclass. 107 | 108 | Variables (T : Type) (cT : type). 109 | 110 | Definition class := let: Pack _ c as cT' := cT return class_of cT' in c. 111 | Definition clone c of phant_id class c := @Pack T c. 112 | 113 | Definition pack := 114 | fun bT b & phant_id (@Countable.class bT) b => 115 | fun m => Pack (@Class T b m). 116 | 117 | Definition eqType := @Equality.Pack cT class. 118 | Definition choiceType := @Choice.Pack cT class. 119 | Definition countType := @Countable.Pack cT class. 120 | 121 | End ClassDef. 122 | 123 | Module Export Exports. 124 | Coercion base : class_of >-> Countable.class_of. 125 | Coercion sort : type >-> Sortclass. 126 | Coercion eqType : type >-> Equality.type. 127 | Coercion choiceType : type >-> Choice.type. 128 | Coercion countType : type >-> Countable.type. 129 | Canonical eqType. 130 | Canonical choiceType. 131 | Canonical countType. 132 | Notation identType := type. 133 | Notation IdentType T m := (@pack T _ _ id m). 134 | Notation "[ 'identType' 'of' T 'for' cT ]" := (@clone T cT _ id) 135 | (at level 0, format "[ 'identType' 'of' T 'for' cT ]") : form_scope. 136 | Notation "[ 'identType' 'of' T ]" := [identType of T for _] 137 | (at level 0, format "[ 'identType' 'of' T ]") : form_scope. 138 | End Exports. 139 | 140 | Module Export Def. 141 | 142 | Definition unpickle_tot {T : identType} n : @unpickle T n. 143 | Proof. by case: T=> ? [? []]. Defined. 144 | 145 | Notation encode (* : T -> nat *) := (pickle). 146 | Notation decode (* : nat -> T *) := (mk_total unpickle_tot). 147 | 148 | Section Def. 149 | Context {T : identType}. 150 | 151 | Definition ident0 : T := 152 | decode 0%nat. 153 | 154 | Definition ident1 : T := 155 | decode 1%nat. 156 | 157 | Definition fresh : T -> T := 158 | fun x => decode (1 + encode x). 159 | 160 | Definition nfresh : T -> nat -> seq T := 161 | fun i n => traject fresh i n. 162 | 163 | Definition ident_le : rel T := 164 | fun x y => encode x <= encode y. 165 | 166 | Definition ident_lt : rel T := 167 | fun x y => encode x < encode y. 168 | 169 | Definition ident_min : T -> T -> T := 170 | fun x y => decode (minn (encode x) (encode y)). 171 | 172 | Definition ident_max : T -> T -> T := 173 | fun x y => decode (maxn (encode x) (encode y)). 174 | 175 | End Def. 176 | End Def. 177 | 178 | Prenex Implicits fresh ident_le ident_lt. 179 | 180 | Arguments nfresh : simpl never. 181 | 182 | (* basic properties required by canonical instances *) 183 | Module Export Props. 184 | Section Props. 185 | 186 | Context {T : identType}. 187 | Implicit Types (x : T) (s : seq T). 188 | 189 | Lemma unpickle_inj : 190 | injective (@unpickle T). 191 | Proof. by case: T=> ? [/= ? []]. Qed. 192 | 193 | Lemma decode_inj : 194 | injective (decode : nat -> T). 195 | Proof. by apply /mk_total_inj /unpickle_inj. Qed. 196 | 197 | Lemma encodeK : 198 | cancel encode (decode : nat -> T). 199 | Proof. by apply /mk_totalK /pickleK. Qed. 200 | 201 | Lemma decodeK : 202 | cancel decode (encode : T -> nat). 203 | Proof. by apply/inj_can_sym; [exact/encodeK | exact/decode_inj]. Qed. 204 | 205 | Lemma encode0 : 206 | encode (ident0 : T) = 0%nat. 207 | Proof. by rewrite /ident0; exact/decodeK. Qed. 208 | 209 | Lemma encode1 : 210 | encode (ident1 : T) = 1%nat. 211 | Proof. by rewrite /ident1; exact/decodeK. Qed. 212 | 213 | Lemma encode_fresh (e : T) : encode (fresh e) = (encode e).+1. 214 | Proof. rewrite /fresh decodeK; lia. Qed. 215 | 216 | Lemma encode_iter (e : T) n : 217 | encode (iter n fresh e) = (encode e) + n. 218 | Proof. 219 | elim: n=> //= [|?]; first lia. 220 | rewrite encode_fresh; lia. 221 | Qed. 222 | 223 | Lemma encode_inj : injective (@encode T). 224 | Proof. exact/pickle_inj. Qed. 225 | 226 | End Props. 227 | End Props. 228 | 229 | Module Export Inh. 230 | Section Inh. 231 | Context (T : identType). 232 | Implicit Types (x y z : T). 233 | 234 | Lemma disp : unit. 235 | Proof. exact: tt. Qed. 236 | 237 | Definition inhMixin := @Inhabited.Mixin T _ ident0. 238 | Definition inhType := Eval hnf in InhType T disp inhMixin. 239 | 240 | End Inh. 241 | 242 | Module Export Exports. 243 | Canonical inhType. 244 | Coercion inhType : type >-> Inhabited.type. 245 | End Exports. 246 | 247 | End Inh. 248 | 249 | 250 | Module Export Order. 251 | Section Order. 252 | Context (T : identType). 253 | Implicit Types (x y z : T). 254 | 255 | Lemma disp : unit. 256 | Proof. exact: tt. Qed. 257 | 258 | Lemma lt_def x y : (ident_lt x y) = (y != x) && (ident_le x y). 259 | Proof. 260 | rewrite /ident_lt /ident_le. 261 | have ->: (y != x) = (pickle y != pickle x); last exact /lt_def. 262 | case H: (y == x); first by (move: H=> /eqP->; rewrite eq_refl). 263 | move=> /=; apply esym. 264 | move: H=> /eqP /eqP /=. 265 | by apply /contra_neq /pickle_inj. 266 | Qed. 267 | 268 | Lemma meet_def x y : ident_min x y = (if ident_lt x y then x else y). 269 | Proof. 270 | rewrite /ident_min /ident_lt /minn /Order.lt=> /=. 271 | rewrite (mk_totalE ident0). 272 | by case: ifP=> ?; rewrite pickleK /=. 273 | Qed. 274 | 275 | Lemma join_def x y : ident_max x y = (if ident_lt x y then y else x). 276 | Proof. 277 | rewrite /ident_max /ident_lt /maxn /Order.lt=> /=. 278 | rewrite (mk_totalE ident0). 279 | by case: ifP=> ?; rewrite pickleK /=. 280 | Qed. 281 | 282 | Lemma le_anti : antisymmetric (@ident_le T). 283 | Proof. 284 | move=> x y /andP []; rewrite /ident_le=> ??. 285 | by apply /pickle_inj /anti_leq /andP. 286 | Qed. 287 | 288 | Lemma le_trans : transitive (@ident_le T). 289 | Proof. by move=> z x y; rewrite /ident_le; apply leq_trans. Qed. 290 | 291 | Lemma le_total : total (@ident_le T). 292 | Proof. by move=> x y; rewrite /ident_le; apply leq_total. Qed. 293 | 294 | Lemma le0x x : ident_le ident0 x. 295 | Proof. rewrite /ident_le encode0; exact /leq0n. Qed. 296 | 297 | Lemma wfb : well_founded_bool (@ident_lt T). 298 | Proof. 299 | move=> x; rewrite /ident_lt. 300 | rewrite -(encodeK x). 301 | elim/(@wfb_ind _ nat_wfType): (encode x). 302 | constructor=> y. 303 | rewrite decodeK -{2}(encodeK y). 304 | by apply /X. 305 | Qed. 306 | 307 | Definition mixin := 308 | LeOrderMixin lt_def meet_def join_def le_anti le_trans le_total. 309 | 310 | End Order. 311 | 312 | Module Export Exports. 313 | 314 | Implicit Types (T : identType). 315 | 316 | Canonical porderType T := POrderType disp T (@Order.mixin T). 317 | Canonical latticeType T := LatticeType T (@Order.mixin T). 318 | Canonical bLatticeType T := BLatticeType T (BottomMixin (@Order.le0x T)). 319 | Canonical distrLatticeType T := DistrLatticeType T (@Order.mixin T). 320 | Canonical bDistrLatticeType T := [bDistrLatticeType of T]. 321 | Canonical orderType T := OrderType T (@Order.mixin T). 322 | 323 | Canonical wfType T := 324 | let wf_mixin := @WellFounded.Mixin T 325 | (Order.POrder.class (porderType T)) (@Order.wfb T) 326 | in WfType disp T wf_mixin. 327 | 328 | Coercion porderType : type >-> Order.POrder.type. 329 | Coercion latticeType : type >-> Order.Lattice.type. 330 | Coercion bLatticeType : type >-> Order.BLattice.type. 331 | Coercion distrLatticeType : type >-> Order.DistrLattice.type. 332 | Coercion bDistrLatticeType : type >-> Order.BDistrLattice.type. 333 | Coercion wfType : type >-> WellFounded.type. 334 | Coercion orderType : type >-> Order.Total.type. 335 | 336 | End Exports. 337 | 338 | End Order. 339 | 340 | Module Export Syntax. 341 | 342 | Notation "'\i0'" := (ident0) : ident_scope. 343 | Notation "'\i1'" := (ident1) : ident_scope. 344 | 345 | Notation ident_le := (@Order.le (Order.disp) _). 346 | Notation ident_lt := (@Order.lt (Order.disp) _). 347 | Notation ident_comparable := (@Order.comparable (Order.disp) _). 348 | Notation ident_ge := (@Order.ge (Order.disp) _). 349 | Notation ident_gt := (@Order.gt (Order.disp) _). 350 | Notation ident_leif := (@Order.leif (Order.disp) _). 351 | Notation ident_lteif := (@Order.lteif (Order.disp) _). 352 | Notation ident_max := (@Order.max (Order.disp) _). 353 | Notation ident_min := (@Order.min (Order.disp) _). 354 | Notation ident_meet := (@Order.meet (Order.disp) _). 355 | Notation ident_join := (@Order.join (Order.disp) _). 356 | Notation ident_bottom := (@Order.bottom (Order.disp) _). 357 | Notation ident_top := (@Order.top (Order.disp) _). 358 | 359 | Notation "<=^i%O" := ident_le : fun_scope. 360 | Notation ">=^i%O" := ident_ge : fun_scope. 361 | Notation "<^i%O" := ident_lt : fun_scope. 362 | Notation ">^i%O" := ident_gt : fun_scope. 363 | Notation "=<^i%O" := ident_comparable : fun_scope. 366 | Notation "><^i%O" := (fun x y => ~~ ident_comparable x y) : fun_scope. 367 | 368 | Notation "<=^i y" := (>=^i%O y) : order_scope. 369 | Notation "<=^i y :> T" := (<=^i (y : T)) (only parsing) : order_scope. 370 | Notation ">=^i y" := (<=^i%O y) : order_scope. 371 | Notation ">=^i y :> T" := (>=^i (y : T)) (only parsing) : order_scope. 372 | 373 | Notation "<^i y" := (>^i%O y) : order_scope. 374 | Notation "<^i y :> T" := (<^i (y : T)) (only parsing) : order_scope. 375 | Notation ">^i y" := (<^i%O y) : order_scope. 376 | Notation ">^i y :> T" := (>^i (y : T)) (only parsing) : order_scope. 377 | 378 | Notation "x <=^i y" := (<=^i%O x y) : order_scope. 379 | Notation "x <=^i y :> T" := ((x : T) <=^i (y : T)) (only parsing) : order_scope. 380 | Notation "x >=^i y" := (y <=^i x) (only parsing) : order_scope. 381 | Notation "x >=^i y :> T" := ((x : T) >=^i (y : T)) (only parsing) : order_scope. 382 | 383 | Notation "x <^i y" := (<^i%O x y) : order_scope. 384 | Notation "x <^i y :> T" := ((x : T) <^i (y : T)) (only parsing) : order_scope. 385 | Notation "x >^i y" := (y <^i x) (only parsing) : order_scope. 386 | Notation "x >^i y :> T" := ((x : T) >^i (y : T)) (only parsing) : order_scope. 387 | 388 | Notation "x <=^i y <=^i z" := ((x <=^i y) && (y <=^i z)) : order_scope. 389 | Notation "x <^i y <=^i z" := ((x <^i y) && (y <=^i z)) : order_scope. 390 | Notation "x <=^i y <^i z" := ((x <=^i y) && (y <^i z)) : order_scope. 391 | Notation "x <^i y <^i z" := ((x <^i y) && (y <^i z)) : order_scope. 392 | 393 | Notation "x <=^i y ?= 'iff' C" := ( T" := ((x : T) <=^i (y : T) ?= iff C) 395 | (only parsing) : order_scope. 396 | 397 | Notation "x <^i y ?<= 'if' C" := ( T" := ((x : T) <^i (y : T) ?<= if C) 399 | (only parsing) : order_scope. 400 | 401 | Notation ">=<^i x" := (>=<^i%O x) : order_scope. 402 | Notation ">=<^i y :> T" := (>=<^i (y : T)) (only parsing) : order_scope. 403 | Notation "x >=<^i y" := (>=<^i%O x y) : order_scope. 404 | 405 | Notation "><^i y" := [pred x | ~~ ident_comparable x y] : order_scope. 406 | Notation "><^i y :> T" := (><^i (y : T)) (only parsing) : order_scope. 407 | Notation "x ><^i y" := (~~ (><^i%O x y)) : order_scope. 408 | 409 | End Syntax. 410 | 411 | Module Export Theory. 412 | Section Theory. 413 | 414 | Lemma foldr_monoid {S : Type} {f : S -> S -> S} {n s1 s2}: 415 | associative f -> 416 | (forall a, f n a = a) -> 417 | (forall a, f a n = a) -> 418 | f (foldr f n s1) (foldr f n s2) = 419 | foldr f n (s1 ++ s2). 420 | Proof. by move=> A L R; elim: s1=> //= ??; rewrite -A=>->. Qed. 421 | 422 | Context {T : identType}. 423 | Implicit Types (x : T) (s : seq T). 424 | 425 | Lemma ident_leE x y : 426 | x <=^i y = (encode x <= encode y). 427 | Proof. done. Qed. 428 | 429 | Lemma ident_ltE x y : 430 | x <^i y = (encode x < encode y). 431 | Proof. done. Qed. 432 | 433 | Lemma fresh0 : 434 | fresh (\i0 : T) = \i1. 435 | Proof. by rewrite /fresh encode0. Qed. 436 | 437 | Lemma fresh_lt x : 438 | x <^i fresh x. 439 | Proof. 440 | rewrite /fresh /ident_lt /= /Def.ident_lt decodeK. 441 | exact /ltnSn. 442 | Qed. 443 | 444 | Lemma fresh_inj : 445 | injective (@fresh T). 446 | Proof. by rewrite /fresh=> x y /decode_inj [] /pickle_inj. Qed. 447 | 448 | Lemma fresh_mon : 449 | { mono (fresh : T -> T) : x y / x <=^i y }. 450 | Proof. move=> x y; rewrite !ident_leE /fresh !decodeK; lia. Qed. 451 | 452 | Lemma size_nfresh x n : 453 | size (nfresh x n) = n. 454 | Proof. by rewrite /nfresh size_traject. Qed. 455 | 456 | Lemma nth_nfresh x n i : 457 | i < n -> nth x (nfresh x n) i = iter i fresh x. 458 | Proof. by rewrite /nfresh=> ?; apply /nth_traject. Qed. 459 | 460 | Lemma nfresh_head x y n : 461 | head x (nfresh y n) = if n == 0 then x else y. 462 | Proof. by case: n=> //=. Qed. 463 | 464 | Lemma nfresh_sorted x n : 465 | sorted (<%O) (nfresh x n). 466 | Proof. 467 | rewrite /nfresh; case: n=> //= n. 468 | apply /sub_path; last exact/fpath_traject. 469 | move=> ?? /= /eqP <-; exact/fresh_lt. 470 | Qed. 471 | 472 | Lemma nfresh0 x : 473 | nfresh x 0 = [::]. 474 | Proof. by rewrite /nfresh. Qed. 475 | 476 | Lemma nfreshS x n : 477 | nfresh x n.+1 = x :: nfresh (fresh x) n. 478 | Proof. by rewrite /nfresh; exact/trajectS. Qed. 479 | 480 | Lemma nfreshSr x n : 481 | nfresh x n.+1 = rcons (nfresh x n) (iter n fresh x). 482 | Proof. by rewrite /nfresh; exact/trajectSr. Qed. 483 | 484 | Lemma in_nfresh x n y : 485 | y \in nfresh x n = (encode x <= encode y < n + encode x)%N. 486 | Proof. 487 | elim: n x=> //= [? |?/[swap] ?]; rewrite ?(inE, in_nil); first lia. 488 | move=>->; rewrite encode_fresh -(inj_eq encode_inj); lia. 489 | Qed. 490 | 491 | Definition fresh_seq : seq T -> T := fun t => 492 | max_seq (\i0 : T) (map fresh t). 493 | 494 | Lemma fresh_seq_nil : 495 | fresh_seq [::] = (\i0 : T). 496 | Proof. by rewrite /fresh_seq /=. Qed. 497 | 498 | Lemma maxx0 x : Order.max x \i0 = x. 499 | Proof. exact/max_idPl/le0x. Qed. 500 | 501 | Lemma max0x x : Order.max \i0 x = x. 502 | Proof. exact/max_idPr/le0x. Qed. 503 | 504 | Lemma max_fresh x y: 505 | Order.max (fresh x) (fresh y) = fresh (Order.max x y). 506 | Proof. rewrite ?maxEle fresh_mon; by case: ifP. Qed. 507 | 508 | Lemma fresh_seq_mem x s : 509 | x \in s -> x <^i fresh_seq s. 510 | Proof. 511 | rewrite /fresh_seq. 512 | elim: s=> [|y {}s IH] => //=. 513 | rewrite inE maxElt. 514 | case: ifP=> /[swap] /orP[/eqP<-|/IH] //. 515 | - by move=> H; apply/(lt_trans _ H)/fresh_lt. 516 | - by move: (fresh_lt x). 517 | move=> /[swap]/negbT; rewrite -leNgt. 518 | by move=> /[swap]/lt_le_trans; apply. 519 | Qed. 520 | 521 | Lemma fresh_seq_nmem s : fresh_seq s \notin s. 522 | Proof. by apply/memPn => x /fresh_seq_mem; rewrite lt_neqAle=> /andP[]. Qed. 523 | 524 | Lemma fresh_seq_nfresh x n : 525 | n != 0 -> fresh_seq (nfresh x n) = iter n fresh x. 526 | Proof. 527 | case: n=> //= n _; rewrite /fresh_seq; apply/eqP. 528 | rewrite -is_sup_NnilE=> //; last exact/le0x. 529 | rewrite is_sup_mon; last first. 530 | - exact/fresh_mon. 531 | - exact/fresh_inj. 532 | apply/is_supP; split=>>. 533 | - by apply/path.trajectP; exists n. 534 | rewrite in_nfresh ident_leE encode_iter; lia. 535 | Qed. 536 | 537 | Lemma fresh_seq_subset s1 s2 : 538 | {subset s1 <= s2} -> fresh_seq s1 <=^i fresh_seq s2. 539 | Proof. 540 | rewrite /fresh_seq. 541 | elim: s1 s2=> [?? |] //=; first exact/le0x. 542 | move=> a s1 IH s2 subs. 543 | rewrite le_maxl; apply/andP; split. 544 | - apply/max_seq_in_le; rewrite (mem_map fresh_inj). 545 | exact/(subs a)/mem_head. 546 | by apply/IH=> ? I; apply/subs; rewrite inE I orbT. 547 | Qed. 548 | 549 | Lemma fresh_seq_eq s1 s2 : 550 | s1 =i s2 -> fresh_seq s1 = fresh_seq s2. 551 | Proof. 552 | rewrite /fresh_seq=> eqm. 553 | apply/(max_set_eq); first exact/le0x. 554 | by apply/eq_mem_map. 555 | Qed. 556 | 557 | Lemma fresh_seqU (s1 s2 : {fset T}): 558 | fresh_seq (s1 `|` s2)%fset = Order.max (fresh_seq s1) (fresh_seq s2). 559 | Proof. 560 | have->: Order.max (fresh_seq s1) (fresh_seq s2) = fresh_seq (s1 ++ s2). 561 | - apply/eqP; rewrite /fresh_seq /=. 562 | by rewrite (foldr_monoid maxA max0x maxx0) ?map_cat. 563 | have/andP/(le_anti) //: 564 | ((fresh_seq (s1 `|` s2)%fset <=^i fresh_seq (s1 ++ s2)) /\ 565 | (fresh_seq (s1 ++ s2) <=^i fresh_seq (s1 `|` s2)%fset)). 566 | split; apply/fresh_seq_subset=> ?; by rewrite ?inE mem_cat. 567 | Qed. 568 | 569 | Lemma fresh_seq_add x (s : {fset T}) : 570 | fresh_seq (x |` s)%fset = Order.max (fresh x) (fresh_seq s). 571 | Proof. 572 | rewrite fresh_seqU. 573 | under (@fresh_seq_eq _ [:: x]) do rewrite ?inE //. 574 | by rewrite {1}/fresh_seq /= maxx0. 575 | Qed. 576 | 577 | End Theory. 578 | End Theory. 579 | 580 | End Ident. 581 | 582 | Export Ident.Exports. 583 | Export Ident.Inh.Exports. 584 | Export Ident.Order.Exports. 585 | Export Ident.Def. 586 | Export Ident.Props. 587 | Export Ident.Syntax. 588 | Export Ident.Theory. 589 | 590 | (* Context {T : identType}. *) 591 | (* Variable (x y : T). *) 592 | (* Check (x <=^i y : bool). *) 593 | 594 | Lemma nat_unpickle_tot (n : nat) : (unpickle n : option nat). 595 | Proof. done. Qed. 596 | 597 | Lemma nat_unpickle_inj : injective (unpickle : nat -> option nat). 598 | Proof. exact/Some_inj. Qed. 599 | 600 | Definition nat_identMixin := 601 | @Ident.Mixin nat (Countable.class nat_countType) 602 | nat_unpickle_tot nat_unpickle_inj. 603 | 604 | Canonical nat_identType := 605 | Eval hnf in IdentType nat nat_identMixin. 606 | -------------------------------------------------------------------------------- /theories/common/seq.v: -------------------------------------------------------------------------------- 1 | From mathcomp Require Import ssreflect ssrbool ssrnat ssrfun. 2 | From mathcomp Require Import eqtype choice order seq tuple path zify. 3 | From mathcomp Require Import fintype finfun fingraph finmap. 4 | From mathcomp.tarjan Require Import extra. 5 | From eventstruct Require Import utils. 6 | 7 | Set Implicit Arguments. 8 | Unset Strict Implicit. 9 | Unset Printing Implicit Defensive. 10 | 11 | Import Order.Theory. 12 | 13 | Section SeqUtils. 14 | Context {T : Type}. 15 | Implicit Types (p : pred T) (r : rel T) (s : seq T) (n : nat). 16 | 17 | Lemma behead_rcons x s : 18 | behead (rcons s x) = if s is [::] then [::] else rcons (behead s) x. 19 | Proof. by case: s. Qed. 20 | 21 | Lemma headNnil x y s : 22 | ~~ nilp s -> head y s = head x s. 23 | Proof. by case: s. Qed. 24 | 25 | Lemma lastNnil x y s : 26 | ~~ nilp s -> last y s = last x s. 27 | Proof. by case: s. Qed. 28 | 29 | Lemma hasNcount p s : 30 | ~~ has p s = (count p s == 0). 31 | Proof. by rewrite has_count -leqNgt leqn0. Qed. 32 | 33 | Lemma hasNtake p s : 34 | ~~ has p (take (find p s) s). 35 | Proof. by apply/contra; first apply/find_ltn; rewrite ltnn. Qed. 36 | 37 | Lemma count_take_find p s : 38 | count p (take (find p s) s) = 0. 39 | Proof. apply/eqP; rewrite -hasNcount; apply/hasNtake. Qed. 40 | 41 | Lemma count_set_nth m i : 42 | ~~ nth false m i -> count id (set_nth false m i true) = 1 + count id m. 43 | Proof. 44 | move: i; elim: m=> [|b {}m IH] i /=. 45 | - by rewrite set_nth_nil addn0 /= => _; elim i. 46 | elim i=> [|{}i IHi] => /=. 47 | - by move=> /negbTE ->. 48 | move=> /IH ->; lia. 49 | Qed. 50 | 51 | Lemma mkseqS (f : nat -> T) n : 52 | mkseq f n.+1 = rcons (mkseq f n) (f n). 53 | Proof. by rewrite /mkseq -addn1 iotaD add0n map_cat cats1. Qed. 54 | 55 | Lemma set_nthE x s i y : i < size s -> 56 | set_nth x s i y = (rcons (take i s) y) ++ (drop i.+1 s). 57 | Proof. 58 | move=> Hi; apply/(@eq_from_nth _ x). 59 | - rewrite size_set_nth size_cat size_rcons. 60 | rewrite size_drop size_takel ?maxnE //; exact/ltnW. 61 | move=> j Hj; rewrite nth_set_nth /=. 62 | rewrite -cats1 -catA !nth_cat size_takel ?nth_drop /=; last exact/ltnW. 63 | case: (j < i)/idP. 64 | - move=> /[dup] Hlt; rewrite nth_take //. 65 | by rewrite ltn_neqAle=> /andP[/negPf->]. 66 | move=> /negP; rewrite -leqNgt ltnS leqn0. 67 | rewrite leq_eqVlt=> /orP[/eqP->|]. 68 | - by rewrite subnn eq_refl /=. 69 | rewrite ?subn_eq0 eq_sym. 70 | move=> /[dup]; rewrite {1}ltnNge=> /negPf->. 71 | move=> /[dup]; rewrite {1}ltn_neqAle=> /andP[/negPf-> _]. 72 | by move=> ?; rewrite -subnDA addn1 subnKC. 73 | Qed. 74 | 75 | Lemma find_take p s n : 76 | has p (take n s) -> find p (take n s) = find p s. 77 | Proof. by rewrite -[in find p s](@cat_take_drop n _ s) find_cat=> ->. Qed. 78 | 79 | Lemma sorted_rcons x r s y : 80 | sorted r (rcons s y) = sorted r s && (nilp s || r (last x s) y). 81 | Proof. case s=> [|??] //=; exact/rcons_path. Qed. 82 | 83 | Lemma sorted_subn (s : seq nat) n : 84 | sorted ltn s -> all (fun m => n <= m) s -> sorted ltn (map (subn^~ n) s). 85 | Proof. 86 | elim s=> [|i {}s IH] //=. 87 | rewrite !path_sortedE; try by exact/ltn_trans. 88 | move=> /andP[Hi Hs] /andP[Hn Hleq]. 89 | apply/andP; split=> //; last by apply/IH. 90 | apply/allP=> j /mapP[k + ->] /=. 91 | move: Hi=> /allP /[apply] /= Hk. 92 | apply/ltn_sub2r=> //. 93 | by apply/(leq_ltn_trans Hn). 94 | Qed. 95 | 96 | Lemma sorted_ltn_nth (s : seq nat) i j : 97 | sorted ltn s -> i < j < size s -> nth 0 s i < nth 0 s j. 98 | Proof. 99 | move=> Hs /andP[Hij Hsz]. 100 | suff: (nth 0 s i < nth 0 s j)%O by done. 101 | rewrite lt_sorted_ltn_nth=> //=. 102 | exact/(ltn_trans Hij). 103 | Qed. 104 | 105 | Lemma sorted_nth_drop_lt (s : seq nat) i j : 106 | sorted ltn s -> i.+1 < size s -> j \in drop i.+1 s -> nth 0 s i < j. 107 | Proof. 108 | move=> Hs Hi Hj; apply/leq_trans. 109 | - by apply/(@sorted_ltn_nth s i i.+1)=> //; apply/andP. 110 | have: exists k, (nth 0 s k = j) /\ (i.+1 <= k < size s). 111 | - move: Hj=> /(nthP 0) [k]. 112 | rewrite size_drop nth_drop=> ??. 113 | exists (i.+1 + k); split=> //. 114 | apply/andP; split=> //; first lia. 115 | by rewrite -ltn_subRL. 116 | move=> [k [<- /andP[]]]. 117 | rewrite leq_eqVlt=> /orP[/eqP ->|??] //. 118 | by apply/ltnW/sorted_ltn_nth=> //; apply/andP. 119 | Qed. 120 | 121 | End SeqUtils. 122 | 123 | Arguments sorted_rcons {T} x. 124 | 125 | Section SeqEqUtils. 126 | Context {T : eqType}. 127 | Implicit Types (p : pred T) (r : rel T) (s : seq T) (n : nat). 128 | 129 | Lemma eq_mem0 s1 s2 : 130 | s1 =i s2 -> (s1 == [::]) = (s2 == [::]). 131 | Proof. 132 | case: s1; case s2=> //= x s eqm; rewrite eqxx; apply/idP/idP. 133 | - by rewrite /= -(in_nil x) eqm inE eqxx. 134 | by move: (eqm x); rewrite !inE in_nil eqxx /=. 135 | Qed. 136 | 137 | Lemma subseq_anti : 138 | antisymmetric (@subseq T). 139 | Proof. 140 | move=> s1 s2 /andP[]. 141 | move=> /size_subseq_leqif /leqifP. 142 | case: ifP=> [/eqP->|_] //. 143 | move=> /[swap] /size_subseq. 144 | by rewrite leqNgt=> /negP. 145 | Qed. 146 | 147 | Lemma index_inj s : 148 | {in s &, injective (index^~ s)}. 149 | Proof. 150 | move=> x y; elim s=> [|z {}s] IH //=. 151 | case: ifP=> [/eqP->|]; case: ifP=> [/eqP->|] => //. 152 | rewrite !inE [z == y]eq_sym [z == x]eq_sym => -> -> /=. 153 | move=> ?? []; exact/IH. 154 | Qed. 155 | 156 | Lemma mkseq_in_uniq (f : nat -> T) n : 157 | { in iota 0 n &, injective f } -> uniq (mkseq f n). 158 | Proof. by move/map_inj_in_uniq ->; apply: iota_uniq. Qed. 159 | 160 | End SeqEqUtils. 161 | 162 | Section Slice. 163 | Context {T : eqType}. 164 | Implicit Types (s : seq T) (n m : nat). 165 | 166 | Definition slice n m s := 167 | take (m - n) (drop n s). 168 | 169 | Lemma size_slice n m s : 170 | (m <= size s)%N -> size (slice n m s) = m - n. 171 | Proof. 172 | move=> sz. 173 | rewrite /slice size_takel //. 174 | rewrite size_drop; lia. 175 | Qed. 176 | 177 | Lemma index_drop s x n : 178 | (n <= index x s)%N -> index x (drop n s) = index x s - n. 179 | Proof. 180 | move: s; elim n=> [|{}n IH] s nLe. 181 | - rewrite drop0 subn0 //=. 182 | rewrite -addn1 -drop_drop. 183 | move: nLe; case: s=> [|y {}s] //=. 184 | case: ifP => // _. 185 | rewrite drop0 ltnS addn1 subSS=> nLe. 186 | by rewrite IH. 187 | Qed. 188 | 189 | Lemma index_drop_uniq s x n : 190 | uniq s -> (index x s < n <= size s)%N -> index x (drop n s) = size s - n. 191 | Proof. 192 | move=> uq /andP[] ixLe nLe. 193 | rewrite memNindex ?size_drop //. 194 | case: (x \in s)/idP; last first. 195 | - move=> /negP; exact/contra/mem_drop. 196 | move: uq; rewrite -{1 2}[s](cat_take_drop n)=> uq xIn. 197 | by rewrite -(uniq_catLR uq) // in_take_leq. 198 | Qed. 199 | 200 | Lemma in_slice_index n m s x : 201 | (n <= m <= size s)%N -> uniq s -> x \in (slice n m s) = (n <= index x s < m)%N. 202 | Proof. 203 | rewrite /slice=> sz. 204 | rewrite in_take_leq; last first. 205 | - rewrite size_drop; lia. 206 | move=> uq; case: (n <= index x s)%N/idP. 207 | - move=> nLe; rewrite index_drop //; lia. 208 | move=> /negP; rewrite -ltnNge=> ixLe. 209 | rewrite index_drop_uniq //; lia. 210 | Qed. 211 | 212 | End Slice. 213 | 214 | Section FindNth. 215 | 216 | Context {T : Type}. 217 | Implicit Types (p : pred T) (s : seq T) (n : nat). 218 | 219 | (* TODO: rename to avoid collision with find_nth_spec from mathcomp? *) 220 | Fixpoint find_nth p s n := 221 | match n with 222 | | 0 => find p s 223 | | n.+1 => 224 | let i := find_nth p s n in 225 | (i.+1 + find p (drop i.+1 s))%N 226 | end. 227 | 228 | Variant split_count_find_nth_spec p : 229 | seq T -> nat -> nat -> seq T -> seq T -> T -> Type := 230 | FindNth x n i s1 s2 of p x & (size s1 = i) & (count p s1 = n) : 231 | split_count_find_nth_spec p (rcons s1 x ++ s2) n i s1 s2 x. 232 | 233 | Lemma split_count_find_nth x0 p s n : n < count p s -> 234 | let i := find_nth p s n in 235 | split_count_find_nth_spec p s n i (take i s) (drop i.+1 s) (nth x0 s i). 236 | Proof. 237 | move: s; elim n=> [|{}n IH] s H /=. 238 | - case: (split_find_nth x0); first by rewrite has_count. 239 | move=> x s1 s2 Hp Hh; constructor=> //. 240 | - rewrite -cats1 !find_cat has_cat /= Hp orbT addn0 /=. 241 | by move: Hh; case: ifP=> //. 242 | by move: Hh; rewrite has_count -leqNgt leqn0=> /eqP. 243 | move: H=> /[dup] H; case: (IH s); first by apply/ltnW. 244 | move: H=> _ x m i s1 s2; clear s. 245 | pose s := rcons s1 x ++ s2. 246 | have Hs: s = rcons s1 x ++ s2 by done. 247 | move=> Hp Hsz Hcs1 Hc; rewrite -Hs. 248 | have Hs1 : s1 = take i s. 249 | - rewrite Hs -cats1 !take_cat size_cat Hsz /=. 250 | by rewrite ltnn addn1 leqnn subnn take0 cats0. 251 | have Hs1' : rcons s1 x = take i.+1 s. 252 | - by rewrite Hs take_cat size_rcons Hsz ltnn subnn take0 cats0. 253 | have Hs2 : s2 = drop i.+1 s. 254 | - by rewrite Hs drop_cat size_rcons Hsz ltnn subnn drop0. 255 | have Hcs2 : 0 < count p s2. 256 | - move: Hc; rewrite -cats1 !count_cat /= addn0 Hcs1 Hp. 257 | by rewrite addn1 -{1}[m.+1]addn0 ltn_add2l. 258 | have Hszf : i.+1 + find p s2 < size s. 259 | - move: Hcs2; rewrite -has_count has_find. 260 | by rewrite Hs size_cat size_rcons Hsz ltn_add2l=> ->. 261 | rewrite -[s in split_count_find_nth_spec p s m.+1] 262 | (cat_take_drop (i.+1 + find p s2) s). 263 | rewrite (drop_nth x0 _)=> //. 264 | rewrite -cat_rcons. constructor=> //. 265 | - by rewrite -nth_drop Hs2 nth_find // has_count -Hs2 //. 266 | - by rewrite size_take Hszf. 267 | rewrite takeD take_drop addnC takeD drop_cat size_takel; last first. 268 | - rewrite Hs size_cat size_rcons Hsz; lia. 269 | rewrite ltnn subnn drop0 count_cat -Hs1' Hs2. 270 | by rewrite -cats1 count_cat Hcs1 count_take_find /= Hp !addn0 addn1. 271 | Qed. 272 | 273 | Lemma count_Nfind_nth (x0 : T) p s n : 274 | (count p s <= n) -> (find_nth p s n >= size s). 275 | Proof. 276 | move: s; elim n=> [|{}n IH] s /=. 277 | - rewrite leqn0=> /eqP H; rewrite hasNfind=> //. 278 | by rewrite has_count -leqNgt H. 279 | rewrite leq_eqVlt=> /orP[/eqP H|]. 280 | - move: H=> /[dup] H; case: (split_count_find_nth x0). 281 | + by rewrite H. 282 | move=> x m i s1 s2 Hp Hsz Hc Hc'. 283 | rewrite size_cat size_rcons Hsz. 284 | rewrite leq_add2l leqNgt -has_find has_count -leqNgt. 285 | move: Hc'; rewrite count_cat -cats1 count_cat /= Hp /= Hc; lia. 286 | by move=> /ltnSE H; apply/(leq_trans (IH s H)); lia. 287 | Qed. 288 | 289 | Lemma count_find_nth (x0 : T) p s n : 290 | (n < count p s) = (find_nth p s n < size s). 291 | Proof. 292 | symmetry; case H: (n < count p s). 293 | - case: (split_count_find_nth x0 H). 294 | move=> x m i s1 s2 ? <- ?. 295 | rewrite size_cat size_rcons; lia. 296 | apply/negP/negP; rewrite -leqNgt; apply/(count_Nfind_nth x0). 297 | by move: H=> /negP/negP; rewrite -leqNgt. 298 | Qed. 299 | 300 | Lemma find_nth_ltn p s n m : 301 | n < m -> find_nth p s n < find_nth p s m. 302 | Proof. 303 | elim: m=> [|{}m IH] // /ltnSE. 304 | rewrite leq_eqVlt=> /orP[/eqP->|/IH] /=. 305 | - exact/leq_addr. 306 | move=> H; apply/(ltn_trans H); exact/leq_addr. 307 | Qed. 308 | 309 | Lemma find_nth_leq p s n m : 310 | n <= m -> find_nth p s n <= find_nth p s m. 311 | Proof. 312 | rewrite leq_eqVlt=> /orP[/eqP->|] //. 313 | by move=> ?; apply/ltnW/find_nth_ltn. 314 | Qed. 315 | 316 | Lemma find_nth_inj p s : 317 | injective (find_nth p s). 318 | Proof. 319 | move=> i j; move: (ltn_total i j). 320 | by move=> /orP[/eqP|/orP[]] // /(find_nth_ltn p s); lia. 321 | Qed. 322 | 323 | Lemma find_nth_consT p x xs n : 324 | p x -> find_nth p (x::xs) n = if n is n'.+1 then 1 + find_nth p xs n' else 0. 325 | Proof. 326 | elim n=> [|{}n IH] //=. 327 | - case: ifP=> ? //=. 328 | move=> ?; rewrite IH //=. 329 | case n=> [|{}n'] //=. 330 | by rewrite drop0. 331 | Qed. 332 | 333 | Lemma find_nth_consF p x xs n : 334 | ~~ p x -> find_nth p (x::xs) n = 1 + find_nth p xs n. 335 | Proof. 336 | elim n=> [|{}n IH] //=. 337 | - case: ifP=> ? //=. 338 | by move=> ?; rewrite IH. 339 | Qed. 340 | 341 | End FindNth. 342 | 343 | Section MaskUtils. 344 | 345 | Context {T : Type}. 346 | Implicit Types (s : seq T) (m : bitseq) (n : nat). 347 | 348 | Lemma mask_size_find_nth s n m : 349 | size m = size s -> n < size (mask m s) -> find_nth id m n < size m. 350 | Proof. by move=> /size_mask ->; rewrite (count_find_nth false). Qed. 351 | 352 | Lemma mask_size_Nfind_nth s n m : 353 | size m = size s -> size (mask m s) <= n -> size m <= find_nth id m n. 354 | Proof. by move=> /size_mask ->; exact/(count_Nfind_nth false). Qed. 355 | 356 | Lemma nth_mask (x : T) s m n : 357 | size m = size s -> nth x (mask m s) n = nth x s (find_nth id m n). 358 | Proof. 359 | move=> Hsz; case: (n < size (mask m s))/idP; last first. 360 | - move=> /negP; rewrite -leqNgt. 361 | move=> /[dup] ? /(mask_size_Nfind_nth Hsz) ?. 362 | by rewrite !nth_default -?Hsz. 363 | move=> /[dup] Hn /(mask_size_find_nth Hsz) Hi. 364 | move: n m Hsz Hn Hi; elim s=> [|y ys IH] n m /=. 365 | - by rewrite mask0 /=. 366 | case m=> [|b bs] //; rewrite mask_cons /=. 367 | move=> [] Hsz; rewrite -cat1s !nth_cat. 368 | case H: b=> /=; last first. 369 | - rewrite subn0 !find_nth_consF //. 370 | move=> /[dup] Hn /(mask_size_find_nth Hsz) Hi ?. 371 | by rewrite IH. 372 | case: ifP. 373 | - by rewrite ltnS leqn0=> /eqP -> /=. 374 | move=> /negP/negP; rewrite -leqNgt. 375 | case n=> [|{}n'] //. 376 | rewrite find_nth_consT //. 377 | rewrite add1n !ltnS subn1 -pred_Sn=> _ Hn Hi /=. 378 | by apply/IH. 379 | Qed. 380 | 381 | End MaskUtils. 382 | 383 | 384 | Section MkMask. 385 | Context {T : Type}. 386 | Implicit Types (s : seq nat) (m : bitseq) (n : nat). 387 | 388 | Definition mkmask s n : bitseq := 389 | (fix mkmask (s : seq nat) m := match s with 390 | | [::] => m 391 | | i :: s' => set_nth false (mkmask s' m) i true 392 | end) s (nseq n false). 393 | 394 | Lemma mkmask_cons i s n : 395 | mkmask (i::s) n = set_nth false (mkmask s n) i true. 396 | Proof. by case s. Qed. 397 | 398 | Lemma size_mkmask s n : 399 | (all (fun i => i < n) s) -> size (mkmask s n) = n. 400 | Proof. 401 | elim s=> [|i {}s IH] //. 402 | - by rewrite size_nseq. 403 | rewrite mkmask_cons size_set_nth /=. 404 | move=> /andP[Hi Ha]; rewrite IH //=. 405 | exact/maxn_idPr. 406 | Qed. 407 | 408 | Lemma nth_mkmask s n i : 409 | nth false (mkmask s n) i = (i \in s). 410 | Proof. 411 | move: n; elim s=> [|j {}s IH] n. 412 | - by rewrite /mkmask /= nth_nseq inE; case: ifP. 413 | rewrite mkmask_cons nth_set_nth in_cons /=. 414 | by case: ifP=> //. 415 | Qed. 416 | 417 | Lemma count_mkmask s n : 418 | uniq s -> count id (mkmask s n) = size s. 419 | Proof. 420 | move: n; elim s=> [|i {}s IH] n. 421 | - by rewrite count_nseq. 422 | rewrite mkmask_cons /= => /andP[Hi Hu]. 423 | rewrite count_set_nth ?IH //. 424 | rewrite nth_mkmask; apply/(nthP 0). 425 | move=> [j] Hj; move: Hi=> /[swap] <-. 426 | by rewrite mem_nth. 427 | Qed. 428 | 429 | End MkMask. 430 | 431 | (* The following lemmas rely on a similar set of assumptions about a sequence s. 432 | * Putting all of these assumptions in front of each lemma makes it harder 433 | * to read the code and grasp the idea. 434 | * However, because of some technical problems of the section mechanism 435 | * we cannot declare all these assumptions in a single section. 436 | * It looks like in the case of a single section 437 | * the lemmas' arguments (hypothesis) cannot be generalized and 438 | * we cannot apply previous lemmas in subsequent lemmas. 439 | * Thus we pick a middle ground: we put each lemma in a separate section. 440 | * Then we can declare all the assumptions as Hypothesis. 441 | * It improves readability and preserves the lemma statments generalized enough. 442 | *) 443 | 444 | Section SortedSizeSubn. 445 | Context {T : Type}. 446 | Variables (s : seq nat) (n i : nat). 447 | Hypothesis (Hs : sorted ltn s) (Ha : all (ltn^~ n) s). 448 | Hypothesis (Hsz : i < size s <= n). 449 | 450 | Lemma sorted_size_subn : 451 | size s - i <= n - (nth 0 s i). 452 | Proof. 453 | (* move: s i Hs Ha Hsz; clear s i Hs Ha Hsz. *) 454 | move: Hsz=> /andP[Hi Hn]. 455 | pose f := fun i => size s - i. 456 | pose g := fun i => size s - i. 457 | pose p := fun i => i < size s. 458 | have K: {in p, cancel f g}. 459 | - move=> j; subst f g p=> /= ?. 460 | rewrite subKn //; exact/ltnW. 461 | rewrite -[i in nth 0 s i]K //. 462 | have ->: size s - i = f i by done. 463 | have: 0 < f i by rewrite subn_gt0. 464 | have: f i <= size s by exact/leq_subr. 465 | elim (f i)=> [|k]; subst g=> //=. 466 | move=> IH Hks. 467 | case: (0 < k)/idP; last first. 468 | - move=> /negP; rewrite -leqNgt leqn0=> /eqP-> _. 469 | rewrite subn1 nth_last ltn_subCr subn0. 470 | move: (mem_last 0 s); rewrite in_cons. 471 | move=> /orP[/eqP->|] //; first lia. 472 | by move: Ha=> /allP /[apply]. 473 | move=> Hk _; move: (IH (ltnW Hks) Hk)=> Hkn. 474 | apply/(leq_ltn_trans Hkn). 475 | have Hnth: nth 0 s (size s - k.+1) < nth 0 s (size s - k). 476 | - apply/sorted_ltn_nth=> //. 477 | apply/andP; split=> //. 478 | apply/ltn_sub2l=> //. 479 | lia. 480 | apply/(ltn_sub2l _ Hnth)/(ltn_trans Hnth). 481 | by rewrite -subn_gt0; apply/(leq_trans Hk). 482 | Qed. 483 | 484 | End SortedSizeSubn. 485 | 486 | Section DropMkMaskLt. 487 | Context {T : Type}. 488 | Variables (s : seq nat) (n j : nat). 489 | Hypothesis (Hs : sorted ltn s) (Ha : all (ltn^~ n) s) (Hj : all (ltn j) s). 490 | Hypothesis (Hsz : size s <= n). 491 | 492 | Lemma drop_mkmask_lt : 493 | drop j.+1 (mkmask s n) = mkmask [seq k - j.+1 | k <- s] (n - j.+1). 494 | Proof. 495 | move: s Hs Ha Hj Hsz; clear s Hs Ha Hj Hsz. 496 | elim=> [|i {}s IH]. 497 | - by move=> /= ?? Hn ?; rewrite drop_nseq. 498 | rewrite map_cons !mkmask_cons /=. 499 | rewrite path_sortedE; last exact/ltn_trans. 500 | move=> /andP[Ha Hs] /andP[Hi Hlt] /andP[Hj Hjs] Hn. 501 | rewrite !set_nthE ?drop_cat /=; last first. 502 | - rewrite size_mkmask //; exact/ltnW. 503 | - rewrite size_mkmask //. 504 | + apply/ltn_sub2r=> //. 505 | by apply/(leq_ltn_trans Hj). 506 | rewrite all_map /preim; apply/allP. 507 | move=> k Hk /=; rewrite ltn_sub2r //. 508 | + by apply/(leq_ltn_trans Hj). 509 | by move: Hlt Hk=> /allP /[apply]. 510 | rewrite size_rcons size_takel ?ltnS ?Hj; last first. 511 | - rewrite size_mkmask //; exact/ltnW. 512 | rewrite -IH //; last first. 513 | - exact/ltnW. 514 | rewrite drop_drop -subSn //. 515 | rewrite take_drop !subnK //; last exact/ltnW. 516 | rewrite drop_rcons //. 517 | rewrite size_takel ?size_mkmask //. 518 | by apply/ltnW. 519 | Qed. 520 | 521 | End DropMkMaskLt. 522 | 523 | Section DropMkMask. 524 | Context {T : Type}. 525 | Variables (s : seq nat) (n i : nat). 526 | Let j : nat := nth 0 s i. 527 | Hypothesis (Hs : sorted ltn s) (Ha : all (ltn^~ n) s). 528 | Hypothesis (Hsz : i < size s <= n). 529 | 530 | Lemma drop_mkmask : 531 | drop j.+1 (mkmask s n) = mkmask [seq k - j.+1 | k <- drop i.+1 s] (n - j.+1). 532 | Proof. 533 | subst j; move: s i Hs Ha Hsz; clear s i Hs Ha Hsz. 534 | elim=> [|j {}s IH] i //. 535 | rewrite mkmask_cons /=. 536 | rewrite path_sortedE; last exact/ltn_trans. 537 | move=> /andP[Hjs Hs] /andP[Hj Ha]. 538 | rewrite set_nthE ?drop_cat ?size_rcons ?size_takel ?size_mkmask //; 539 | last exact/ltnW. 540 | move=> /andP[Hi Hn]. 541 | have: j <= nth 0 (j :: s) i. 542 | - move: Hi; case i=> [|{}k] //=. 543 | rewrite ltnS=> /(mem_nth 0) Hi. 544 | move: Hjs=> /allP=> H; move: (H (nth 0 s k) Hi)=> //; exact/ltnW. 545 | case: ifP=> [|_]; first lia. 546 | move: Hi; case i=> [|{}k] /=. 547 | - move=> Hsz _; rewrite subnn !drop0. 548 | apply/drop_mkmask_lt=> //; last exact/ltnW. 549 | rewrite ltnS=> Hi Hjn. 550 | rewrite drop_drop subnK ?ltnS ?IH //. 551 | apply/andP; split=> //; exact/ltnW. 552 | Qed. 553 | 554 | End DropMkMask. 555 | 556 | Section FindMkMask. 557 | Context {T : Type}. 558 | Variables (s : seq nat) (n : nat). 559 | Hypothesis (Hs : sorted ltn s) (Ha : all (ltn^~ n) s). 560 | Hypothesis (Hsz : 0 < size s <= n). 561 | 562 | Lemma find_mkmask : 563 | find id (mkmask s n) = nth 0 s 0. 564 | Proof. 565 | move: s Hs Ha Hsz; clear s Hs Ha Hsz. 566 | elim=> [|i {}s IH] Hl //. 567 | rewrite mkmask_cons /=. 568 | move=> /andP[Hi Ha] Hs. 569 | rewrite set_nthE; last first. 570 | - by rewrite size_mkmask. 571 | rewrite -?cats1 !find_cat has_cat /= orbT. 572 | case: (size s == 0)/eqP. 573 | - move=> /size0nil -> /=. 574 | rewrite take_nseq; last by exact/ltnW. 575 | by rewrite has_nseq andbF size_nseq addn0. 576 | move=> /eqP; rewrite eqn0Ngt=> /negbNE Hs0. 577 | case: ifP=> [|_]; last first. 578 | - by rewrite size_take size_mkmask ?Hi ?addn0. 579 | move: Hl=> /=; rewrite lt_path_sortedE=> /andP[Hil Hl]. 580 | move=> H; exfalso; move: H. 581 | move=> /[dup] /find_take; rewrite has_find=> ->. 582 | rewrite size_take size_mkmask ?Hi ?addn0 //. 583 | rewrite {}IH //; last first. 584 | - apply/andP; split=> //; exact/ltnW. 585 | move: Ha Hs Hs0 Hil Hl; case: s=> [|j {}s'] //. 586 | move=> /= ??? /andP[] + ??. 587 | rewrite /Order.lt /=; lia. 588 | Qed. 589 | 590 | End FindMkMask. 591 | 592 | Section FindNthMkMask. 593 | Context {T : Type}. 594 | Variables (s : seq nat) (n i : nat). 595 | Hypothesis (Hs : sorted ltn s) (Ha : all (ltn^~ n) s). 596 | Hypothesis (Hsz : i < size s <= n). 597 | 598 | Lemma find_nth_mkmask : 599 | find_nth id (mkmask s n) i = nth 0 s i. 600 | Proof. 601 | move: i s Hs Ha Hsz; clear s i Hs Ha Hsz. 602 | elim=> [|{}i IH] s /=. 603 | - by apply/find_mkmask. 604 | move=> Hl Ha /andP[Hi Hs]. 605 | rewrite IH=> //; last first. 606 | - apply/andP; split=> //; exact/ltnW. 607 | rewrite drop_mkmask ?find_mkmask //; last first. 608 | - apply/andP; split=> //; exact/ltnW. 609 | - rewrite size_map size_drop; apply/andP; split. 610 | + by rewrite subn_gt0. 611 | rewrite !subnS -subn1 -subn1 leq_sub2r //. 612 | apply/sorted_size_subn=> //. 613 | apply/andP; split=> //; exact/ltnW. 614 | - rewrite all_map; apply/allP=> j Hj /=. 615 | rewrite -subSn; last first. 616 | + apply/sorted_nth_drop_lt=> //. 617 | by apply/leq_sub2r/(allP Ha)/mem_drop/Hj. 618 | - apply/sorted_subn=> //. 619 | + by apply/drop_sorted. 620 | apply/allP=> j Hj. 621 | by apply/sorted_nth_drop_lt. 622 | rewrite (nth_map 0) ?nth_drop ?addn0; last first. 623 | - by rewrite size_drop subn_gt0. 624 | rewrite subnKC //. 625 | suff: (nth 0 s i < nth 0 s i.+1)%O by done. 626 | apply/nth_count_lt; last by rewrite count_lt_nth. 627 | by move: Hl; rewrite lt_sorted_uniq_le=> /andP[]. 628 | Qed. 629 | 630 | End FindNthMkMask. 631 | 632 | Section MkMaskMask. 633 | Context {T : Type} {n m : nat}. 634 | Variables (t : n.-tuple T) (u : m.-tuple T) (f : 'I_n -> 'I_m). 635 | Let s := mkseq (sub_lift (addn m) f) n. 636 | 637 | Hypothesis (Hhm : {homo f : x y / x < y}). 638 | Hypothesis (Hinj : injective f). 639 | Hypothesis (Hnm : forall i, f i < m). 640 | Hypothesis (Hnth : forall i, tnth t i = tnth u (f i)). 641 | 642 | Lemma mkmask_mask : 643 | mask (mkmask s m) u = t. 644 | Proof. 645 | (* move=> Hfh Hf Hm Hn. *) 646 | have Ha: all (fun i : nat => i < m) s. 647 | - apply/allP=> i /(nthP 0) [j]. 648 | rewrite size_mkseq=> Hj <-. 649 | by rewrite nth_mkseq // sub_liftT. 650 | have Hsz: size (mask (mkmask s m) u) = size t. 651 | - rewrite size_mask ?size_mkmask ?count_mkmask ?size_tuple //. 652 | apply/mkseq_uniq/sub_lift_inj. 653 | + by move=> {}x {}y; move: (valP (f y))=> /[swap] /= <-; lia. 654 | + by move=> ??; apply/addnI. 655 | by move=> ???; apply/Hinj/val_inj. 656 | have Hsz': size (mask (mkmask s m) u) = n. 657 | - by rewrite Hsz size_tuple. 658 | apply/(@eq_from_tuple _ _ _ Hsz). 659 | rewrite tvalK; apply/eq_from_tnth. 660 | move=> i; rewrite tcastE /tnth /=. 661 | have Hi: i < n by move: i=> []; rewrite size_tuple. 662 | rewrite nth_mask ?find_nth_mkmask=> //; last first. 663 | - by rewrite size_mkmask ?size_tuple //. 664 | - rewrite size_mkseq; apply/andP; split=> //. 665 | move: Hinj Hi=> /leq_card /=. 666 | by rewrite !card_ord. 667 | - apply/homo_sorted; last by exact/iota_ltn_sorted. 668 | apply/sub_lift_homo=> //=; [lia| ..]; last first. 669 | + by move=> ?? /=; rewrite ltn_add2l. 670 | move=> {}x {}y /= /negP; rewrite -leqNgt=> Hyn. 671 | rewrite -[val (f x)]addn0 -addnS; apply/leq_add. 672 | - by apply/ltnW; move: (valP (f x)). 673 | apply/(leq_trans _ Hyn); lia. 674 | rewrite -tnth_nth tcastE esymK Hnth. 675 | have ->: cast_ord (size_tuple t) i = Ordinal Hi by exact/val_inj. 676 | by subst s; rewrite nth_mkseq // sub_liftT // -tnth_nth. 677 | Qed. 678 | 679 | End MkMaskMask. 680 | -------------------------------------------------------------------------------- /theories/concur/transitionsystem.v: -------------------------------------------------------------------------------- 1 | From RelationAlgebra Require Import lattice monoid rel kat_tac kleene. 2 | From mathcomp Require Import ssreflect ssrfun ssrbool eqtype choice seq path. 3 | From mathcomp Require Import order finmap fintype ssrnat finfun. 4 | From eventstruct Require Import utils rel_algebra rewriting_system. 5 | From eventstruct Require Import inhtype ident porf_eventstruct. 6 | 7 | (******************************************************************************) 8 | (* Here we want to make function that by event and event structure creates a *) 9 | (* new event structure with added event. Then we want to describe behavior of *) 10 | (* ca, cf, ... on new structure in terms of ca, cf, ... on old one. Finally *) 11 | (* we want to prove that if our structure is consistent, and we are adding *) 12 | (* the element that is not conflicting with his predecessors, then our new *) 13 | (* structure is going to be consistent, too. *) 14 | (* *) 15 | (* This file contains the definitions of: *) 16 | (* add_label == special record with all necessary information about *) 17 | (* event that we want to add to a porf_eventstruct *) 18 | (* add_event es al == function that takes porf_eventstruct *) 19 | (* and record add_label with event we want to add and *) 20 | (* returns new porf_eventstruct with added element *) 21 | (* 'function'_add_eventE == lemma that determines behavior of *) 22 | (* 'function' on the new event structure with added element *) 23 | (* in terms of 'function' on event structure without one *) 24 | (* consist_add_event == statement about consistence of our new *) 25 | (* structure *) 26 | (* tr_add_event e1 e2 == we can add some event to e1 and obtain e2 *) 27 | (* ltr_add_event e1 al e2 == we can add al to e1 and obtain e2 *) 28 | (* add_label_of_nread == takes non-read label and predecessor and *) 29 | (* returns corresponding add_label structure *) 30 | (* rf_ncf_nread == lemma that ensures event structures obtained by *) 31 | (* add_label_of_nread is prime *) 32 | (* contain al es == checks if event that we want to add (al) is *) 33 | (* already in es *) 34 | (* add_new_event == adding a new event to the event structure if it *) 35 | (* is not contained there *) 36 | (******************************************************************************) 37 | 38 | Set Implicit Arguments. 39 | Unset Strict Implicit. 40 | Unset Printing Implicit Defensive. 41 | 42 | Import Order.LTheory. 43 | 44 | Local Open Scope rel_scope. 45 | Local Open Scope order_scope. 46 | Local Open Scope fset_scope. 47 | Local Open Scope ident_scope. 48 | 49 | Import Label.Syntax. 50 | 51 | Arguments dom0 {_ _ _}. 52 | 53 | Section TransitionSystem. 54 | 55 | Context (E : identType) (Lab : labType). 56 | 57 | Notation porf_eventstruct := (@porf_eventstruct E Lab). 58 | Notation prime_porf_eventstruct := (@prime_porf_eventstruct E Lab). 59 | 60 | Notation label := (Lab). 61 | 62 | Implicit Types (x : Loc) (es : porf_eventstruct). 63 | 64 | (* Section with definitions for execution graph with added event *) 65 | Section AddEvent. 66 | 67 | (* execution graph in which we want to add l *) 68 | Context (es : porf_eventstruct). 69 | 70 | Notation dom := (dom es). 71 | Notation ffed := (fed es). 72 | Notation flab := (lab es). 73 | Notation ffpo := (fpo es). 74 | Notation ffrf := (frf es). 75 | 76 | Notation fresh_id := (fresh_seq dom). 77 | 78 | Structure add_label := Add { 79 | add_lb : Lab; 80 | add_po : E; 81 | add_rf : E; 82 | 83 | add_po_in_dom : add_po \in dom; 84 | add_rf_in_dom : add_rf \in dom; 85 | add_po_consist : flab add_po (po)>> add_lb; 86 | add_rf_consist : flab add_rf (rf)>> add_lb; 87 | }. 88 | 89 | Coercion of_add_label := fun 90 | '(Add l p w _ _ _ _) => mk_edescr l p w. 91 | 92 | Lemma of_add_label_inj : injective of_add_label. 93 | Proof. 94 | case=> ??? ++++ [??? ++++ [le pe we]]. 95 | move: le pe we; (do ? case :_ /)=> *; congr Add; exact/eq_irrelevance. 96 | Qed. 97 | 98 | Variable al : add_label. 99 | 100 | (* label of an event to add *) 101 | Notation lb := (add_lb al). 102 | 103 | (* predecessor of the new event (if it exists) *) 104 | Notation pred := (add_po al). 105 | 106 | (* if our event is `Read` then we should provide the corresponding `Write` 107 | event *) 108 | Notation write := (add_rf al). 109 | 110 | Lemma po_fresh_id : pred <^i fresh_id. 111 | Proof. by move/add_po_in_dom/fresh_seq_mem: al. Qed. 112 | 113 | Lemma rf_fresh_id : write <^i fresh_id. 114 | Proof. by move/add_rf_in_dom/fresh_seq_mem: al. Qed. 115 | 116 | Definition contain := 117 | has (fun e => (flab e == lb) && (ffrf e == write) && (ffpo e == pred)) dom. 118 | 119 | Definition add_fed := 120 | [ fsfun ffed with fresh_id |-> 121 | {| lab_prj := lb; fpo_prj := pred; frf_prj := write |} ]. 122 | 123 | Definition add_lab := fun e : E => lab_prj (add_fed e). 124 | Definition add_fpo := fun e : E => fpo_prj (add_fed e). 125 | Definition add_frf := fun e : E => frf_prj (add_fed e). 126 | 127 | Lemma add_fedE e : 128 | add_fed e = if e == fresh_id then mk_edescr lb pred write else fed es e. 129 | Proof. by rewrite /= fsfun_withE /=; case: ifP. Qed. 130 | 131 | Lemma add_labE e : 132 | add_lab e = if e == fresh_id then lb else lab es e. 133 | Proof. by rewrite /add_lab /add_fed /= fsfun_withE /=; case: ifP. Qed. 134 | 135 | Lemma add_fpoE e : 136 | add_fpo e = if e == fresh_id then pred else fpo es e. 137 | Proof. by rewrite /add_fpo /add_fed /= fsfun_withE /=; case: ifP. Qed. 138 | 139 | Lemma add_frfE e : 140 | add_frf e = if e == fresh_id then write else frf es e. 141 | Proof. by rewrite /add_frf /add_fed /= fsfun_withE; case: ifP. Qed. 142 | 143 | Fact add_fed_finsupp : finsupp add_fed == (seq_fset tt (fresh_id :: dom)). 144 | Proof. 145 | apply/fset_eqP=> x; rewrite ?inE seq_fsetE finsupp_with. 146 | case: ifP; rewrite ?inE fed_supp //. 147 | move: po_fresh_id=> /[swap]/eqP[?->]; by rewrite ltxx. 148 | Qed. 149 | 150 | Lemma add_fed0 : 151 | add_fed ident0 = {| lab_prj := \init; fpo_prj := ident0; frf_prj := ident0 |}. 152 | Proof. 153 | rewrite add_fedE lt_eqF; first exact/fed0. 154 | exact/fresh_seq_mem/dom0. 155 | Qed. 156 | 157 | Fact add_fpo_dom : 158 | [forall e : finsupp add_fed, add_fpo (val e) \in fresh_id :: dom]. 159 | Proof. 160 | apply/forallP=> [[/= x]]. 161 | rewrite (eqP add_fed_finsupp) ?inE seq_fsetE ?inE /add_fpo fsfun_withE. 162 | case: (x =P fresh_id) => /=; first by rewrite (add_po_in_dom al). 163 | by move=> ? /fpo_dom->. 164 | Qed. 165 | 166 | Fact add_frf_dom : 167 | [forall e : finsupp add_fed, add_frf (val e) \in fresh_id :: dom]. 168 | Proof. 169 | apply/forallP=> [[/= x]]. 170 | rewrite (eqP add_fed_finsupp) ?inE seq_fsetE ?inE /add_frf fsfun_withE. 171 | case: (x =P fresh_id)=> /=; first by rewrite (add_rf_in_dom al). 172 | by move=> ? /frf_dom->. 173 | Qed. 174 | 175 | Fact add_fpo_le : 176 | [forall e : finsupp add_fed, (val e != \i0) ==> (add_fpo (val e) <^i val e)]. 177 | Proof. 178 | apply/forallP=> [[/=]] e. 179 | rewrite (eqP add_fed_finsupp) ?inE seq_fsetE ?inE. 180 | rewrite add_fpoE; case: ifP=> /= [/eqP-> _|?]. 181 | - by rewrite po_fresh_id implybT. 182 | by move/fpo_n0/implyP. 183 | Qed. 184 | 185 | Fact add_frf_le : 186 | [forall e : finsupp add_fed, (val e != \i0) ==> (add_frf (val e) <^i val e)]. 187 | Proof. 188 | apply/forallP=> [[/=]] e. 189 | rewrite (eqP add_fed_finsupp) ?inE seq_fsetE ?inE. 190 | rewrite add_frfE; case: ifP=> /= [/eqP-> _|?]. 191 | - by rewrite rf_fresh_id implybT. 192 | by move/frf_n0/implyP. 193 | Qed. 194 | 195 | Fact add_frf_sync : 196 | [forall e : finsupp add_fed, add_lab (add_frf (val e)) (rf)>> add_lab (val e)]. 197 | Proof. 198 | apply/forallP=> [[/=]] e. 199 | rewrite (eqP add_fed_finsupp) ?inE seq_fsetE ?inE. 200 | rewrite !add_labE !add_frfE. 201 | case: (e =P fresh_id)=> /= [|? /frf_dom /fresh_seq_mem /lt_eqF->]. 202 | - by rewrite (lt_eqF rf_fresh_id) (add_rf_consist al). 203 | exact/frf_sync. 204 | Qed. 205 | 206 | Fact add_fpo_sync : 207 | [forall e : finsupp add_fed, add_lab (add_fpo (val e)) (po)>> add_lab (val e)]. 208 | Proof. 209 | apply/forallP=> [[/=]] e. 210 | rewrite (eqP add_fed_finsupp) ?inE seq_fsetE ?inE. 211 | rewrite !add_labE !add_fpoE. 212 | case: (e =P fresh_id)=> /= [|? /fpo_dom /fresh_seq_mem /lt_eqF->]. 213 | - by rewrite (lt_eqF po_fresh_id) (add_po_consist al). 214 | exact/fpo_sync. 215 | Qed. 216 | 217 | Lemma nfresh_dom0 : 218 | \i0 \in fresh_id :: dom. 219 | Proof. by rewrite ?inE dom0. Qed. 220 | 221 | Definition add_event := 222 | @Pack _ _ 223 | (fresh_id :: dom) 224 | add_fed 225 | add_fed_finsupp 226 | nfresh_dom0 227 | add_fed0 228 | add_fpo_dom 229 | add_frf_dom 230 | add_fpo_le 231 | add_frf_le 232 | add_fpo_sync 233 | add_frf_sync. 234 | 235 | Definition add_new_event := if contain then es else add_event. 236 | 237 | Hypothesis rf_ncf_dom_ : rf_ncf_dom es. 238 | (* Hypothesis rf_ncf_fresh : ~~ (cf add_event fresh_id write). *) 239 | 240 | Import Relation_Operators. 241 | 242 | (* TODO: remove duplicate lemmas `add_fedE`, `add_labE`, etc *) 243 | 244 | Lemma fed_add_eventE e : 245 | fed add_event e = if e == fresh_id then mk_edescr lb pred write else fed es e. 246 | Proof. exact: add_fedE. Qed. 247 | 248 | Lemma lab_add_eventE e : 249 | lab add_event e = if e == fresh_id then lb else lab es e. 250 | Proof. exact: add_labE. Qed. 251 | 252 | Lemma fpo_add_eventE e : 253 | fpo add_event e = if e == fresh_id then pred else fpo es e. 254 | Proof. exact: add_fpoE. Qed. 255 | 256 | Lemma frf_add_eventE e : 257 | frf add_event e = if e == fresh_id then write else frf es e. 258 | Proof. exact: add_frfE. Qed. 259 | 260 | Lemma ica_add_eventE e1 e2 : 261 | ica add_event e1 e2 = 262 | if e2 == fresh_id then 263 | (pred == e1) || (write == e1) 264 | else ica es e1 e2. 265 | Proof. 266 | rewrite icaE /= /fca frf_add_eventE fpo_add_eventE. 267 | case: ifP=> ?; rewrite ?(andTb, andFb) ?orbF // ?inE. 268 | by rewrite eq_sym orbC eq_sym orbC. 269 | Qed. 270 | 271 | Lemma ca_add_eventE e1 e2 : 272 | e2 != fresh_id -> ca es e1 e2 = ca add_event e1 e2. 273 | Proof. 274 | move=> N. 275 | apply/closure_n1P/closure_n1P; move: N=> /[swap]; elim; try constructor. 276 | all: move=> y ? I ? H /negbTE Z; apply: (@rtn1_trans _ _ _ y). 277 | 2,4: apply/H/negP; move: I. 278 | - by rewrite ica_add_eventE Z. 279 | - move/[swap]/eqP=>->/ica_fresh Ez. 280 | by move/eqP: Z Ez. 281 | - rewrite ica_add_eventE Z=> /[swap]/eqP->/ica_fresh. 282 | by move/eqP: Z. 283 | move: I; by rewrite ica_add_eventE Z. 284 | Qed. 285 | 286 | Lemma icf_add_eventE e1 e2 : 287 | e1 != fresh_id -> e2 != fresh_id -> 288 | icf es e1 e2 = icf add_event e1 e2. 289 | Proof. 290 | rewrite /icf !fpo_add_eventE lab_add_eventE=> /[dup] N /negbTE->/negbTE->. 291 | case: ifP=> //; case: (boolP (e1 \in dom))=> [|/fpo_ndom-> /(negP N)//]. 292 | by move/fpo_dom/fresh_seq_mem/lt_eqF->. 293 | Qed. 294 | 295 | Lemma cf_add_eventE e1 e2 : 296 | e1 != fresh_id -> e2 != fresh_id -> 297 | cf es e1 e2 = cf add_event e1 e2. 298 | Proof. 299 | move=> /[dup] /ca_fresh_contra Cnf1 Nf1 /[dup] /ca_fresh_contra Cnf2 Nf2. 300 | apply/cfP/cfP=> -[x [y C]]; exists x, y; move: C; rewrite -?ca_add_eventE //. 301 | - move=> [] ??; rewrite -icf_add_eventE //; 302 | [by rewrite Cnf1 | by rewrite Cnf2]. 303 | move=> [] ??; rewrite icf_add_eventE //; first by rewrite Cnf1 ?C. 304 | by rewrite Cnf2 ?C. 305 | Qed. 306 | 307 | Lemma rf_ncf_add_event : 308 | ~~ (cf add_event fresh_id write) <-> rf_ncf_dom add_event. 309 | Proof. 310 | split=> [? |]. 311 | - rewrite /rf_ncf_dom; apply /allP=> e1. 312 | rewrite /frf /= fsfun_withE ?inE. 313 | case: ifP=> /= [/eqP-> _|/negbT N /(allP rf_ncf_dom_)] //; first exact/implyP. 314 | rewrite -cf_add_eventE //. 315 | apply/negP=> /eqP Ef. 316 | have /ica_fresh /eqP /(negP N) //: ica es fresh_id e1. 317 | by rewrite icaE /= ?inE -Ef eq_refl. 318 | case: (boolP (write == fresh_id))=> [/eqP<- /cf_irrelf/(_ write)->|?] //. 319 | move/allP/(_ fresh_id)=> /=; rewrite frf_add_eventE inE eq_refl /=. 320 | move/(_ erefl)/implyP; exact. 321 | Qed. 322 | 323 | (* Lemma rf_ncf_add_new_event : 324 | ~~ (cf add_event fresh_id write) -> rf_ncf_dom add_new_event. 325 | Proof. rewrite /add_new_event; case: ifP=>// _; exact/rf_ncf_add_event. Qed. *) 326 | 327 | End AddEvent. 328 | 329 | (*Section NreadPrime. 330 | 331 | Context (pes : prime_porf_eventstruct) (pr : E) (l : label). 332 | 333 | Notation domain := (dom pes). 334 | Notation fresh_id := (fresh_seq domain). 335 | 336 | Hypothesis pr_mem : pr \in domain. 337 | Hypothesis nr : ~~ Label.is_read l. 338 | 339 | Fact add_nread_synch : lab pes ident0 \>> l. 340 | Proof. 341 | rewrite lab0 /Label.synch. 342 | case H: l=> //; symmetry; apply/contraPF. 343 | - move=> x; apply/negP; exact/nr. 344 | by rewrite /Label.is_read H. 345 | Qed. 346 | 347 | Let add_label_nread := Add pr_mem dom0 add_nread_synch. 348 | 349 | Lemma rf_ncf_nread : 350 | rf_ncf_dom (add_event add_label_nread). 351 | Proof. apply/rf_ncf_add_event=> //=; first (by case: pes); exact/cf0. Qed. 352 | 353 | Lemma rf_ncf_new_nread : 354 | rf_ncf_dom (add_new_event add_label_nread). 355 | Proof. 356 | rewrite /add_new_event; case: ifP=> // _. 357 | - by case pes. 358 | by rewrite ?rf_ncf_nread //. 359 | Qed. 360 | 361 | End NreadPrime.*) 362 | 363 | End TransitionSystem. 364 | 365 | Module AddEvent. 366 | 367 | Section Confluence. 368 | 369 | Context (E : identType) (Lab : labType). 370 | 371 | Notation porf_eventstruct := (@porf_eventstruct E Lab). 372 | Notation prime_porf_eventstruct := (@prime_porf_eventstruct E Lab). 373 | 374 | Notation label := Lab. 375 | 376 | Implicit Types (x : Loc) (es : porf_eventstruct). 377 | 378 | Definition tr es1 es2 := exists al, es2 = @add_event _ Lab es1 al. 379 | 380 | Notation "es1 '~>' es2" := (tr es1 es2) (at level 0). 381 | 382 | Definition ltr (ed : edescr E label) es1 es2 := 383 | exists2 al, es2 = @add_event _ Lab es1 al & ed = al. 384 | 385 | Notation "es1 '~(' l ')~>' es2" := (ltr l es1 es2) (at level 0). 386 | 387 | Section Equivalence. 388 | 389 | Section IsoDef. 390 | 391 | Context (f : E -> E) (es1 es2 : porf_eventstruct). 392 | 393 | Definition is_morph := fed es2 \o f =1 (edescr_map f) \o fed es1. 394 | 395 | Section Morphism. 396 | 397 | Hypothesis morph: is_morph. 398 | 399 | Lemma is_morph_lab e : 400 | lab es1 e = lab es2 (f e). 401 | Proof. 402 | move/(congr1 (@lab_prj _ _)): (morph e). 403 | by rewrite /lab /=; case: (fed es1 e). 404 | Qed. 405 | 406 | Lemma is_morph_po e : 407 | f (fpo es1 e) = fpo es2 (f e). 408 | Proof. 409 | move/(congr1 (@fpo_prj _ _)): (morph e). 410 | by rewrite fpo_prj_edescr_map. 411 | Qed. 412 | 413 | Lemma is_morph_rf e : 414 | f (frf es1 e) = frf es2 (f e). 415 | Proof. 416 | move/(congr1 (@frf_prj _ _)): (morph e). 417 | by rewrite frf_prj_edescr_map. 418 | Qed. 419 | 420 | Lemma is_morph_ica e1 e2 : 421 | ica es1 e1 e2 -> ica es2 (f e1) (f e2). 422 | Proof. 423 | rewrite ?icaE /fca /= ?inE -is_morph_po -is_morph_rf=> /orP[]/eqP->; 424 | by rewrite eq_refl. 425 | Qed. 426 | 427 | Lemma is_morph_ca e1 e2 : 428 | ca es1 e1 e2 -> ca es2 (f e1) (f e2). 429 | Proof. 430 | move/closure_n1P; elim=> [|??/is_morph_ica I ?]; first exact/ca_refl. 431 | move/closure_n1P=> ?; apply/closure_n1P. 432 | by apply/Relation_Operators.rtn1_trans; first by exact/I. 433 | Qed. 434 | 435 | End Morphism. 436 | 437 | 438 | Definition is_iso := is_morph /\ bijective f. 439 | 440 | Section IsoMorphism. 441 | 442 | Hypothesis iso : is_iso. 443 | 444 | Lemma iso_dom : map f (dom es1) =i dom es2. 445 | Proof. 446 | case: iso=> l /[dup] B [g /[dup] c1 /can_inj I c2 x]. 447 | rewrite -[x]c2 (mem_map I) -?fed_supp_mem !mem_finsupp. 448 | move: (l (g x))=> /= ->. 449 | rewrite -[_ _ (f _) _]/(edescr_map f (mk_edescr _ _ _)). 450 | by rewrite (bij_eq (@edescr_map_bij label E E _ B)). 451 | Qed. 452 | 453 | Lemma f_icf e1 e2 : 454 | icf es1 e1 e2 -> icf es2 (f e1) (f e2). 455 | Proof. 456 | case: iso=> ??. 457 | rewrite/icf ?lt_neqAle ?fpo_le ?andbT. 458 | by rewrite ?is_morph_lab -?is_morph_po ?(bij_eq (f := f)). 459 | Qed. 460 | 461 | Lemma f_cf e1 e2 : 462 | es1 |- e1 # e2 -> es2 |- (f e1) # (f e2). 463 | Proof. 464 | case: iso=> ?? /cfP [x [y [*]]]; apply/cfP; exists (f x), (f y). 465 | by rewrite ?is_morph_ca ?f_icf. 466 | Qed. 467 | 468 | End IsoMorphism. 469 | 470 | End IsoDef. 471 | 472 | Lemma is_iso_can es1 es2 f g : 473 | is_iso f es1 es2 -> cancel f g -> cancel g f -> 474 | is_iso g es2 es1. 475 | Proof. 476 | move=> [l b c1 c2]. 477 | have B: bijective g by apply/(bij_can_bij b). 478 | split=> //; do ? split; try move=> x /=. 479 | apply/(bij_inj (@edescr_map_bij label _ _ _ b)). 480 | move: (l (g x))=> /= <-. 481 | by rewrite ?(edescr_map_can c2) c2. 482 | Qed. 483 | 484 | Lemma isoE f e1 e2 es1 es2: is_iso f es1 es2 -> 485 | ( 486 | (lab es1 e1 = lab es2 (f e1)) * 487 | ((f (fpo es1 e1) = fpo es2 (f e1)) * 488 | (f (frf es1 e1) = frf es2 (f e1))) * 489 | ((ca es1 e1 e2 = ca es2 (f e1) (f e2)) * 490 | (cf es1 e1 e2 = cf es2 (f e1) (f e2))) 491 | )%type. 492 | Proof. 493 | move=> /[dup] If [M []? /[dup] c /(is_iso_can If) /[apply] Ig]. 494 | do ? split; rewrite ?(is_morph_po M) ?(is_morph_lab M) ?(is_morph_rf M) //. 495 | - apply/(sameP idP)/(equivP idP). 496 | split=> [/(is_morph_ca Ig.1)|/(is_morph_ca M)//]; by rewrite ?c. 497 | apply/(sameP idP)/(equivP idP). 498 | split=> [/(f_cf Ig)|/(f_cf If)//]; by rewrite ?c. 499 | Qed. 500 | 501 | Lemma eq_is_iso f g es1 es2 : f =1 g -> 502 | is_iso f es1 es2 <-> is_iso g es1 es2. 503 | Proof. 504 | move=> /[dup] /fsym H1 H2; rewrite /is_iso /is_morph. 505 | have->: bijective f <-> bijective g. 506 | - by split=> [/eq_bij/(_ _ H2) |/eq_bij/(_ _ H1)]. 507 | apply/(and_iff_compat_r (bijective g)). 508 | split=> H x; move: (H x)=> /=; rewrite (H1, H2)=>->; 509 | by under edescr_map_eqfun=> ? do rewrite (H1, H2) over //. 510 | Qed. 511 | 512 | Definition eqv := exlab is_iso. 513 | 514 | Lemma eqv_refl : \1 \<= eqv. 515 | Proof. 516 | move=> ??->. exists id; do ? split=> //; last exact/inv_bij; 517 | rewrite ?map_id // => ? /=; by rewrite edescr_map_id. 518 | Qed. 519 | 520 | Lemma is_iso_comp es1 es2 es3 f g : 521 | is_iso f es1 es2 -> is_iso g es2 es3 -> 522 | is_iso (g \o f) es1 es3 . 523 | Proof. 524 | case=> [] l1 ?[] l2 /[dup] [[?? c1 ?]] . 525 | (do ? split)=>[x|]; last exact/bij_comp. 526 | by move: (l1 x) (l2 (f x))=> /=; rewrite edescr_map_comp /= => <-. 527 | Qed. 528 | 529 | Lemma eqv_trans : Transitive eqv. 530 | Proof. move=> ???[f i [g ?]]; exists (g \o f); exact/(is_iso_comp i). Qed. 531 | 532 | Lemma eqv_symm : Symmetric eqv. 533 | Proof. move=>> [? /[dup] I [_ [f *]]]; exists f; exact/(is_iso_can I). Qed. 534 | 535 | End Equivalence. 536 | 537 | Notation "e1 ~~ e2" := (eqv e1 e2) (at level 20). 538 | 539 | Notation fresh_id1 es := (fresh_seq (dom es)). 540 | Notation fresh_id2 es := (fresh_seq (fresh_seq (dom es) :: dom es)). 541 | 542 | Lemma is_iso_swap es1 es2 f e1 e2 : 543 | e1 \notin dom es1 -> 544 | e2 \notin dom es1 -> 545 | is_iso f es1 es2 -> 546 | is_iso (swap f e1 e2) es1 es2. 547 | Proof. 548 | move=> N1 N2 /[dup] I [ l /[dup] /bij_inj ? b]. 549 | case: (e1 =P e2)=> /= [->|/eqP/negbTE e12]. 550 | - by under eq_is_iso=> ? do rewrite swapxx over //. 551 | (do ? split)=> [x/=|]; last exact/bij_swap. 552 | have H: forall e es, e \notin dom es -> fed es e = mk_edescr \eps e e. 553 | - by move=> ?? D; rewrite fsfun_dflt // fed_supp_mem D. 554 | rewrite /swap; case: ifP=> [/eqP->|]. 555 | - rewrite ?H /= ?eq_refl // -?(iso_dom I) mem_map //. 556 | case: ifP=> [/eqP-> N|F1 F2]. 557 | rewrite ?H //= ?N ?eq_refl // -?(iso_dom I) mem_map //. 558 | case: (boolP (x \in dom es1))=> [/[dup]/fpo_dom I1 /frf_dom I2|?]. 559 | - apply/eqP; rewrite edescr_eq. 560 | rewrite lab_prj_edescr_map fpo_prj_edescr_map frf_prj_edescr_map. 561 | rewrite ?(negbTE (memPn _ _ I1)) ?(negbTE (memPn _ _ I2)) //. 562 | move: (l x)=> /=->. 563 | rewrite lab_prj_edescr_map fpo_prj_edescr_map frf_prj_edescr_map. 564 | by rewrite !eq_refl. 565 | by rewrite ?H //= ?F1 ?F2 // -?(iso_dom I) mem_map. 566 | Qed. 567 | 568 | Arguments Add {_ _ _ _} _ _ _. 569 | 570 | Lemma comm_eqv_tr : 571 | diamond_commute eqv tr. 572 | Proof. 573 | move=> es es3 ? /[swap][][[al ap aw apd awd apc awc]]->. 574 | case=> f /[dup][[_ [g? c]]] I. 575 | have NI: g (fresh_id1 es3) \notin dom es. 576 | - by rewrite -(mem_map (bij_inj (proj2 I))) c (iso_dom I) fresh_seq_nmem //. 577 | move/(is_iso_swap (fresh_seq_nmem (dom es)) NI): I. 578 | set h := (swap f (fresh_id1 es) (g (fresh_id1 es3))). 579 | move=> /[dup] I [ l /[dup] /bij_inj ? b]. 580 | have H: forall e, e \in dom es -> h e \in dom es3=> [e|]. 581 | by rewrite -(iso_dom I) mem_map. 582 | have [: a1 a2 a3 a4] @s4: add_label es3 := @Add E Lab es3 al (h ap) (h aw) a1 a2 a3 a4. 583 | 1,2: by apply/H; rewrite (apd, awd). 584 | - move: apc; move: (l ap)=> /=; rewrite /lab. 585 | by case L1: (fed _ ap)=> /=; case L2: (fed es3 (f ap))=> -> /=. 586 | - move: awc; move: (l aw)=> /=; rewrite /lab. 587 | by case L1: (fed _ aw)=> /=; case L2: (fed es3 (f aw))=> -> /=. 588 | exists (add_event s4); [by exists s4 | exists h]. 589 | (do ? split)=> // x /=. 590 | rewrite ?fed_add_eventE /= -[fresh_id1 _]c -(swap1 f (fresh_id1 es)). 591 | rewrite -/h (bij_eq b); case: ifP=> // ?; exact/l. 592 | Qed. 593 | 594 | Lemma swap_dom es e : e \in dom es -> 595 | swap id (fresh_id1 es) (fresh_id2 es) e = e. 596 | Proof. 597 | move=> H; rewrite -swap_not_eq=> //; rewrite lt_eqF //. 598 | - by apply /fresh_seq_mem. 599 | by apply /fresh_seq_mem; rewrite inE; apply /orP; right. 600 | Qed. 601 | 602 | Lemma add_add (es : porf_eventstruct) 603 | (al1 al2 : add_label es) : 604 | exists al : add_label (add_event al1), 605 | al = al2 :> edescr E label. 606 | Proof. 607 | case: al2=> l p w ap aw ??. 608 | have [:a1 a2 a3 a4] @al : add_label (add_event al1) := 609 | @Add E Lab (add_event al1) l p w a1 a2 a3 a4; try by rewrite ?inE (ap, aw) orbT. 610 | - by rewrite /= lab_add_eventE (lt_eqF (fresh_seq_mem ap)). 611 | - by rewrite /= lab_add_eventE (lt_eqF (fresh_seq_mem aw)). 612 | by exists al; rewrite ?(swap_dom (lexx _)). 613 | Qed. 614 | 615 | Lemma swap_add es 616 | (al1 al2 : add_label es) 617 | (al3 : add_label (add_event al1)) 618 | (al4 : add_label (add_event al2)) : 619 | al1 = al4 :> edescr E label -> 620 | al2 = al3 :> edescr E label -> 621 | is_iso (swap id (fresh_id1 es) (fresh_id2 es)) 622 | (add_event al3) (add_event al4) . 623 | Proof. 624 | case: al1 al3 al2 al4=> ???????[/=???++++] [???????[/=???++++ E1 E2]]. 625 | case: E1 E2; do 3? case:_/; case; (do 3? case:_/)=>*. 626 | do ? split; last exact/bij_swap/inv_bij. 627 | move=> x /=; rewrite /comp !fed_add_eventE /=. 628 | have: fresh_id1 es <> fresh_id2 es. 629 | - suff: fresh_id1 es < fresh_id2 es by rewrite lt_def eq_sym=> /andP[] /eqP. 630 | by apply/fresh_seq_mem/mem_head. 631 | move/eqP/negbTE=>F; case: (x =P fresh_id1 es)=> [->|/eqP/[dup] ? /negbTE N1]. 632 | - rewrite swap1 eq_refl F /= !swap_dom //. 633 | rewrite ?inv_eq ?swap1 ?swap2 ?N1; try exact/swap_inv. 634 | case: ifP=> //=; first by rewrite !swap_dom=> //. 635 | move/negbT=> ?; rewrite -swap_not_eq //. 636 | case: (boolP (x \in dom es))=> [|I]. 637 | - case L: (fed _ x)=> [l p r] I /=; apply/congr2; rewrite swap_dom //. 638 | - by rewrite -[p]/(fpo_prj (mk_edescr l p r)) -L fpo_dom. 639 | by rewrite -[r]/(frf_prj (mk_edescr l p r)) -L frf_dom. 640 | by rewrite fsfun_dflt /= -?swap_not_eq // fed_supp I. 641 | Qed. 642 | 643 | Lemma comm_ltr l1 l2 : 644 | eqv_diamond_commute (ltr l1) (ltr l2) eqv. 645 | Proof. 646 | move=> es ?? [al1 -> /[swap][[al2->]]]. 647 | case: (add_add al1 al2)=> al3 /[dup]? <-->. 648 | case: (add_add al2 al1)=> al4 /[dup]? <-->. 649 | exists (add_event al3), (add_event al4). 650 | split; [by exists al3| by exists al4|]. 651 | exists (swap id (fresh_id1 es) (fresh_id2 es)); exact/swap_add. 652 | Qed. 653 | 654 | Lemma exlab_tr : tr \== exlab ltr. 655 | Proof. by move=> ??; split=> [[l ->]|[?[l ->]]]; do ? exists l. Qed. 656 | 657 | Arguments isoE {_ _ _ _ _}. 658 | 659 | Lemma dom_consist_eqv es1 es2 : 660 | es1 ~~ es2 -> rf_ncf_dom es1 -> 661 | rf_ncf_dom es2. 662 | Proof. 663 | rewrite /rf_ncf_dom=> [[f /[dup] If]] [L ? /allP H]; apply/allP. 664 | move=> x; rewrite -(iso_dom If)=> /mapP[y /H ?->]. 665 | move/(congr1 (@frf_prj _ _)): (L y)=> /=; rewrite -frfE=>->. 666 | by rewrite frf_prj_edescr_map bij_eq // -(isoE If). 667 | Qed. 668 | 669 | Lemma dom_consist_add l1 l2 670 | (es1 es2 es3 es4 : porf_eventstruct) : 671 | rf_ncf_dom es1 -> 672 | es1 ~(l1)~> es2 -> rf_ncf_dom es2 -> 673 | es1 ~(l2)~> es3 -> rf_ncf_dom es3 -> 674 | es2 ~(l2)~> es4 -> rf_ncf_dom es4. 675 | Proof. 676 | move=> ?; case=> [[la1 p1 w1 ap1 aw1 ad1 ac1 ->]]. 677 | set al1 := @Add E Lab _ _ _ _ ap1 aw1 ad1 ac1=> e2; move=> C'. 678 | case=> [[l p w ap aw ad ac]]+->; set al2 := @Add E Lab _ _ _ _ ap aw ad ac=> -> C. 679 | case=> [[l' p' ap' ++++-> [le pe we]]]. 680 | move: le pe we; (do ? case: _/). 681 | move=> ap2 aw2 ad2 ac2; set al2' := @Add E Lab _ _ _ _ ap2 aw2 ad2 ac2. 682 | apply/rf_ncf_add_event=> //=. 683 | set f := swap id (fresh_id1 es1) (fresh_id2 es1). 684 | have P : f p1 = p1 by rewrite /f (swap_dom ap1). 685 | have W : f w1 = w1 by rewrite /f (swap_dom aw1). 686 | have [: a1 a2 a3 a4] @al3 : add_label (add_event al2) 687 | := @Add E Lab _ la1 (f p1) (f w1) a1 a2 a3 a4=> /=. 688 | 1,2: rewrite ?inE (P, W) (ap1, aw1); lattice. 689 | - by rewrite P lab_add_eventE (lt_eqF (po_fresh_id al1)). 690 | - by rewrite W lab_add_eventE (lt_eqF (rf_fresh_id al1)). 691 | have E1: al1 = al3 :> edescr _ _ by rewrite /= W P. 692 | have E2: al2 = al2' :> edescr _ _ by []. 693 | rewrite (isoE (swap_add E1 E2)) swap2 (swap_dom aw) //. 694 | rewrite -cf_add_eventE; first exact/rf_ncf_add_event. 695 | - suff: fresh_id1 es1 < fresh_id1 (add_event al2) by rewrite lt_def eq_sym=> /andP[]. 696 | by apply /fresh_seq_mem=> /=; apply mem_head. 697 | by rewrite (lt_eqF (rf_fresh_id al2')). 698 | Qed. 699 | 700 | Lemma dup_free_eqv es1 es2 : 701 | es1 ~~ es2 -> dup_free es1 -> dup_free es2. 702 | Proof. 703 | case=> f /[dup] If [M /[dup][[g c1 c2]] b /dup_freeP I]. 704 | apply/dup_freeP=> x y. 705 | rewrite -?(iso_dom If) -[x]c2 -[y]c2 ?(mem_map (bij_inj b)). 706 | move: (M (g x)) (M (g y)). 707 | by move=> /=->-> /I/[apply] Eq /(bij_inj (edescr_map_bij b))/Eq->. 708 | Qed. 709 | 710 | Lemma fresh_id12 es : 711 | fresh_id1 es == fresh_id2 es = false. 712 | Proof. 713 | apply /contra_neqF; first exact /eqP. 714 | suff: fresh_id1 es < fresh_id2 es by rewrite lt_def eq_sym=> /andP[]. 715 | by apply/fresh_seq_mem/mem_head. 716 | Qed. 717 | 718 | Lemma dup_free_add l1 l2 719 | (es1 es2 es3 es4 : porf_eventstruct) : 720 | es2 != es3 -> 721 | dup_free es1 -> 722 | es1 ~(l1)~> es2 -> dup_free es2 -> 723 | es1 ~(l2)~> es3 -> dup_free es3 -> 724 | es2 ~(l2)~> es4 -> dup_free es4. 725 | Proof. 726 | move=> + /dup_freeP I1 [al1] + ? => /[swap]->. 727 | move=> + /dup_freeP I2 [al2] + -> => /[swap]-> /negP N. 728 | have {N} ?: al1 <> al2 :> edescr _ _ by move: N=>/[swap]/of_add_label_inj->. 729 | move/dup_freeP=> I3 [al3] -> Eq. 730 | have N: al1 <> al3 :> edescr _ _ by rewrite -Eq=> /of_add_label_inj //. 731 | apply/dup_freeP=> x y /=. 732 | move: (I1 x y) (I2 x y)=> /=. rewrite ?add_fedE ?inE /=. 733 | case: ifP=> /= [/eqP->|]. 734 | - rewrite fresh_id12 /=; case: ifP=> [/eqP->|]. 735 | - by rewrite fresh_id12. 736 | case: ifP=> /= [/eqP->|???/[apply]/[apply]//]. 737 | move=> ????? []; case: (al1) (al3) N=> /= ??????? [/=]. 738 | by move=>> ???? /[swap]->/[swap]->/[swap]->. 739 | case: ifP=> /= [/eqP->|]. 740 | - rewrite fresh_id12 /=; case: ifP=> /= // ?????? /esym. 741 | by case: (al1) (al3) N=> /= ??????? []. 742 | case: ifP=> /= [/eqP->|]; case: ifP=> [/eqP->|] //=. 743 | - move=> ? /[dup] EN + ???? D Ef; move: (I3 (fresh_id1 es1) y)=> /=. 744 | rewrite ?inE ?add_fedE {-3}EN -Ef ?eqxx D /==> /(_ erefl erefl) L. 745 | have->: fresh_id1 es1 = y by apply/L; case: (al2) (al3) Eq=> ??????? []. 746 | by rewrite eqxx. 747 | move=> ?? /[dup] EN + ?? D ? Ef; move: (I3 x (fresh_id1 es1))=> /=. 748 | rewrite ?inE ?add_fedE {-3}EN Ef ?eqxx D /==> /(_ erefl erefl) L. 749 | have->: x = fresh_id1 es1 by apply/L; case: (al2) (al3) Eq=> ??????? []. 750 | by rewrite eqxx. 751 | Qed. 752 | 753 | End Confluence. 754 | 755 | End AddEvent. 756 | 757 | --------------------------------------------------------------------------------