├── .github └── workflows │ ├── build.yml │ └── deploy.yml ├── .gitignore ├── Makefile ├── _CoqProject ├── coq-domains.opam ├── extra ├── footer.html ├── header.html ├── index.html └── resources │ ├── config.js │ ├── coqdoc.css │ ├── coqdocjs.css │ └── coqdocjs.js └── theories ├── ClosedModality.v ├── Dcpo.v ├── DcpoExponential.v ├── DcpoProduct.v ├── ILift.v ├── Kleene.v ├── Lift.v ├── Path.v ├── Poset.v ├── Preamble.v ├── Preorder.v ├── Sierpinski.v ├── Skeleton.v ├── UNat.v └── WF.v /.github/workflows/build.yml: -------------------------------------------------------------------------------- 1 | name: build 2 | 3 | # Controls when the action will run. 4 | on: [push,pull_request] 5 | 6 | 7 | jobs: 8 | build: 9 | runs-on: ubuntu-latest # container actions require GNU/Linux 10 | strategy: 11 | matrix: 12 | coq_version: 13 | - '8.15' 14 | ocaml_version: 15 | - '4.13-flambda' 16 | fail-fast: false # don't stop jobs if one fails 17 | steps: 18 | - uses: actions/checkout@v2 19 | - uses: coq-community/docker-coq-action@v1 20 | with: 21 | opam_file: 'coq-domains.opam' 22 | coq_version: ${{ matrix.coq_version }} 23 | ocaml_version: ${{ matrix.ocaml_version }} 24 | before_script: | 25 | startGroup "Workaround permission issue" 26 | sudo chown -R coq:coq . 27 | endGroup 28 | script: | 29 | startGroup "Build project" 30 | make 31 | endGroup 32 | -------------------------------------------------------------------------------- /.github/workflows/deploy.yml: -------------------------------------------------------------------------------- 1 | name: deploy 2 | 3 | # Controls when the action will run. 4 | on: 5 | # Triggers the workflow on push or pull request events but only for the main branch 6 | push: 7 | branches: [ main ] 8 | 9 | # Allows you to run this workflow manually from the Actions tab 10 | workflow_dispatch: 11 | 12 | 13 | jobs: 14 | build: 15 | runs-on: ubuntu-latest # container actions require GNU/Linux 16 | strategy: 17 | matrix: 18 | coq_version: 19 | - '8.15' 20 | ocaml_version: 21 | - '4.13-flambda' 22 | fail-fast: false # don't stop jobs if one fails 23 | steps: 24 | - uses: actions/checkout@v2 25 | - uses: coq-community/docker-coq-action@v1 26 | with: 27 | opam_file: 'coq-domains.opam' 28 | coq_version: ${{ matrix.coq_version }} 29 | ocaml_version: ${{ matrix.ocaml_version }} 30 | before_script: | 31 | startGroup "Workaround permission issue" 32 | sudo chown -R coq:coq . 33 | endGroup 34 | script: | 35 | startGroup "Build project" 36 | make 37 | endGroup 38 | 39 | - uses: peaceiris/actions-gh-pages@v3 40 | with: 41 | github_token: ${{ secrets.GITHUB_TOKEN }} 42 | force_orphan: false 43 | keep_files: true 44 | publish_dir: ./html 45 | 46 | 47 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | .DS_store 2 | *~ 3 | *.cache 4 | *.d 5 | *\#* 6 | *.aux* 7 | *glob 8 | *.vo* 9 | Makefile.coq 10 | Makefile.coq.conf 11 | CoqMakefile.conf 12 | html/ 13 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | EXTRA_DIR:=extra 2 | COQDOCFLAGS:= \ 3 | --external 'http://ssr2.msr-inria.inria.fr/doc/ssreflect-1.5/' Ssreflect \ 4 | --external 'http://ssr2.msr-inria.inria.fr/doc/mathcomp-1.5/' MathComp \ 5 | --toc --toc-depth 2 --html --interpolate \ 6 | --index indexpage --no-lib-name --parse-comments \ 7 | --with-header $(EXTRA_DIR)/header.html --with-footer $(EXTRA_DIR)/footer.html 8 | export COQDOCFLAGS 9 | COQMAKEFILE:=Makefile.coq 10 | COQ_PROJ:=_CoqProject 11 | VS:=$(wildcard *.v) 12 | VS_IN_PROJ:=$(shell grep .v $(COQ_PROJ)) 13 | 14 | ifeq (,$(VS_IN_PROJ)) 15 | VS_OTHER := $(VS) 16 | else 17 | VS := $(VS_IN_PROJ) 18 | endif 19 | 20 | all: html 21 | 22 | clean: $(COQMAKEFILE) 23 | @$(MAKE) -f $(COQMAKEFILE) $@ 24 | rm -f $(COQMAKEFILE) 25 | 26 | html: $(COQMAKEFILE) $(VS) 27 | rm -rf html 28 | @$(MAKE) -f $(COQMAKEFILE) $@ 29 | cp $(EXTRA_DIR)/index.html html 30 | cp $(EXTRA_DIR)/resources/* html 31 | 32 | $(COQMAKEFILE): $(COQ_PROJ) $(VS) 33 | coq_makefile -f $(COQ_PROJ) $(VS_OTHER) -o $@ 34 | 35 | %: $(COQMAKEFILE) force 36 | @$(MAKE) -f $(COQMAKEFILE) $@ 37 | force $(COQ_PROJ) $(VS): ; 38 | 39 | .PHONY: clean all force 40 | -------------------------------------------------------------------------------- /_CoqProject: -------------------------------------------------------------------------------- 1 | -R theories/ Domains 2 | -arg -w 3 | -arg all 4 | theories/Preamble.v 5 | theories/Preorder.v 6 | theories/Poset.v 7 | theories/Dcpo.v 8 | theories/DcpoExponential.v 9 | theories/DcpoProduct.v 10 | theories/Sierpinski.v 11 | theories/UNat.v 12 | theories/Path.v 13 | theories/Lift.v 14 | theories/ClosedModality.v 15 | theories/Kleene.v 16 | theories/ILift.v 17 | theories/Skeleton.v 18 | theories/WF.v 19 | 20 | -------------------------------------------------------------------------------- /coq-domains.opam: -------------------------------------------------------------------------------- 1 | opam-version: "2.0" 2 | synopsis: "A Coq library for constructive domain theory" # One-line description 3 | description: """ 4 | A Coq library for constructive domain theory 5 | """ # Longer description, can span several lines 6 | 7 | homepage: "https://github.com/jonsterling/coq-domains" 8 | dev-repo: "git+https://github.com/jonsterling/coq-domains.git" 9 | bug-reports: "https://github.com/jonsterling/coq-domains/issues" 10 | doc: "https://jonsterling.github.io/coq-domains/" 11 | maintainer: "your@email.address" 12 | authors: [ 13 | "Jonathan Sterling" 14 | "Alex Gryzlov" 15 | ] 16 | 17 | # license: "MIT" # what should the license be ??? 18 | 19 | depends: [ 20 | "coq" {>= "8.13.2" & < "8.16~"} 21 | "coq-mathcomp-ssreflect" {>= "1.6"} 22 | "coq-hierarchy-builder" {>= "1.1.0"} 23 | ] 24 | 25 | build: [ 26 | [make] 27 | ] 28 | install: [ 29 | [make "install"] 30 | ] 31 | 32 | -------------------------------------------------------------------------------- /extra/footer.html: -------------------------------------------------------------------------------- 1 | 2 | 5 | 6 | 7 | 8 | 9 | -------------------------------------------------------------------------------- /extra/header.html: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | 6 | 7 | 8 | 9 | 10 | 11 | 12 | 13 | 26 |
27 |
28 | -------------------------------------------------------------------------------- /extra/index.html: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | HTML Meta Tag 5 | 6 | 7 | 8 |

(redirecting you)

9 | 10 | 11 | -------------------------------------------------------------------------------- /extra/resources/config.js: -------------------------------------------------------------------------------- 1 | var coqdocjs = coqdocjs || {}; 2 | 3 | coqdocjs.repl = { 4 | "forall": "∀", 5 | "exists": "∃", 6 | "~": "¬", 7 | "/\\": "∧", 8 | "\\/": "∨", 9 | "->": "→", 10 | "<-": "←", 11 | "<->": "↔", 12 | "=>": "⇒", 13 | "<>": "≠", 14 | "<=": "≤", 15 | ">=": "≥", 16 | "el": "∈", 17 | "nel": "∉", 18 | "<<=": "⊆", 19 | "|-": "⊢", 20 | ">>": "»", 21 | "<<": "⊆", 22 | "++": "⧺", 23 | "===": "≡", 24 | "=/=": "≢", 25 | "=~=": "≅", 26 | "==>": "⟹", 27 | "lhd": "⊲", 28 | "rhd": "⊳", 29 | "nat": "ℕ", 30 | "alpha": "α", 31 | "beta": "β", 32 | "gamma": "γ", 33 | "delta": "δ", 34 | "epsilon": "ε", 35 | "eta": "η", 36 | "iota": "ι", 37 | "kappa": "κ", 38 | "lambda": "λ", 39 | "mu": "μ", 40 | "nu": "ν", 41 | "omega": "ω", 42 | "phi": "ϕ", 43 | "pi": "π", 44 | "psi": "ψ", 45 | "rho": "ρ", 46 | "sigma": "σ", 47 | "tau": "τ", 48 | "theta": "θ", 49 | "xi": "ξ", 50 | "zeta": "ζ", 51 | "Delta": "Δ", 52 | "Gamma": "Γ", 53 | "Pi": "Π", 54 | "Sigma": "Σ", 55 | "Omega": "Ω", 56 | "Xi": "Ξ" 57 | }; 58 | 59 | coqdocjs.subscr = { 60 | "0" : "₀", 61 | "1" : "₁", 62 | "2" : "₂", 63 | "3" : "₃", 64 | "4" : "₄", 65 | "5" : "₅", 66 | "6" : "₆", 67 | "7" : "₇", 68 | "8" : "₈", 69 | "9" : "₉", 70 | }; 71 | 72 | coqdocjs.replInText = ["==>","<=>", "=>", "->", "<-", ":="]; 73 | -------------------------------------------------------------------------------- /extra/resources/coqdoc.css: -------------------------------------------------------------------------------- 1 | @import url('https://fonts.googleapis.com/css2?family=Fira+Code&display=swap'); 2 | @import url('https://fonts.googleapis.com/css2?family=Fira+Sans&display=swap'); 3 | 4 | 5 | body{ 6 | font-family: 'Fira Sans', sans-serif; 7 | font-size: 14px; 8 | color: #2D2D2D 9 | } 10 | 11 | a { 12 | text-decoration: none; 13 | border-radius: 3px; 14 | padding-left: 3px; 15 | padding-right: 3px; 16 | margin-left: -3px; 17 | margin-right: -3px; 18 | color: inherit; 19 | font-weight: bold; 20 | } 21 | 22 | #main .code a, #main .inlinecode a, #toc a { 23 | font-weight: inherit; 24 | } 25 | 26 | a[href]:hover, [clickable]:hover{ 27 | background-color: rgba(0,0,0,0.1); 28 | cursor: pointer; 29 | } 30 | 31 | h, h1, h2, h3, h4, h5 { 32 | line-height: 1; 33 | color: black; 34 | text-rendering: optimizeLegibility; 35 | font-weight: normal; 36 | letter-spacing: 0.1em; 37 | text-align: left; 38 | } 39 | 40 | div + br { 41 | display: none; 42 | } 43 | 44 | div:empty{ display: none;} 45 | 46 | #main h1 { 47 | font-size: 2em; 48 | } 49 | 50 | #main h2 { 51 | font-size: 1.667rem; 52 | } 53 | 54 | #main h3 { 55 | font-size: 1.333em; 56 | } 57 | 58 | #main h4, #main h5, #main h6 { 59 | font-size: 1em; 60 | } 61 | 62 | #toc h2 { 63 | padding-bottom: 0; 64 | } 65 | 66 | #main .doc { 67 | margin: 0; 68 | text-align: justify; 69 | } 70 | 71 | .inlinecode, .code, #main pre { 72 | font-family: 'Fira Code', monospace; 73 | } 74 | 75 | .code > br:first-child { 76 | display: none; 77 | } 78 | 79 | .doc + .code{ 80 | margin-top:0.5em; 81 | } 82 | 83 | .block{ 84 | display: block; 85 | margin-top: 5px; 86 | margin-bottom: 5px; 87 | padding: 10px; 88 | text-align: center; 89 | } 90 | 91 | .block img{ 92 | margin: 15px; 93 | } 94 | 95 | table.infrule { 96 | border: 0px; 97 | margin-left: 50px; 98 | margin-top: 10px; 99 | margin-bottom: 10px; 100 | } 101 | 102 | td.infrule { 103 | font-family: "Fira Code", "DejaVu Sans Mono", monospace; 104 | text-align: center; 105 | padding: 0; 106 | line-height: 1; 107 | } 108 | 109 | tr.infrulemiddle hr { 110 | margin: 1px 0 1px 0; 111 | } 112 | 113 | .infrulenamecol { 114 | color: rgb(60%,60%,60%); 115 | padding-left: 1em; 116 | padding-bottom: 0.1em 117 | } 118 | 119 | .id[type="constructor"], .id[type="projection"], .id[type="method"], 120 | .id[title="constructor"], .id[title="projection"], .id[title="method"] { 121 | color: #A30E16; 122 | } 123 | 124 | .id[type="var"], .id[type="variable"], 125 | .id[title="var"], .id[title="variable"] { 126 | color: inherit; 127 | } 128 | 129 | .id[type="definition"], .id[type="record"], .id[type="class"], .id[type="instance"], .id[type="inductive"], .id[type="library"], 130 | .id[title="definition"], .id[title="record"], .id[title="class"], .id[title="instance"], .id[title="inductive"], .id[title="library"] { 131 | color: #A6650F; 132 | } 133 | 134 | .id[type="lemma"], 135 | .id[title="lemma"]{ 136 | color: #188B0C; 137 | } 138 | 139 | .id[type="keyword"], .id[type="notation"], .id[type="abbreviation"], 140 | .id[title="keyword"], .id[title="notation"], .id[title="abbreviation"]{ 141 | color : #2874AE; 142 | } 143 | 144 | .comment { 145 | color: #808080; 146 | } 147 | 148 | /* TOC */ 149 | 150 | #toc h2{ 151 | letter-spacing: 0; 152 | font-size: 1.333em; 153 | } 154 | 155 | /* Index */ 156 | 157 | #index { 158 | margin: 0; 159 | padding: 0; 160 | width: 100%; 161 | } 162 | 163 | #index #frontispiece { 164 | margin: 1em auto; 165 | padding: 1em; 166 | width: 60%; 167 | } 168 | 169 | .booktitle { font-size : 140% } 170 | .authors { font-size : 90%; 171 | line-height: 115%; } 172 | .moreauthors { font-size : 60% } 173 | 174 | #index #entrance { 175 | text-align: center; 176 | } 177 | 178 | #index #entrance .spacer { 179 | margin: 0 30px 0 30px; 180 | } 181 | 182 | ul.doclist { 183 | margin-top: 0em; 184 | margin-bottom: 0em; 185 | } 186 | 187 | #toc > * { 188 | clear: both; 189 | } 190 | 191 | #toc > a { 192 | display: block; 193 | float: left; 194 | margin-top: 1em; 195 | } 196 | 197 | #toc a h2{ 198 | display: inline; 199 | } 200 | -------------------------------------------------------------------------------- /extra/resources/coqdocjs.css: -------------------------------------------------------------------------------- 1 | /* replace unicode */ 2 | 3 | .id[repl] .hidden { 4 | font-size: 0; 5 | } 6 | 7 | .id[repl]:before{ 8 | content: attr(repl); 9 | } 10 | 11 | /* folding proofs */ 12 | 13 | @keyframes show-proof { 14 | 0% { 15 | max-height: 1.2em; 16 | opacity: 1; 17 | } 18 | 99% { 19 | max-height: 1000em; 20 | } 21 | 100%{ 22 | } 23 | } 24 | 25 | @keyframes hide-proof { 26 | from { 27 | visibility: visible; 28 | max-height: 10em; 29 | opacity: 1; 30 | } 31 | to { 32 | max-height: 1.2em; 33 | } 34 | } 35 | 36 | .proof { 37 | cursor: pointer; 38 | } 39 | .proof * { 40 | cursor: pointer; 41 | } 42 | 43 | .proof { 44 | overflow: hidden; 45 | position: relative; 46 | transition: opacity 1s; 47 | display: inline-block; 48 | } 49 | 50 | .proof[show="false"] { 51 | max-height: 1.2em; 52 | visibility: visible; 53 | opacity: 0.3; 54 | } 55 | 56 | .proof[show="false"][animate] { 57 | animation-name: hide-proof; 58 | animation-duration: 0.25s; 59 | } 60 | 61 | .proof[show=true] { 62 | animation-name: show-proof; 63 | animation-duration: 10s; 64 | } 65 | 66 | .proof[show="false"]:before { 67 | position: absolute; 68 | visibility: visible; 69 | width: 100%; 70 | height: 100%; 71 | display: block; 72 | opacity: 0; 73 | content: "M"; 74 | } 75 | .proof[show="false"]:hover:before { 76 | content: ""; 77 | } 78 | 79 | .proof[show="false"] + br + br { 80 | display: none; 81 | } 82 | 83 | .proof[show="false"]:hover { 84 | visibility: visible; 85 | opacity: 0.5; 86 | } 87 | 88 | #toggle-proofs[proof-status="no-proofs"] { 89 | display: none; 90 | } 91 | 92 | #toggle-proofs[proof-status="some-hidden"]:before { 93 | content: "Show Proofs"; 94 | } 95 | 96 | #toggle-proofs[proof-status="all-shown"]:before { 97 | content: "Hide Proofs"; 98 | } 99 | 100 | 101 | /* page layout */ 102 | 103 | html, body { 104 | height: 100%; 105 | margin:0; 106 | padding:0; 107 | } 108 | 109 | @media only screen { /* no div with internal scrolling to allow printing of whole content */ 110 | body { 111 | display: flex; 112 | flex-direction: column 113 | } 114 | 115 | #content { 116 | flex: 1; 117 | overflow: auto; 118 | display: flex; 119 | flex-direction: column; 120 | } 121 | } 122 | 123 | #content:focus { 124 | outline: none; /* prevent glow in OS X */ 125 | } 126 | 127 | #main { 128 | display: block; 129 | padding: 16px; 130 | padding-top: 1em; 131 | padding-bottom: 2em; 132 | margin-left: auto; 133 | margin-right: auto; 134 | max-width: 60em; 135 | flex: 1 0 auto; 136 | } 137 | 138 | .libtitle { 139 | display: none; 140 | } 141 | 142 | /* header */ 143 | #header { 144 | width:100%; 145 | padding: 0; 146 | margin: 0; 147 | display: flex; 148 | align-items: center; 149 | background-color: rgb(21,57,105); 150 | color: white; 151 | font-weight: bold; 152 | overflow: hidden; 153 | } 154 | 155 | 156 | .button { 157 | cursor: pointer; 158 | } 159 | 160 | #header * { 161 | text-decoration: none; 162 | vertical-align: middle; 163 | margin-left: 15px; 164 | margin-right: 15px; 165 | } 166 | 167 | #header > .right, #header > .left { 168 | display: flex; 169 | flex: 1; 170 | align-items: center; 171 | } 172 | #header > .left { 173 | text-align: left; 174 | } 175 | #header > .right { 176 | flex-direction: row-reverse; 177 | } 178 | 179 | #header a, #header .button { 180 | color: white; 181 | box-sizing: border-box; 182 | } 183 | 184 | #header a { 185 | border-radius: 0; 186 | padding: 0.2em; 187 | } 188 | 189 | #header .button { 190 | background-color: rgb(63, 103, 156); 191 | border-radius: 1em; 192 | padding-left: 0.5em; 193 | padding-right: 0.5em; 194 | margin: 0.2em; 195 | } 196 | 197 | #header a:hover, #header .button:hover { 198 | background-color: rgb(181, 213, 255); 199 | color: black; 200 | } 201 | 202 | #header h1 { padding: 0; 203 | margin: 0;} 204 | 205 | /* footer */ 206 | #footer { 207 | text-align: center; 208 | opacity: 0.5; 209 | font-size: 75%; 210 | } 211 | 212 | /* hyperlinks */ 213 | 214 | @keyframes highlight { 215 | 50%{ 216 | background-color: black; 217 | } 218 | } 219 | 220 | :target * { 221 | animation-name: highlight; 222 | animation-duration: 1s; 223 | } 224 | 225 | a[name]:empty { 226 | float: right; 227 | } 228 | 229 | /* Proviola */ 230 | 231 | div.code { 232 | width: auto; 233 | float: none; 234 | } 235 | 236 | div.goal { 237 | position: fixed; 238 | left: 75%; 239 | width: 25%; 240 | top: 3em; 241 | } 242 | 243 | div.doc { 244 | clear: both; 245 | } 246 | 247 | span.command:hover { 248 | background-color: inherit; 249 | } 250 | -------------------------------------------------------------------------------- /extra/resources/coqdocjs.js: -------------------------------------------------------------------------------- 1 | var coqdocjs = coqdocjs || {}; 2 | (function(){ 3 | 4 | function replace(s){ 5 | var m; 6 | if (m = s.match(/^(.+)'/)) { 7 | return replace(m[1])+"'"; 8 | } else if (m = s.match(/^([A-Za-z]+)_?(\d+)$/)) { 9 | return replace(m[1])+m[2].replace(/\d/g, function(d){ 10 | if (coqdocjs.subscr.hasOwnProperty(d)) { 11 | return coqdocjs.subscr[d]; 12 | } else { 13 | return d; 14 | } 15 | }); 16 | } else if (coqdocjs.repl.hasOwnProperty(s)){ 17 | return coqdocjs.repl[s] 18 | } else { 19 | return s; 20 | } 21 | } 22 | 23 | function toArray(nl){ 24 | return Array.prototype.slice.call(nl); 25 | } 26 | 27 | function replInTextNodes() { 28 | coqdocjs.replInText.forEach(function(toReplace){ 29 | toArray(document.getElementsByClassName("code")).concat(toArray(document.getElementsByClassName("inlinecode"))).forEach(function(elem){ 30 | toArray(elem.childNodes).forEach(function(node){ 31 | if (node.nodeType != Node.TEXT_NODE) return; 32 | var fragments = node.textContent.split(toReplace); 33 | node.textContent = fragments[fragments.length-1]; 34 | for (var k = 0; k < fragments.length - 1; ++k) { 35 | node.parentNode.insertBefore(document.createTextNode(fragments[k]),node); 36 | var replacement = document.createElement("span"); 37 | replacement.appendChild(document.createTextNode(toReplace)); 38 | replacement.setAttribute("class", "id"); 39 | replacement.setAttribute("type", "keyword"); 40 | node.parentNode.insertBefore(replacement, node); 41 | } 42 | }); 43 | }); 44 | }); 45 | } 46 | 47 | function replNodes() { 48 | toArray(document.getElementsByClassName("id")).forEach(function(node){ 49 | if (["var", "variable", "keyword", "notation", "definition", "inductive"].indexOf(node.getAttribute("type"))>=0){ 50 | var text = node.textContent; 51 | var replText = replace(text); 52 | if(text != replText) { 53 | node.setAttribute("repl", replText); 54 | node.setAttribute("title", text); 55 | var hidden = document.createElement("span"); 56 | hidden.setAttribute("class", "hidden"); 57 | while (node.firstChild) { 58 | hidden.appendChild(node.firstChild); 59 | } 60 | node.appendChild(hidden); 61 | } 62 | } 63 | }); 64 | } 65 | 66 | function isVernacStart(l, t){ 67 | t = t.trim(); 68 | for(var s of l){ 69 | if (t == s || t.startsWith(s+" ") || t.startsWith(s+".")){ 70 | return true; 71 | } 72 | } 73 | return false; 74 | } 75 | 76 | function isProofStart(n){ 77 | return isVernacStart(["Proof"], n.textContent) || 78 | (isVernacStart(["Next"], n.textContent) && isVernacStart(["Obligation"], n.nextSibling.nextSibling.textContent)); 79 | } 80 | 81 | function isProofEnd(s){ 82 | return isVernacStart(["Qed", "Admitted", "Defined", "Abort"], s); 83 | } 84 | 85 | function proofStatus(){ 86 | var proofs = toArray(document.getElementsByClassName("proof")); 87 | if(proofs.length) { 88 | for(var proof of proofs) { 89 | if (proof.getAttribute("show") === "false") { 90 | return "some-hidden"; 91 | } 92 | } 93 | return "all-shown"; 94 | } 95 | else { 96 | return "no-proofs"; 97 | } 98 | } 99 | 100 | function updateView(){ 101 | document.getElementById("toggle-proofs").setAttribute("proof-status", proofStatus()); 102 | } 103 | 104 | function foldProofs() { 105 | var hasCommands = true; 106 | var nodes = document.getElementsByClassName("command"); 107 | if(nodes.length == 0) { 108 | hasCommands = false; 109 | console.log("no command tags found") 110 | nodes = document.getElementsByClassName("id"); 111 | } 112 | toArray(nodes).forEach(function(node){ 113 | if(isProofStart(node)) { 114 | var proof = document.createElement("span"); 115 | proof.setAttribute("class", "proof"); 116 | 117 | node.parentNode.insertBefore(proof, node); 118 | if(proof.previousSibling.nodeType === Node.TEXT_NODE) 119 | proof.appendChild(proof.previousSibling); 120 | while(node && !isProofEnd(node.textContent)) { 121 | proof.appendChild(node); 122 | node = proof.nextSibling; 123 | } 124 | if (proof.nextSibling) proof.appendChild(proof.nextSibling); // the Qed 125 | if (!hasCommands && proof.nextSibling) proof.appendChild(proof.nextSibling); // the dot after the Qed 126 | 127 | proof.addEventListener("click", function(proof){return function(e){ 128 | if (e.target.parentNode.tagName.toLowerCase() === "a") 129 | return; 130 | proof.setAttribute("show", proof.getAttribute("show") === "true" ? "false" : "true"); 131 | proof.setAttribute("animate", ""); 132 | updateView(); 133 | };}(proof)); 134 | proof.setAttribute("show", "false"); 135 | } 136 | }); 137 | } 138 | 139 | function toggleProofs(){ 140 | var someProofsHidden = proofStatus() === "some-hidden"; 141 | toArray(document.getElementsByClassName("proof")).forEach(function(proof){ 142 | proof.setAttribute("show", someProofsHidden); 143 | proof.setAttribute("animate", ""); 144 | }); 145 | updateView(); 146 | } 147 | 148 | function repairDom(){ 149 | // pull whitespace out of command 150 | toArray(document.getElementsByClassName("command")).forEach(function(node){ 151 | while(node.firstChild && node.firstChild.textContent.trim() == ""){ 152 | console.log("try move"); 153 | node.parentNode.insertBefore(node.firstChild, node); 154 | } 155 | }); 156 | toArray(document.getElementsByClassName("id")).forEach(function(node){ 157 | node.setAttribute("type", node.getAttribute("title")); 158 | }); 159 | toArray(document.getElementsByClassName("idref")).forEach(function(ref){ 160 | toArray(ref.childNodes).forEach(function(child){ 161 | if (["var", "variable"].indexOf(child.getAttribute("type")) > -1) 162 | ref.removeAttribute("href"); 163 | }); 164 | }); 165 | 166 | } 167 | 168 | function fixTitle(){ 169 | var url = "/" + window.location.pathname; 170 | var basename = url.substring(url.lastIndexOf('/')+1, url.lastIndexOf('.')); 171 | if (basename === "toc") {document.title = "Table of Contents";} 172 | else if (basename === "indexpage") {document.title = "Index";} 173 | else {document.title = basename;} 174 | } 175 | 176 | function postprocess(){ 177 | repairDom(); 178 | foldProofs(); 179 | document.getElementById("toggle-proofs").addEventListener("click", toggleProofs); 180 | updateView(); 181 | } 182 | 183 | fixTitle(); 184 | document.addEventListener('DOMContentLoaded', postprocess); 185 | 186 | coqdocjs.toggleProofs = toggleProofs; 187 | })(); 188 | -------------------------------------------------------------------------------- /theories/ClosedModality.v: -------------------------------------------------------------------------------- 1 | (** EXPERIMENTAL. This file is a mess, don't look at it! LOL *) 2 | 3 | From Domains Require Import Preamble Preorder Poset Dcpo DcpoProduct. 4 | 5 | Axiom T : Dcpo.type → Prop → Dcpo.type. 6 | 7 | (** It is a result of Jung that DCPO is cocomplete, constructively. Hence the following exists. *) 8 | Section Modality. 9 | Context {A : Dcpo.type} {ϕ : Prop}. 10 | Axiom seal : A → T A ϕ. 11 | Axiom seal_cont : is_continuous seal. 12 | Axiom pt : ϕ → T A ϕ. 13 | Axiom gl : ∀ u : ϕ, ∀ x : T A ϕ, x = pt u. 14 | 15 | Context {C : Dcpo.type}. 16 | 17 | Axiom unseal : ∀ (f : A → C) (g : ϕ → C), (∀ x y, f x = g y) → is_continuous f → T A ϕ → C. 18 | 19 | Context {f : A → C} {g : ϕ → C} {coh : ∀ x y, f x = g y} {fcont : is_continuous f}. 20 | Axiom unseal_cont : is_continuous (unseal f g coh fcont). 21 | Axiom unseal_seal : ∀ a, unseal f g coh fcont (seal a) = f a. 22 | Axiom unseal_pt : ∀ z, unseal f g coh fcont (pt z) = g z. 23 | Axiom unseal_uniq : ∀ h, is_continuous h → (∀ x, h (seal x) = f x) → (∀ x, h (pt x) = g x) → ∀ x, h x = unseal f g coh fcont x. 24 | End Modality. 25 | 26 | Context (A : Dcppo.type) (ϕ : Prop). 27 | 28 | -------------------------------------------------------------------------------- /theories/Dcpo.v: -------------------------------------------------------------------------------- 1 | From Domains Require Import Preamble Preorder Poset. 2 | 3 | HB.mixin Record DcpoOfPoset D of Poset D := 4 | {ltHasDirLubs : ∀ (A : Family D), is_directed A → ∃ x, is_lub A x}. 5 | 6 | HB.structure Definition Dcpo := {D of DcpoOfPoset D & Poset D}. 7 | HB.structure Definition Dcppo := {D of Dcpo D & PointedPoset D}. 8 | 9 | Section DLub. 10 | Context {D : Dcpo.type} (A : Family D) (dir : is_directed A). 11 | 12 | Definition dlub_bundled : {x : D | is_lub A x}. 13 | Proof. 14 | apply: constructive_definite_description. 15 | case: (ltHasDirLubs A dir) => //= x xlub. 16 | exists x; split=>// y ylub. 17 | by apply: (lub_unique A). 18 | Qed. 19 | 20 | Definition dlub : D. 21 | Proof. by case: dlub_bundled. Defined. 22 | 23 | Lemma dlub_is_lub : is_lub A dlub. 24 | Proof. by rewrite /dlub; case: dlub_bundled. Qed. 25 | 26 | Lemma dlub_is_ub : is_ub A dlub. 27 | Proof. by rewrite /dlub; case: dlub_bundled => ? []. Qed. 28 | 29 | Lemma dlub_least : ∀ z : D, is_ub A z → dlub ≤ z. 30 | Proof. by rewrite /dlub; case: dlub_bundled => ? []. Qed. 31 | 32 | Opaque dlub. 33 | End DLub. 34 | 35 | 36 | #[global] 37 | Hint Extern 0 => apply: dlub_is_lub : core. 38 | 39 | 40 | 41 | Definition preserves_dlub {D : Dcpo.type} {E : Poset.type} (f : D → E) := 42 | ∀ (A : Family D) (h : is_directed A), 43 | is_lub (push_fam f A) (f (dlub A h)). 44 | 45 | Definition leq_family {D : Dcpo.type} (x y : D) : Family D. 46 | Proof. by exists bool; case; [exact: x | exact: y]. Defined. 47 | 48 | Lemma leq_family_directed {D : Dcpo.type} : ∀ x y : D, x ≤ y → is_directed (leq_family x y). 49 | Proof. 50 | move=> *; split; first by exists true. 51 | by do 2!case; exists false. 52 | Qed. 53 | 54 | Lemma leq_to_lub {D : Dcpo.type} : ∀ x y : D, ∀ p : x ≤ y, y = dlub (leq_family x y) (leq_family_directed x y p). 55 | Proof. 56 | move=> x y xy. 57 | apply/lub_unique/dlub_is_lub; split; first by case. 58 | by move=> z /(_ false). 59 | Qed. 60 | 61 | Lemma preserves_dlub_cont {D E : Dcpo.type} {f : D → E} : preserves_dlub f → is_continuous f. 62 | Proof. 63 | rewrite /preserves_dlub. 64 | move=> fcont A dirA x xlub. 65 | replace x with (dlub A dirA). 66 | - apply: fcont. 67 | - apply: lub_unique; auto. 68 | Qed. 69 | 70 | Lemma cont_preserves_dlub {D : Dcpo.type} {E : Poset.type} {f : D → E} : is_continuous f → preserves_dlub f. 71 | Proof. by move=> fcont ? ?; apply: fcont. Qed. 72 | 73 | 74 | Lemma cont_mono {D : Dcpo.type} {E : Poset.type} (f : D → E) : is_continuous f → is_monotone f. 75 | Proof. 76 | move=> /cont_preserves_dlub fdlub x y xy. 77 | rewrite (leq_to_lub _ _ xy). 78 | case: (fdlub (leq_family x y) (leq_family_directed x y xy))=> + _. 79 | by move/(_ true). 80 | Qed. 81 | -------------------------------------------------------------------------------- /theories/DcpoExponential.v: -------------------------------------------------------------------------------- 1 | From Domains Require Import Preamble Preorder Poset Dcpo. 2 | 3 | Section Map. 4 | Context (D E : Dcpo.type). 5 | 6 | Definition map := {f : D → E | is_continuous f}. 7 | Definition ap (f : map) : D → E := proj1_sig f. 8 | Definition ap_cont (f : map) : is_continuous (ap f) := proj2_sig f. 9 | 10 | Lemma map_ext : ∀ f g, ap f = ap g → f = g. 11 | Proof. by rewrite /map => f g fg; apply: eq_sig. Qed. 12 | 13 | Definition map_lt (f g : map) : Prop := 14 | ∀ x, ap f x ≤ ap g x. 15 | 16 | Lemma map_ltR : ∀ f, map_lt f f. 17 | Proof. by move=>?. Qed. 18 | 19 | Lemma map_ltT : ∀ f g h, map_lt f g → map_lt g h → map_lt f h. 20 | Proof. 21 | move=> f g h fg gh x. 22 | by apply: ltT; [apply: fg | apply: gh]. 23 | Qed. 24 | 25 | HB.instance Definition map_preorder_axioms := PreorderOfType.Build map map_lt map_ltR map_ltT. 26 | 27 | Lemma map_ltE : ∀ f g : map, f ≤ g → g ≤ f → f = g. 28 | Proof. 29 | move=> f g fg gf. 30 | apply/map_ext/funext=>x. 31 | by apply: ltE; [apply: fg | apply: gf]. 32 | Qed. 33 | 34 | HB.instance Definition map_poset_axioms := PosetOfPreorder.Build map map_ltE. 35 | 36 | Section Lub. 37 | 38 | Context (A : Family map). 39 | 40 | Lemma push_ap_directed : ∀ (x : D), is_directed A → is_directed (push_fam (λ f, ap f x) A). 41 | Proof. 42 | move=> x dir; split; first by apply: nonempty dir. 43 | move=> //= i j. 44 | case: (predirected A dir i j) => k [ij jk]. 45 | by exists k; split; [apply: ij | apply: jk]. 46 | Qed. 47 | 48 | Section Map. 49 | Context (dir : is_directed A). 50 | 51 | Definition dlub_fun : D → E := 52 | λ x, 53 | dlub (push_fam (λ f, ap f x) A) (push_ap_directed x dir). 54 | 55 | Lemma dlub_fun_continuous : is_continuous dlub_fun. 56 | Proof. 57 | apply: preserves_dlub_cont. 58 | move=> F dirF; split. 59 | - move=> //= i. 60 | apply: above_lub; first by apply: dlub_is_lub. 61 | move=> //= z. 62 | apply: ltT. 63 | + by apply: cont_mono; [apply: ap_cont | apply: dlub_is_ub]. 64 | + by apply: (dlub_is_ub (push_fam _ A)). 65 | - move=> z //= H. 66 | apply: dlub_least => //= x. 67 | apply: lub_univ; first by [apply: ap_cont; eauto]. 68 | move=> //= y. 69 | apply: ltT'; first by apply: H. 70 | by apply: (dlub_is_ub (push_fam _ A)). 71 | Qed. 72 | 73 | Lemma map_ltHasDLubs : ∃ f, is_lub A f. 74 | Proof. 75 | unshelve esplit. 76 | - by exists dlub_fun; apply: dlub_fun_continuous. 77 | - split=>/=. 78 | + move=> i; move=> ?. 79 | by apply: (dlub_is_ub (push_fam _ _)). 80 | + move=> f Hf; move=> ?. 81 | apply: dlub_least => ?. 82 | by apply: Hf. 83 | Qed. 84 | End Map. 85 | End Lub. 86 | 87 | HB.instance Definition map_dcpo_axioms := DcpoOfPoset.Build map map_ltHasDLubs. 88 | 89 | End Map. 90 | 91 | Arguments ap [D] [E]. 92 | -------------------------------------------------------------------------------- /theories/DcpoProduct.v: -------------------------------------------------------------------------------- 1 | From Domains Require Import Preamble Preorder Poset Dcpo. 2 | 3 | Section Product. 4 | Context (D E : Dcpo.type). 5 | 6 | Definition prod_lt (p q : prod D E) : Prop := 7 | p.1 ≤ q.1 ∧ p.2 ≤ q.2. 8 | 9 | Lemma prod_ltR : ∀ p, prod_lt p p. 10 | Proof. by []. Qed. 11 | 12 | Lemma prod_ltT : ∀ p q r, prod_lt p q → prod_lt q r → prod_lt p r. 13 | Proof. 14 | by move=> [x1 y1][x2 y2][x3 y3][/= ? ?] [/= Hx Hy]; split=>/=; 15 | [apply/ltT/Hx | apply/ltT/Hy]. 16 | Qed. 17 | 18 | HB.instance Definition prod_preorder_axioms := PreorderOfType.Build (prod D E) prod_lt prod_ltR prod_ltT. 19 | 20 | Lemma prod_ltE : ∀ p q, prod_lt p q → prod_lt q p → p = q. 21 | Proof. 22 | move=> [? ?] [? ?] //= [/= h1 h2] [/= h'1 h'2]. 23 | by rewrite (ltE _ _ h1 h'1) (ltE _ _ h2 h'2). 24 | Qed. 25 | 26 | HB.instance Definition prod_poset_axioms := PosetOfPreorder.Build (prod D E) prod_ltE. 27 | 28 | Section DLub. 29 | Context (A : Family (prod D E)) (dirA : is_directed A). 30 | 31 | Definition prod_dlub : prod D E. 32 | Proof. 33 | split. 34 | - unshelve apply: dlub. 35 | + by apply: push_fam A; apply: fst. 36 | + split. 37 | * by case (nonempty A dirA) => i _; exists i. 38 | * by move=> i j; case (predirected A dirA i j)=> k [[p1 p2] [q1 q2]]; exists k. 39 | - unshelve apply: dlub. 40 | + by apply: push_fam A; apply: snd. 41 | + split. 42 | * by case (nonempty A dirA) => i _; exists i. 43 | * by move=> i j; case (predirected A dirA i j)=> k [[p1 p2] [q1 q2]]; exists k. 44 | Defined. 45 | 46 | Lemma prod_dlub_is_lub : is_lub A prod_dlub. 47 | Proof. 48 | split. 49 | - move=> i; split; 50 | by apply: ltT'; [apply dlub_is_lub | apply: ltR]. 51 | - move=> //= [p1 p2] h; split=>/=; 52 | by apply: (lub_univ _)=>// u; case: (h u). 53 | Qed. 54 | 55 | Lemma prod_ltHasDLubs : ∃ x, is_lub A x. 56 | Proof. by exists prod_dlub; apply: prod_dlub_is_lub. Qed. 57 | End DLub. 58 | 59 | HB.instance Definition prod_dcpo_axioms := DcpoOfPoset.Build (prod D E) prod_ltHasDLubs. 60 | 61 | Lemma fst_continous : is_continuous fst. 62 | Proof. 63 | move=>/= A dirA x xlub; split. 64 | - move=>/= i. 65 | suff: A i ≤ x by case. 66 | by apply: lub_is_ub. 67 | - move=>/= y yub. 68 | case: (lub_univ A x xlub (y,x.2))=>//. 69 | move=>/= i; split=>/=. 70 | + by apply: yub. 71 | + suff: A i ≤ x by case. 72 | by apply: lub_is_ub. 73 | Qed. 74 | 75 | Lemma snd_continous : is_continuous snd. 76 | Proof. 77 | move=>/= A dirA x xlub; split. 78 | - move=>/= i. 79 | suff: A i ≤ x by case. 80 | by apply: lub_is_ub. 81 | - move=>/= y yub. 82 | case: (lub_univ A x xlub (x.1,y))=>//. 83 | move=>/= i; split=>/=. 84 | * suff: A i ≤ x by case. 85 | by apply: lub_is_ub. 86 | * by apply: yub. 87 | Qed. 88 | 89 | Lemma pair_left_continous : ∀ x, is_continuous (pair x). 90 | Proof. 91 | move=> x; split. 92 | - move=>/= i; split=>//=. 93 | by apply: lub_is_ub. 94 | - move=>/= z zub. 95 | split=>/=. 96 | + case: (nonempty _ h) => i _. 97 | by case: (zub i). 98 | + apply: lub_univ; first by eauto. 99 | move=> i. 100 | suff: (z.1, A i) ≤ z by case. 101 | by case: (zub i). 102 | Qed. 103 | 104 | Lemma pair_right_continous : ∀ x, is_continuous (fun y => pair y x). 105 | Proof. 106 | move=> x; split. 107 | - move=>/= i; split=>//=. 108 | by apply: lub_is_ub. 109 | - move=>/= z zub. 110 | split=>/=. 111 | + apply: lub_univ; first by eauto. 112 | move=> i. 113 | suff: (A i, z.2) ≤ z by case. 114 | by case: (zub i). 115 | + case: (nonempty _ h) => i _. 116 | by case: (zub i). 117 | Qed. 118 | End Product. 119 | -------------------------------------------------------------------------------- /theories/ILift.v: -------------------------------------------------------------------------------- 1 | Require Import Preamble Preorder Poset Dcpo UNat. 2 | 3 | Set Primitive Projections. 4 | 5 | (** An "intensional" lift operation that can track termination in a (potentially infinite) number of steps. *) 6 | Record IL (A : Type) := 7 | {beh : UNat; 8 | run :> UNat_defd beh → A}. 9 | 10 | Arguments beh [A] _. 11 | Arguments run [A] _. 12 | 13 | Lemma IL_ext : ∀ A (m n : IL A) (p : beh m ≤ beh n) (q : beh n ≤ beh m), (∀ x y, m x = n y) → m = n. 14 | Proof. 15 | move=> A [bm rm] [bn rn] //= p q h. 16 | have Q: bm = bn by apply: ltE. 17 | dependent destruction Q. 18 | rewrite (_ : rm = rn) //. 19 | apply: funext=>?. 20 | by apply: h. 21 | Qed. 22 | 23 | Section Lift. 24 | Context (A : Type). 25 | 26 | Definition IL_lt (m n : IL A) : Prop := 27 | beh m ≤ beh n ∧ ∀ u v, m u = n v. 28 | 29 | Lemma IL_ltR : ∀ m, IL_lt m m. 30 | Proof. 31 | move=> m; split=>// u v. 32 | by rewrite (_ : u = v). 33 | Qed. 34 | 35 | Lemma IL_ltT : ∀ m n o, IL_lt m n → IL_lt n o → IL_lt m o. 36 | Proof. 37 | move=> m n o [mn0 mn1] [no0 n1]. 38 | split. 39 | - by apply: ltT mn0 no0. 40 | - move=> u v. 41 | rewrite mn1 //. 42 | case: u=> k ?. 43 | by exists k; apply: mn0. 44 | Qed. 45 | 46 | HB.instance Definition IL_preorder_axioms := PreorderOfType.Build (IL A) IL_lt IL_ltR IL_ltT. 47 | 48 | Lemma IL_ltE (m n : IL A) : m ≤ n → n ≤ m → m = n. 49 | Proof. by move=> [mn0 mn1] [nm0 nm1]; apply: IL_ext. Qed. 50 | 51 | HB.instance Definition IL_poset_axioms := PosetOfPreorder.Build (IL A) IL_ltE. 52 | 53 | 54 | Section Lub. 55 | Context (F : Family (IL A)) (dirF : is_directed F). 56 | 57 | Lemma directed_defd_fam : is_directed (push_fam (λ x : IL A, beh x) F). 58 | Proof. 59 | split. 60 | - by case: (nonempty _ dirF). 61 | - move=> //= i j. 62 | case: (predirected _ dirF i j)=> k [[ik0 ik1] [jk0 jk1]]. 63 | by exists k; split; move=> ?; [apply: ik0 | apply: jk0]. 64 | Qed. 65 | 66 | Definition candidate_dlub : UNat_defd (dlub (push_fam (λ x : IL A, beh x) F) directed_defd_fam) → A. 67 | Proof. 68 | move=> Q; apply: (iota (λ a, ∀ i x, F i x = a)); move: Q. 69 | case=> x. 70 | apply: UNat_lub_elim=>//= i y u. 71 | unshelve esplit. 72 | - apply: F. 73 | by exists y; apply: u. 74 | - split=>// j. 75 | case: (predirected _ dirF i j)=> k [[ik0 ik1] [jk0 jk1]] [z w]. 76 | rewrite jk1 //. 77 | by exists z; apply: jk0. 78 | Defined. 79 | 80 | Definition candidate_dlub_compute : ∀ Q i x, F i x = candidate_dlub Q. 81 | Proof. by move=> Q i x; apply: (iota_prop (λ a, ∀ i x, F i x = a)). Qed. 82 | 83 | Opaque candidate_dlub. 84 | 85 | Definition IL_dlub : IL A. 86 | Proof. 87 | unshelve esplit. 88 | - by apply: dlub directed_defd_fam. 89 | - by apply: candidate_dlub. 90 | Defined. 91 | 92 | Lemma IL_dlub_is_lub : is_lub F IL_dlub. 93 | Proof. 94 | split. 95 | - move=> i; split. 96 | + move=> x hx. 97 | apply: UNat_lub_intro=>//. 98 | by exact: hx. 99 | + by move=> u ?; rewrite /IL_dlub /= -(candidate_dlub_compute _ i u). 100 | - move=> m H; split. 101 | + move=> x. 102 | apply: UNat_lub_elim=>//i u. 103 | case: (H i)=> Hi0 Hi1. 104 | by apply: Hi0. 105 | + rewrite /IL_dlub //=. 106 | case; apply: UNat_lub_elim_dep=>//. 107 | move=> i k hk w [l hl]. 108 | rewrite -(candidate_dlub_compute _ i (ex_intro _ _ hk)). 109 | case: (H i)=> Hi0 Hi1. 110 | by apply: Hi1. 111 | Qed. 112 | 113 | Lemma IL_ltHasDLub : ∃ m : IL A, is_lub F m. 114 | Proof. by exists IL_dlub; apply: IL_dlub_is_lub. Qed. 115 | 116 | Lemma IL_dlub_rw : ∀ m : IL A, is_lub F m → m = IL_dlub. 117 | Proof. by move=> m ?; apply/lub_unique/IL_dlub_is_lub. Qed. 118 | End Lub. 119 | 120 | 121 | Definition IL_bot : IL A. 122 | Proof. by exists ⊥; apply: UNat_bot_elim. Defined. 123 | 124 | Lemma IL_bot_is_bot : is_bottom IL_bot. 125 | Proof. by move=> ?; split=>//; apply: UNat_bot_elim. Qed. 126 | 127 | Lemma IL_has_bot : ∃ x : IL A, is_bottom x. 128 | Proof. by exists IL_bot; apply: IL_bot_is_bot. Qed. 129 | 130 | HB.instance Definition IL_dcpo_axioms := DcpoOfPoset.Build (IL A) IL_ltHasDLub. 131 | HB.instance Definition IL_pointed_poset_axioms := PointedPosetOfPoset.Build (IL A) IL_has_bot. 132 | End Lift. 133 | 134 | 135 | Section Functor. 136 | Context {A B : Type} (f : A → B). 137 | 138 | Definition fmap : IL A → IL B. 139 | Proof. by move=> x; exists (beh x) => z; apply/f/x. Defined. 140 | 141 | Lemma fmap_cont : is_continuous fmap. 142 | Proof. 143 | move=>/= F dirF x xlub; split. 144 | - move=> /= i. 145 | case: (lub_is_ub _ _ xlub i)=> H0 H1. 146 | split=>//=??. 147 | by rewrite H1. 148 | - move=> /= y yub. 149 | rewrite (IL_dlub_rw _ _ _ x xlub). 150 | split. 151 | + move=> u. 152 | apply: UNat_lub_elim=>//= i k hk. 153 | by case: (yub i)=>X ?; apply: X. 154 | + case; apply: UNat_lub_elim_dep=>//= i ? h ? ?. 155 | case: (yub i) => _ /= <-. 156 | * move=> ?. 157 | rewrite candidate_dlub_compute. 158 | ** by move=> ?; congr (f (candidate_dlub _ _ _ _)). 159 | ** by esplit; apply: UNat_lub_intro; [apply: dlub_is_lub | exact: h]. 160 | * by esplit; exact: h. 161 | Qed. 162 | End Functor. 163 | 164 | Section Unit. 165 | 166 | Context {A : Type}. 167 | 168 | Definition unit : A → IL A. 169 | Proof. by move=> a; exists ⊤=> ?; exact: a. Defined. 170 | 171 | End Unit. 172 | 173 | Section Monad. 174 | 175 | Definition bind {A B} : (A → IL B) → IL A → IL B. 176 | Proof. 177 | move=>f a. 178 | unshelve esplit. 179 | - apply: (UNat_dsum (beh a))=> k hk. 180 | apply/beh/f/a. 181 | by exists k. 182 | - move=>/= h. 183 | apply: (iota (λ b : B, ∀ u v, f (a u) v = b)). 184 | case: h=> u [v [w [hv [hw]]]] [vu wu]. 185 | pose a' := a (ex_intro _ _ hv). 186 | pose b' := f a' (ex_intro _ _ hw). 187 | exists b'; split. 188 | + move=> [u' hu'] [v' hv']. 189 | rewrite /b' /a'. 190 | move: (ex_intro _ v' hv'). 191 | move: (ex_intro _ w hw). 192 | move: (ex_intro _ v hv). 193 | move: (ex_intro _ u' hu'). 194 | move=> h h'. 195 | rewrite (_ : h' = h) // => {h'} e e'. 196 | by rewrite (_ : e' = e). 197 | + move=> z hz. 198 | rewrite /b' /a'. 199 | by rewrite -(hz (ex_intro _ _ hv) (ex_intro _ _ hw)). 200 | Defined. 201 | 202 | End Monad. 203 | -------------------------------------------------------------------------------- /theories/Kleene.v: -------------------------------------------------------------------------------- 1 | From Coq Require Import ssrbool. 2 | From mathcomp Require Import ssrnat. 3 | From Domains Require Import Preamble Preorder Poset Dcpo DcpoExponential. 4 | 5 | Set Bullet Behavior "Strict Subproofs". 6 | 7 | (* Kleene fixed-point theorem *) 8 | 9 | Fixpoint pow {D : PointedPoset.type} (f : D -> D) n := 10 | if n is n.+1 then f (pow f n) else bottom. 11 | 12 | Definition pow_family {D : PointedPoset.type} (f : D -> D) : Family D. 13 | Proof. by exists nat; exact: pow f. Defined. 14 | 15 | Lemma pow_chain {D : PointedPoset.type} (f : D -> D) n m : 16 | is_monotone f -> 17 | pow f n ≤ pow f m ∨ pow f m ≤ pow f n. 18 | Proof. 19 | move=>Hm; case: (leqP n m)=>H. 20 | - left; elim: n m H=>[|? IH] m H //=. 21 | by case: m H=>// ?? /=; apply/Hm/IH. 22 | - right; elim: m n H=>[|? IH] n H //=. 23 | by case: n H=>// ?? /=; apply/Hm/IH. 24 | Qed. 25 | 26 | Lemma pow_chain_directed {D : PointedPoset.type} (f : D -> D) : 27 | is_monotone f -> 28 | is_directed (pow_family f). 29 | Proof. 30 | move=>H; split=>/=. 31 | - by exists 0. 32 | - move=>/= n m. 33 | by case: (pow_chain f n m H)=>?; [exists m | exists n]. 34 | Qed. 35 | 36 | Definition is_least_fixpoint {D : Poset.type} (f : D -> D) (x : D) := 37 | f x = x ∧ ∀ y, f y = y -> x ≤ y. 38 | 39 | Definition fix_ {D : Dcppo.type} (f : map D D) : D. 40 | Proof. 41 | apply/(dlub (pow_family (sval f)))/pow_chain_directed/cont_mono. 42 | by case: f. 43 | Defined. 44 | 45 | Lemma fix_is_lub {D : Dcppo.type} (f : map D D) : is_lub (pow_family (sval f)) (fix_ f). 46 | Proof. by apply: dlub_is_lub. Qed. 47 | 48 | Lemma fix_is_lfp {D : Dcppo.type} (f : map D D) : is_least_fixpoint (sval f) (fix_ f). 49 | split. 50 | - case: (svalP f (pow_family (sval f)) _ (fix_ f))=>//. 51 | + by apply/pow_chain_directed/cont_mono/(svalP f). 52 | + move=> H1 H2. 53 | apply: (lub_unique (pow_family _)); last by apply: dlub_is_lub. 54 | split=>/=. 55 | * by case=>//=; apply: H1. 56 | * move=>? H3; apply: H2; move=>/=i. 57 | by exact: (H3 (S i)). 58 | - move=>? H1; apply: dlub_least=> x /=. 59 | elim: x=>//=. 60 | move=>??; rewrite -H1. 61 | apply: cont_mono=>//. 62 | by apply: svalP f. 63 | Qed. 64 | 65 | Opaque fix_. 66 | 67 | Lemma fix_is_fp {D : Dcppo.type} (f : map D D) : fix_ f = sval f (fix_ f). 68 | Proof. by case: (fix_is_lfp f)=> ->. Qed. 69 | 70 | 71 | Theorem kleene_lfp {D : Dcppo.type} (f : map D D) : 72 | ∃ x, is_lub (pow_family (ap f)) x ∧ is_least_fixpoint (ap f) x. 73 | Proof. 74 | exists (fix_ f); split. 75 | - apply: fix_is_lub. 76 | - apply: fix_is_lfp. 77 | Qed. 78 | 79 | 80 | Lemma map_pow_monotone {D : Dcppo.type} n : 81 | is_monotone (λ f : map D D, pow (ap f) n). 82 | Proof. 83 | elim: n=>[|n IH] //=. 84 | move=>/= ?? l. 85 | apply: ltT; first by apply: l. 86 | by apply: cont_mono; [apply: ap_cont | apply: IH]. 87 | Qed. 88 | 89 | Lemma map_pow_family_directed {D : Dcppo.type} {A : Family (map D D)} 90 | (H : is_directed A) (n : nat): 91 | is_directed (push_fam (λ f : map D D, pow (ap f) n) A). 92 | Proof. 93 | split; first by exact: (nonempty _ H). 94 | move=>i j; case: (predirected _ H i j)=>/= x [??]. 95 | by exists x; split; apply: map_pow_monotone. 96 | Qed. 97 | 98 | 99 | 100 | Definition closed_under_dlub {D : Dcpo.type} (S : D → Prop) := 101 | ∀ (A : Family D), is_directed A → (∀ x, S (A x)) → ∀ x, is_lub A x → S x. 102 | 103 | Definition admissible {D : Dcppo.type} (S : D → Prop) := 104 | S ⊥ ∧ closed_under_dlub S. 105 | 106 | Lemma fp_induction {D : Dcppo.type} (S : D → Prop) (f : map D D) : 107 | admissible S 108 | → (∀ d, S d → S (sval f d)) 109 | → S (fix_ f). 110 | Proof. 111 | move=> [botS dlubS] ih. 112 | apply: dlubS=>//. 113 | - apply/pow_chain_directed/cont_mono/(svalP f). 114 | - by elim=>//=??; apply: ih. 115 | Qed. 116 | -------------------------------------------------------------------------------- /theories/Lift.v: -------------------------------------------------------------------------------- 1 | Require Import Preamble Preorder Poset Dcpo Sierpinski. 2 | 3 | Set Primitive Projections. 4 | 5 | 6 | Arguments proj1_sig {A P}. 7 | Notation sval := proj1_sig. 8 | 9 | 10 | (* Using the partial map classifier, via de Jong and Escardo. *) 11 | Record L (A : Type) := 12 | {defd : Σ; 13 | run :> defd → A}. 14 | 15 | Arguments defd [A] _. 16 | Arguments run [A] _. 17 | 18 | Lemma L_ext : ∀ A (m n : L A) (p : defd m ≤ defd n) (q : defd n ≤ defd m), (∀ x, m x = n (p x)) → m = n. 19 | Proof. 20 | move=> A [dm rm] [dn rn] //= p q h. 21 | have Q: dm = dn by apply: propext. 22 | dependent destruction Q. 23 | rewrite (_ : rm = rn) //. 24 | apply: funext => z. 25 | by rewrite (h z) (_ : p z = z). 26 | Qed. 27 | 28 | Section Lift. 29 | Context (A : Dcpo.type). 30 | 31 | Definition L_lt (m n : L A) : Prop := 32 | ∀ z : defd m, ∃ z' : defd n, m z ≤ n z'. 33 | 34 | Lemma L_ltR : ∀ m, L_lt m m. 35 | Proof. 36 | move=> m zm. 37 | by exists zm. 38 | Qed. 39 | 40 | Lemma L_ltT : ∀ m n o, L_lt m n → L_lt n o → L_lt m o. 41 | Proof. 42 | move=> m n o mn no=> zm. 43 | case: (mn zm)=> zn mn'. 44 | case: (no zn)=> zo no'. 45 | exists zo. 46 | apply: ltT. 47 | - by apply: mn'. 48 | - by []. 49 | Qed. 50 | 51 | HB.instance Definition L_preorder_axioms := PreorderOfType.Build (L A) L_lt L_ltR L_ltT. 52 | 53 | Lemma L_ltE (m n : L A) : m ≤ n → n ≤ m → m = n. 54 | Proof. 55 | move=> mn nm. 56 | apply: L_ext. 57 | - move=> zm. 58 | by case: (mn zm). 59 | - move=> zn. 60 | by case: (nm zn). 61 | - move=> zmn zm. 62 | case: (mn zm)=>zn ?. 63 | case: (nm zn)=>zm'?. 64 | apply: ltE. 65 | + by rewrite (_ : zmn zm = zn)//=. 66 | + rewrite (_ : zmn zm = zn)//. 67 | by rewrite (_ : zm = zm'). 68 | Qed. 69 | 70 | HB.instance Definition L_poset_axioms := PosetOfPreorder.Build (L A) L_ltE. 71 | 72 | Lemma L_lt_pi1 {m n : L A} : m ≤ n → defd m → defd n. 73 | Proof. 74 | move=> mn zm. 75 | by case: (mn zm). 76 | Qed. 77 | 78 | Lemma L_lt_pi2 {m n : L A} : m ≤ n → ∀ z z', m z ≤ n z'. 79 | Proof. 80 | move=> mn z z'. 81 | case: (mn z)=> zn. 82 | by rewrite (_ : zn = z'). 83 | Qed. 84 | 85 | Section Lub. 86 | Context (F : Family (L A)) (dirF : is_directed F). 87 | 88 | Lemma directed_defd_fam : is_directed (push_fam (λ x : L A, defd x) F). 89 | Proof. 90 | split. 91 | - by case: (nonempty _ dirF). 92 | - move=> //= i j. 93 | case: (predirected _ dirF i j) => k [ik jk]. 94 | exists k; split; move=>zFi. 95 | + by apply: (L_lt_pi1 ik). 96 | + by apply: (L_lt_pi1 jk). 97 | Qed. 98 | 99 | Section Candidate. 100 | Context (H : dlub (push_fam (λ x : L A, defd x) F) directed_defd_fam). 101 | 102 | Definition candidate_dlub_fam : Family A. 103 | Proof. 104 | unshelve esplit. 105 | - exact: ({i : fam_ix F | defd (F i)}). 106 | - move=> i. 107 | exact: F (sval i) (svalP i). 108 | Defined. 109 | 110 | Lemma candidate_dlub_fam_directed : is_directed candidate_dlub_fam. 111 | Proof. 112 | split. 113 | - move: H. 114 | apply: Σ_lub_elim=>//= i z. 115 | unshelve esplit=>//. 116 | by exists i. 117 | - move=> i j. 118 | case: (predirected _ dirF (sval i) (sval j))=> k [ik jk]. 119 | unshelve esplit. 120 | + by exists k; case: (ik (svalP i)). 121 | + by split=>//=; apply: L_lt_pi2. 122 | Qed. 123 | 124 | Definition candidate_dlub : A. 125 | Proof. by apply: dlub candidate_dlub_fam_directed. Defined. 126 | 127 | End Candidate. 128 | 129 | Definition L_dlub : L A. 130 | Proof. 131 | unshelve esplit. 132 | - by apply: dlub directed_defd_fam. 133 | - by apply: candidate_dlub. 134 | Defined. 135 | 136 | Lemma L_dlub_is_lub : is_lub F L_dlub. 137 | Proof. 138 | split. 139 | - move=> i zi. 140 | unshelve esplit. 141 | + apply: Σ_lub_intro=>//. 142 | by exact: zi. 143 | + rewrite /L_dlub//=. 144 | rewrite /candidate_dlub//=. 145 | apply: ltT'. 146 | apply: lub_is_ub=>//. 147 | * by exists i. 148 | * rewrite /candidate_dlub_fam//=. 149 | by rewrite (_ : (svalP (exist (λ i0 : fam_ix F, defd (F i0)) i zi)) = zi)//=. 150 | - move=>//= x xub. 151 | move/[dup]; apply: Σ_lub_elim=>//. 152 | move=> //= i zi z'. 153 | case: (xub i zi)=> zx h. 154 | exists zx. 155 | apply: lub_univ=>//=. 156 | move=> j. 157 | rewrite /candidate_dlub_fam//=. 158 | case: (xub (sval j) (svalP j))=> zx' h'. 159 | by rewrite (_ : zx = zx')//=. 160 | Qed. 161 | 162 | Lemma L_ltHasDLub : ∃ m : L A, is_lub F m. 163 | Proof. exists L_dlub; by apply: L_dlub_is_lub. Qed. 164 | 165 | Lemma L_dlub_rw : ∀ m : L A, is_lub F m → m = L_dlub. 166 | Proof. move=> m ?; by apply/lub_unique/L_dlub_is_lub. Qed. 167 | End Lub. 168 | 169 | Definition L_bot : L A. 170 | Proof. by exists False. Defined. 171 | 172 | Lemma L_bot_is_bot : is_bottom L_bot. 173 | Proof. by move=>?//=; case. Qed. 174 | 175 | Lemma L_has_bot : ∃ x : L A, is_bottom x. 176 | Proof. by exists L_bot; apply: L_bot_is_bot. Qed. 177 | 178 | HB.instance Definition L_dcpo_axioms := DcpoOfPoset.Build (L A) L_ltHasDLub. 179 | HB.instance Definition L_pointed_poset_axioms := PointedPosetOfPoset.Build (L A) L_has_bot. 180 | End Lift. 181 | 182 | Section Functor. 183 | 184 | Context {A B : Dcpo.type} (f : A → B) (fcont : is_continuous f). 185 | 186 | Definition fmap : L A → L B. 187 | Proof. by move=> x; exists (defd x) => z; apply/f/x. Defined. 188 | 189 | Lemma fmap_cont : is_continuous fmap. 190 | Proof. 191 | move=>/= F dirF x xlub; split. 192 | - move=> /= i; move=> zi. 193 | case: (lub_is_ub _ _ xlub i zi)=> zx h. 194 | exists zx. 195 | rewrite /fmap//=. 196 | by apply: cont_mono=>//. 197 | - move=> /= y yub. 198 | rewrite (L_dlub_rw _ _ _ x xlub). 199 | move/[dup]; apply: Σ_lub_elim=>//. 200 | move=> //= i zi z'. 201 | case: (yub i zi)=> zy h. 202 | exists zy. 203 | apply: lub_univ. 204 | + apply: fcont=>//. 205 | by apply: candidate_dlub_fam_directed. 206 | + move=> //= j. 207 | case: (yub (sval j) (svalP j))=> zy' h'. 208 | by rewrite (_ : zy = zy'). 209 | Qed. 210 | 211 | (* TODO: fmap strict *) 212 | End Functor. 213 | 214 | Section Alg. 215 | Context (D : Dcppo.type). 216 | 217 | Definition alg_fam (x : L D) : Family D. 218 | Proof. 219 | exists (sum (defd x) True); case. 220 | + apply: x. 221 | + move=> _; exact: ⊥. 222 | Defined. 223 | 224 | Lemma alg_fam_dir (x : L D) : is_directed (alg_fam x). 225 | Proof. 226 | split. 227 | + by split=>//=; right. 228 | + case=> [z|[]]; case=> [z' | []]; 229 | (unshelve esplit; first by (left + right)); split; try by []. 230 | by rewrite (_ : z = z'). 231 | Qed. 232 | 233 | Definition alg : L D → D. 234 | Proof. by move=>x; apply/dlub/alg_fam_dir. Defined. 235 | 236 | Lemma alg_cont : is_continuous alg. 237 | Proof. 238 | move=>/= F dirF x xlub. 239 | rewrite /alg. 240 | split. 241 | - move=>/= i. 242 | apply: above_lub=>//. 243 | case=>// di//=. 244 | case: (lub_is_ub _ _ xlub i di)=> zx h. 245 | apply: ltT. 246 | + by apply: h. 247 | + by apply: (lub_is_ub (alg_fam x) (dlub (alg_fam x) (alg_fam_dir x)) _ (inl zx)). 248 | 249 | - move=> z zub /=. 250 | rewrite (L_dlub_rw _ _ _ x xlub). 251 | apply: above_lub=>//. 252 | case=>// /[dup]; apply: Σ_lub_elim=>//= i di u. 253 | rewrite /candidate_dlub. 254 | apply: lub_univ=>//. 255 | move=> //= j. 256 | apply: ltT'. 257 | + by apply: zub (sval j). 258 | + simpl. 259 | apply: ltT'. 260 | * apply: lub_is_ub=>//=. 261 | left. 262 | apply: svalP j. 263 | * by []. 264 | Qed. 265 | End Alg. 266 | 267 | 268 | Section Unit. 269 | Context {A : Dcpo.type}. 270 | Definition unit : A → L A. 271 | Proof. move=> a; exists ⊤ => _; exact: a. Defined. 272 | 273 | Lemma unit_cont : is_continuous unit. 274 | Proof. 275 | move=> F dirF x xlub; split. 276 | - move=> //=i; rewrite /unit; move=> //= zi. 277 | unshelve esplit=>//. 278 | apply: ltT'. 279 | + by apply: lub_is_ub xlub i. 280 | + by []. 281 | - move=> //= y. 282 | case: (nonempty F dirF)=> i z. 283 | move=> yub. 284 | case: (yub i)=> //=. 285 | + by rewrite Σ_top_rw. 286 | + move=> _ zy h zx. 287 | exists zy. 288 | rewrite /unit//=. 289 | apply: lub_univ. 290 | * by apply: xlub. 291 | * move=> j. 292 | case: (yub j)=> zy' //= h'. 293 | by rewrite (_ : zy = zy'). 294 | Qed. 295 | End Unit. 296 | 297 | Section Monad. 298 | 299 | Definition bind {A B : Dcpo.type} (f : A -> L B) : L A -> L B := 300 | alg _ \o (fmap f). 301 | 302 | Lemma bind_continuous {A B : Dcpo.type} (f : A → L B) (fcont : is_continuous f) : is_continuous (bind f). 303 | Proof. 304 | apply: cmp_cont. 305 | - apply: cont_mono. 306 | by apply: fmap_cont. 307 | - by apply: fmap_cont. 308 | - by apply: alg_cont. 309 | Qed. 310 | End Monad. 311 | 312 | Section UniversalProperty. 313 | 314 | Context (A : Dcpo.type) (C : Dcppo.type) (f : A → C) (fcont : is_continuous f). 315 | 316 | Definition univ_map : L A → C := alg _ \o fmap f. 317 | 318 | Lemma univ_map_cont : is_continuous univ_map. 319 | Proof. 320 | apply: cmp_cont. 321 | - by apply/cont_mono/fmap_cont. 322 | - by apply: fmap_cont. 323 | - by apply: alg_cont. 324 | Qed. 325 | 326 | Lemma univ_map_strict : univ_map ⊥ = ⊥. 327 | Proof. 328 | rewrite /univ_map /alg /fmap /=. 329 | apply: lub_unique=>//. 330 | rewrite /alg_fam /=. 331 | split=>//. 332 | case=> [+ |[]]//=. 333 | rewrite (_ : ⊥ = L_bot _) //. 334 | by apply/bottom_is_unique/L_bot_is_bot. 335 | Qed. 336 | 337 | Lemma univ_map_compute : ∀ x, univ_map (unit x) = f x. 338 | Proof. 339 | move=> x. 340 | rewrite /univ_map /unit /fmap /alg /=. 341 | apply: lub_unique=>//. 342 | split; first by case. 343 | move=> c cub. 344 | apply: ltT'. 345 | - by apply: cub; left; rewrite Σ_top_rw. 346 | - by []. 347 | Qed. 348 | 349 | Definition is_univ_map (h : L A → C) := is_continuous h ∧ (h ⊥ = ⊥) ∧ ∀ x, h (unit x) = f x. 350 | 351 | (** In order to prove that there is at most one map satisfying 352 | [is_univ_map], we are going to use the continuity of candidate 353 | universal maps with respect to the following directed family. *) 354 | Section Fam. 355 | Context (x : L A). 356 | Local Definition fam : Family (L A). 357 | Proof. 358 | exists (sum (defd x) True); case. 359 | - by move=>?; apply/unit/x. 360 | - move=> _; exact: ⊥. 361 | Defined. 362 | 363 | Local Lemma fam_dir : is_directed fam. 364 | Proof. 365 | split. 366 | - by split=>//; right. 367 | - case=> [z|[]]; case=> [z'|[]]; (unshelve esplit; first by (left + right)); split=>//. 368 | by rewrite (_ : z = z'). 369 | Qed. 370 | 371 | Local Lemma fam_lub : is_lub fam x. 372 | Proof. 373 | split. 374 | - case=> [z|[]] //=. 375 | move=> z'. 376 | by exists z. 377 | - move=>/=y yub. 378 | move=> z. 379 | have u : (⊤ : Σ) by rewrite Σ_top_rw. 380 | case: (yub (inl z) u)=> z' //= h. 381 | by exists z'. 382 | Qed. 383 | End Fam. 384 | 385 | Lemma univ_map_unique : ∀ h h', is_univ_map h → is_univ_map h' → h = h'. 386 | Proof. 387 | move=> h h' [hcont [hstr hfac]] [h'cont [h'str h'fac]]. 388 | apply: funext=>x. 389 | apply: lub_unique. 390 | - apply/hcont/fam_lub/fam_dir. 391 | - rewrite (_ : push_fam h (fam x) = push_fam h' (fam x)). 392 | + rewrite /push_fam; congr Build_Family. 393 | apply: funext; case=> [z|[]] /=. 394 | * by rewrite hfac h'fac. 395 | * by rewrite hstr h'str. 396 | + apply/h'cont/fam_lub/fam_dir. 397 | Qed. 398 | 399 | Lemma univ_map_is_univ_map : is_univ_map univ_map. 400 | Proof. 401 | split; [|split]. 402 | - apply: univ_map_cont. 403 | - apply: univ_map_strict. 404 | - apply: univ_map_compute. 405 | Qed. 406 | 407 | Lemma universal_property : exists! f, is_univ_map f. 408 | Proof. 409 | exists univ_map. 410 | split. 411 | - apply: univ_map_is_univ_map. 412 | - by move=> ?; apply/univ_map_unique/univ_map_is_univ_map. 413 | Qed. 414 | End UniversalProperty. 415 | -------------------------------------------------------------------------------- /theories/Path.v: -------------------------------------------------------------------------------- 1 | From Domains Require Import Preamble Preorder Poset Dcpo Sierpinski DcpoExponential. 2 | 3 | Section Path. 4 | Context (D : Dcpo.type). 5 | 6 | Definition Path := map (HB.pack Σ) D. 7 | 8 | Lemma lub_intro (A : Family Σ): ∀ u ϕ, is_lub A ϕ → A u → ϕ. 9 | Proof. by move=> u ϕ ϕlub; apply: (lub_is_ub A). Qed. 10 | 11 | Section PathFromLt. 12 | Context (x y : D) (xy : x ≤ y). 13 | 14 | Section Family. 15 | Context (ϕ : Σ). 16 | 17 | Definition path_fam : Family D. 18 | Proof. 19 | exists (sum ϕ True). 20 | by case=> _; [exact: y| exact: x]. 21 | Defined. 22 | 23 | Lemma path_fam_directed : is_directed path_fam. 24 | Proof. 25 | split. 26 | - by exists (inr I). 27 | - by case=>a1; case=>a2 /=; (unshelve esplit; [left + right; assumption | eauto]). 28 | Qed. 29 | End Family. 30 | 31 | Lemma dlub_continuous : is_continuous (λ ϕ : Σ, dlub (path_fam ϕ) (path_fam_directed ϕ)). 32 | Proof. 33 | move=> A dirA p plub; split. 34 | - move=> //= u; apply: (above_lub _)=>//=; case. 35 | + move=>s; apply: ltT'. 36 | * by apply: dlub_is_ub; left; apply: (Σ_lub_intro A _ _ _ s). 37 | * by []. 38 | + move=> []; apply: ltT'. 39 | * by apply: dlub_is_ub; right. 40 | * by []. 41 | - move=> z zub; apply: (lub_univ _)=>//; case=>/=. 42 | + move=> h. 43 | suff: ∃ i, A i. 44 | * move=> [i u]. 45 | apply: ltT; last by apply: zub. 46 | apply: ltT'. 47 | -- by apply: lub_is_ub; [apply: dlub_is_lub | left]. 48 | -- by []. 49 | * apply: (lub_univ A); auto. 50 | -- by apply/lub_is_ub/Σ_exists_is_lub. 51 | -- suff: dlub A dirA = p by move=>->. 52 | by apply: lub_unique. 53 | + move=> _. 54 | case: dirA => [[i _] h]. 55 | apply/ltT/zub; last by []. 56 | apply: ltT'. 57 | * by apply: dlub_is_ub; right. 58 | * by []. 59 | Qed. 60 | 61 | Definition make_path : Path. 62 | Proof. 63 | unshelve esplit. 64 | - move=> ϕ. 65 | by apply/dlub/path_fam_directed/ϕ. 66 | - by apply: dlub_continuous. 67 | Defined. 68 | End PathFromLt. 69 | 70 | 71 | 72 | 73 | Definition HasPath x y := ∃ p : Path, ap p ⊥ = x /\ ap p ⊤ = y. 74 | Infix "⟿" := HasPath (at level 10). 75 | 76 | Lemma fwd : ∀ x y : D, x ≤ y → x ⟿ y. 77 | Proof. 78 | move=> x y xy. 79 | exists (make_path x y xy); split=>/=. 80 | - apply: (lub_unique (path_fam _ _ _))=>//; split. 81 | + by case=>//; rewrite Σ_bot_rw. 82 | + move=> z h; apply: ltT'. 83 | * by apply: h; right. 84 | * by []. 85 | - apply: (lub_unique (path_fam _ _ _))=>//; split; first by case. 86 | move=> z h; apply: ltT'. 87 | * by apply: h; left; rewrite Σ_top_rw. 88 | * by []. 89 | Qed. 90 | 91 | Lemma bwd : ∀ x y : D, x ⟿ y → x ≤ y. 92 | Proof. 93 | move=> ? ? [? [<- <-]]. 94 | by apply/cont_mono/bottom_is_bottom/ap_cont. 95 | Qed. 96 | 97 | Lemma characterization : ∀ x y, (x ≤ y) = (x ⟿ y). 98 | Proof. 99 | move=> x y. 100 | by apply: propext; split; [apply: fwd | apply: bwd]. 101 | Qed. 102 | 103 | End Path. 104 | 105 | 106 | 107 | Definition Σ_fun := 108 | map (HB.pack Σ) (HB.pack Σ). 109 | 110 | Definition Σ_line := 111 | {ϕ : Σ & {ψ : Σ | ϕ ≤ ψ}}. 112 | 113 | Notation "Σ^Σ" := Σ_fun. 114 | Notation "Σ/=>" := Σ_line. 115 | 116 | Definition phoa_fwd : Σ^Σ → Σ/=>. 117 | Proof. 118 | move=> F. 119 | exists (ap F ⊥). 120 | exists (ap F ⊤). 121 | abstract by apply: cont_mono; first by apply: svalP. 122 | Defined. 123 | 124 | Definition phoa_bwd : Σ/=> → Σ^Σ. 125 | Proof. 126 | move=> [ϕ [ψ h]]. 127 | apply: make_path h. 128 | Defined. 129 | 130 | Ltac replace_goal H := 131 | match goal with 132 | | [|- ?G] => rewrite (_ : G = H) 133 | end. 134 | 135 | Definition phoa_bwd_fwd : ∀ F, phoa_bwd (phoa_fwd F) = F. 136 | Proof. 137 | move=> F. 138 | apply: eq_sig=>//=. 139 | apply: funext=> ϕ. 140 | apply: propext; split. 141 | - apply: Σ_lub_elim=>//=. 142 | by case=>//= ?; apply: (cont_mono (ap F))=>//=; by apply: svalP. 143 | - move=> x. 144 | set fam := path_fam (HB.pack Σ) ⊥ ⊤ ϕ. 145 | set Ffam := path_fam (HB.pack Σ) (ap F ⊥) (ap F ⊤) ϕ. 146 | set dfam := path_fam_directed (HB.pack Σ) ⊥ ⊤ (top_is_top ⊥) ϕ. 147 | 148 | replace_goal (ap F (∃ i, fam i)). 149 | + apply: lub_unique; first by []. 150 | rewrite (_ : Ffam = push_fam (sval F) fam). 151 | * by congr Build_Family; apply: funext; case. 152 | * apply: (svalP F fam dfam). 153 | by apply: Σ_exists_is_lub. 154 | + rewrite /fam /dfam /Ffam. 155 | move: x. 156 | apply: (cont_mono (ap F)); first by apply: svalP. 157 | move=> u. 158 | exists (inl u). 159 | by rewrite //= Σ_top_rw. 160 | Qed. 161 | 162 | Definition phoa_fwd_bwd : ∀ x, phoa_fwd (phoa_bwd x) = x. 163 | Proof. 164 | move=> [ϕ [ψ h]]. 165 | rewrite /phoa_fwd //=. 166 | apply: eq_sigT=>//=. 167 | - set fam := path_fam (HB.pack Σ) ϕ ψ ⊥. 168 | set dfam := path_fam_directed (HB.pack Σ ) ϕ ψ h ⊥. 169 | apply: lub_unique=>//=. 170 | split. 171 | + case=>//=. 172 | by rewrite Σ_bot_rw. 173 | + move=>//= χ h'. 174 | apply: h' (inr _). 175 | done. 176 | - move=> H. 177 | apply: eq_sig=>//=. 178 | simplify_eqs. 179 | apply: lub_unique=>//=. 180 | split. 181 | + by case=>//=. 182 | + move=> //= χ h'. 183 | apply: h' (inl _). 184 | by rewrite Σ_top_rw. 185 | Qed. 186 | -------------------------------------------------------------------------------- /theories/Poset.v: -------------------------------------------------------------------------------- 1 | From Domains Require Import Preamble Preorder. 2 | 3 | HB.mixin Record PosetOfPreorder A of Preorder A := 4 | {ltE : ∀ x y : A, x ≤ y → y ≤ x → x = y}. 5 | 6 | HB.structure Definition Poset := {A of PosetOfPreorder A & Preorder A}. 7 | 8 | Definition is_monotone {D E : Preorder.type} (f : D → E) := 9 | ∀ x y, x ≤ y → f x ≤ f y. 10 | 11 | #[export] 12 | Hint Resolve ltR : core. 13 | 14 | Section Extrema. 15 | Context {A : Poset.type}. 16 | Definition is_bottom (x : A) := ∀ y : A, x ≤ y. 17 | Definition is_top (x : A) := ∀ y : A, y ≤ x. 18 | 19 | Lemma bottom_is_unique : ∀ x y, is_bottom x → is_bottom y → x = y. 20 | Proof. 21 | move=> x y xb yb. 22 | by apply: ltE; [apply: xb | apply: yb]. 23 | Qed. 24 | 25 | Lemma top_is_unique : ∀ x y, is_top x → is_top y → x = y. 26 | Proof. 27 | move=> x y xt yt. 28 | by apply: ltE; [apply: yt | apply: xt]. 29 | Qed. 30 | End Extrema. 31 | 32 | HB.mixin Record PointedPosetOfPoset A of Poset A := 33 | {ltHasBot : ∃ x : A, is_bottom x}. 34 | 35 | HB.structure Definition PointedPoset := {A of PointedPosetOfPoset A & Poset A}. 36 | 37 | HB.mixin Record BoundedPosetOfPointedPoset A of PointedPoset A := 38 | {ltHasTop : ∃ x : A, is_top x}. 39 | 40 | HB.structure Definition BoundedPoset := {A of BoundedPosetOfPointedPoset A & PointedPoset A}. 41 | 42 | Section Bottom. 43 | Context {A : PointedPoset.type}. 44 | 45 | Definition bottom_bundled : {x : A | is_bottom x}. 46 | Proof. 47 | apply: constructive_definite_description. 48 | case: (@ltHasBot A) => x xbot. 49 | exists x; split=>// y ybot. 50 | by apply: bottom_is_unique. 51 | Qed. 52 | 53 | Definition bottom : A := proj1_sig bottom_bundled. 54 | Definition bottom_is_bottom : is_bottom bottom := proj2_sig bottom_bundled. 55 | Opaque bottom. 56 | End Bottom. 57 | 58 | #[export] 59 | Hint Extern 0 => apply: bottom_is_bottom : core. 60 | 61 | Section Top. 62 | Context {A : BoundedPoset.type}. 63 | 64 | Definition top_bundled : {x : A | is_top x}. 65 | Proof. 66 | apply: constructive_definite_description. 67 | case: (@ltHasTop A) => x xtop. 68 | exists x; split=>// y ytop. 69 | by apply: top_is_unique. 70 | Qed. 71 | 72 | Definition top : A := proj1_sig top_bundled. 73 | Definition top_is_top : is_top top := proj2_sig top_bundled. 74 | Opaque top. 75 | End Top. 76 | 77 | #[export] 78 | Hint Extern 0 => apply: top_is_top : core. 79 | 80 | 81 | Notation "⊥" := bottom. 82 | Notation "⊤" := top. 83 | 84 | Record Family (A : Type) := 85 | {fam_ix : Type; 86 | fam_val :> fam_ix → A}. 87 | 88 | Arguments fam_ix [_]. 89 | Arguments fam_val [_] _. 90 | 91 | Section DirectedFamilies. 92 | Context {A : Poset.type} (F : Family A). 93 | 94 | Definition is_nonempty : Prop := 95 | ∃ x : fam_ix F, True. 96 | 97 | Definition is_predirected : Prop := 98 | ∀ i j : fam_ix F, 99 | ∃ k, 100 | F i ≤ F k ∧ F j ≤ F k. 101 | 102 | Record is_directed : Prop := 103 | {nonempty : is_nonempty; 104 | predirected : is_predirected}. 105 | End DirectedFamilies. 106 | 107 | Section Lub. 108 | Context {A : Poset.type} (F : Family A). 109 | 110 | Definition is_ub (x : A) := 111 | ∀ i, F i ≤ x. 112 | 113 | Record is_lub (x : A) := 114 | {lub_is_ub : is_ub x; 115 | lub_univ : ∀ z : A, is_ub z → x ≤ z}. 116 | 117 | Lemma lub_unique : ∀ x y : A, is_lub x → is_lub y → x = y. 118 | Proof. by move=> ?? [? Hx] [? Hy]; apply: ltE; [apply: Hx| apply: Hy]. Qed. 119 | 120 | Lemma above_lub : ∀ x y : A, is_lub x → is_ub y → x ≤ y. 121 | Proof. by move=> ?? [?]; apply. Qed. 122 | End Lub. 123 | 124 | 125 | Definition push_fam {D E : Poset.type} (f : D → E) (F : Family D) : Family E. 126 | Proof. 127 | exists (fam_ix F). 128 | by move=>?; apply/f/F. 129 | Defined. 130 | 131 | 132 | Definition is_continuous {D E : Poset.type} (f : D → E) := 133 | ∀ (A : Family D) (h : is_directed A) x, 134 | is_lub A x → 135 | is_lub (push_fam f A) (f x). 136 | 137 | 138 | Lemma mono_preserves_dir {D E : Poset.type} {A : Family D} {f : D → E} : is_monotone f → is_directed A → is_directed (push_fam f A). 139 | Proof. 140 | move=> mono dirA. 141 | split. 142 | + rewrite /is_nonempty /push_fam //=. 143 | apply: nonempty dirA. 144 | + move=> //= u v. 145 | case: (predirected A dirA u v) => k [uk vk]. 146 | by exists k; split; apply: mono. 147 | Qed. 148 | 149 | Lemma cmp_cont {D E F : Poset.type} (f : D → E) (g : E → F) : is_monotone f → is_continuous f → is_continuous g → is_continuous (g \o f). 150 | Proof. 151 | move=> fmono fcont gcont A dirA x xlub. 152 | apply: (gcont (push_fam f A)); last by apply: fcont. 153 | by apply: mono_preserves_dir. 154 | Qed. 155 | -------------------------------------------------------------------------------- /theories/Preamble.v: -------------------------------------------------------------------------------- 1 | Require Export ssreflect ssrfun Unicode.Utf8. 2 | From HB Require Export structures. 3 | Require Export Coq.Logic.Description Coq.Logic.PropExtensionality Coq.Logic.FunctionalExtensionality Program.Equality. 4 | Export EqNotations. 5 | 6 | Set Primitive Projections. 7 | 8 | Definition iota {X : Type} (P : X → Prop) (h : exists! x, P x) : X := 9 | proj1_sig (constructive_definite_description _ h). 10 | 11 | Lemma iota_prop {X : Type} (P : X → Prop) (h : exists! x, P x) : P (iota P h). 12 | Proof. rewrite /iota; apply proj2_sig. Qed. 13 | 14 | Arguments proj1_sig {A P}. 15 | Notation sval := proj1_sig. 16 | 17 | Scheme eq_ind := Induction for eq Sort Type. 18 | Arguments eq_ind [A] x P f y e. 19 | 20 | Definition extract {X : Type} {P : X → Prop} : (∀ x y, P x → P y → x = y) → (∃ x, P x) → X. 21 | Proof. 22 | move=> H J. 23 | apply: (@iota X P). 24 | case: J=> x xP. 25 | exists x; split=>//. 26 | by move=>?; apply: H. 27 | Defined. 28 | 29 | Definition extract_prop {X : Type} {P : X → Prop} : ∀ H J, P (@extract X P H J). 30 | Proof. 31 | move=> ? ?. 32 | apply: iota_prop. 33 | Qed. 34 | 35 | Opaque extract. 36 | 37 | Module Im. 38 | Section Im. 39 | Context {X Y : Type} (f : X → Y). 40 | 41 | Definition T : Type := 42 | { y : Y | ∃ x, f x = y }. 43 | 44 | Definition surj : X → T. 45 | Proof. by move=> x; exists (f x); exists x. Defined. 46 | 47 | Definition inj : T → Y. 48 | Proof. by apply: proj1_sig. Defined. 49 | 50 | Lemma inj_injective : ∀ x y, inj x = inj y → x = y. 51 | Proof. by move=> x y h; apply/eq_sig/proof_irrelevance. Qed. 52 | 53 | Lemma surj_surjective : ∀ i : T, ∃ x : X, surj x = i. 54 | Proof. by move=> [y [x h]]; exists x; apply/eq_sig/proof_irrelevance. Qed. 55 | End Im. 56 | End Im. 57 | 58 | Notation Im := Im.T. 59 | 60 | Notation propext := propositional_extensionality. 61 | Notation funext := functional_extensionality. 62 | Notation depfunext := functional_extensionality_dep. 63 | Notation proofirr := proof_irrelevance. 64 | 65 | #[global] 66 | Hint Resolve proofirr : core. 67 | 68 | 69 | Definition surjective {E B} (f : E → B) : Prop := 70 | ∀ x : B, ∃ y : E, f y = x. 71 | 72 | Definition is_isomorphism {A B} (f : A → B) : Prop := 73 | ∀ x : B, exists! y : A, f y = x. 74 | 75 | Lemma balanced {A B} (f : A → B) : injective f → surjective f → is_isomorphism f. 76 | Proof. 77 | move=> inj surj b. 78 | case: (surj b)=> a ha. 79 | exists a; split=>//=. 80 | move=> a' ha'. 81 | apply: inj. 82 | by congruence. 83 | Qed. 84 | 85 | Lemma iso_injective {A B} (f : A → B) : is_isomorphism f → injective f. 86 | Proof. 87 | move=> iso a a' h. 88 | case: (iso (f a)) (iso (f a'))=> [za [hza1 /(_ a') hza2]] [za' [hza'1 hza'2]]. 89 | by move: (hza'2 za) (hza'2 a); rewrite hza2//=; move=> <-//= <-//=; congruence. 90 | Qed. 91 | 92 | Lemma iso_surjective {A B} (f : A → B) : is_isomorphism f → surjective f. 93 | Proof. by move=> iso b; case: (iso b) => a [? _]; exists a. Qed. 94 | 95 | 96 | 97 | 98 | Module Coeq. 99 | Private Inductive T {A B} (f g : A → B) := 100 | | intro : B → T f g. 101 | 102 | Arguments intro [A] [B] [f] [g] x. 103 | 104 | Section Operations. 105 | Context {A B} {f g : A → B}. 106 | 107 | Axiom glue : ∀ {x}, @intro A B f g (f x) = @intro A B f g (g x). 108 | 109 | Definition rec {C} (h : B → C) : (h \o f = h \o g) → T f g → C. 110 | Proof. by move=> ?; case. Defined. 111 | 112 | Definition ind (C : T f g → Type) (h : ∀ b, C (intro b)) : (∀ x, rew [C] glue in h (f x) = h (g x)) → ∀ x : T f g, C x. 113 | Proof. by move=> ?; case. Defined. 114 | 115 | End Operations. 116 | End Coeq. 117 | 118 | Module Quotient. 119 | Definition gph A (R : A → A → Prop) := {p : A * A | R p.1 p.2}. 120 | 121 | Definition pi1 {A} (R : A → A → Prop) : gph A R → A. 122 | Proof. by move/proj1_sig/fst. Defined. 123 | 124 | Definition pi2 {A} (R : A → A → Prop) : gph A R → A. 125 | Proof. by move/proj1_sig/snd. Defined. 126 | 127 | Definition T A (R : A → A → Prop) := Coeq.T (pi1 R) (pi2 R). 128 | 129 | Section Operations. 130 | Context {A} {R : A → A → Prop}. 131 | 132 | Definition intro : A → T A R. 133 | Proof. apply: Coeq.intro. Defined. 134 | 135 | Definition rec {C} (h : A → C) : (∀ x y : A, R x y → h x = h y) → T A R → C. 136 | Proof. 137 | move=> H. 138 | apply: (Coeq.rec h). 139 | abstract by apply: funext; case=> ? ?; rewrite /pi1 /pi2 //=; apply: H. 140 | Defined. 141 | 142 | Definition glue : ∀ {x y}, R x y → intro x = intro y. 143 | Proof. 144 | move=> x y h. 145 | rewrite /intro. 146 | pose xyh : gph A R := exist _ (x,y) h. 147 | rewrite (_ : x = pi1 _ xyh); first by []. 148 | rewrite (_ : y = pi2 _ xyh) ; first by []. 149 | apply Coeq.glue. 150 | Qed. 151 | 152 | Definition ind (C : T A R → Type) (h : ∀ x : A, C (intro x)) : (∀ (x y : A) (xy : R x y), rew [C] glue xy in h x = h y) → ∀ x : T A R, C x. 153 | Proof. 154 | move=> H. 155 | apply: (Coeq.ind C h); case; case=> x y xy. 156 | abstract by rewrite /pi1 /pi2 //= -(H x y xy); congr eq_rect. 157 | Defined. 158 | 159 | 160 | 161 | Definition indp (C : T A R → Prop) (h : ∀ x : A, C (intro x)) : ∀ x : T A R, C x. 162 | Proof. by apply: ind. Qed. 163 | 164 | Definition ind_eta (C : T A R → Type) (f1 f2 : ∀ x : T A R, C x) : (∀ x, f1 (intro x) = f2 (intro x)) → f1 = f2. 165 | Proof. by move=>?; apply: depfunext; apply: indp. Qed. 166 | 167 | 168 | Section Effectivity. 169 | Context `{RelationClasses.Equivalence A R}. 170 | 171 | Local Definition R' : T A R → A → Prop. 172 | Proof. 173 | apply: (rec R)=> x y xy. 174 | apply: funext=> z. 175 | apply: propext; split. 176 | - move=> ?. 177 | transitivity x=>//. 178 | by symmetry. 179 | - move=> ?. 180 | by transitivity y=>//. 181 | Defined. 182 | 183 | Definition eff {x y : A} : intro x = intro y → R x y. 184 | Proof. 185 | move=> h. 186 | symmetry. 187 | rewrite (_ : R y x = R x x); last by reflexivity. 188 | by move: (f_equal R' h) => //= ->. 189 | Qed. 190 | 191 | Definition glue_is_iso {x y : A} : is_isomorphism (@glue x y). 192 | Proof. 193 | move=> e. 194 | unshelve esplit=>//. 195 | by apply: eff. 196 | Qed. 197 | End Effectivity. 198 | End Operations. 199 | End Quotient. 200 | -------------------------------------------------------------------------------- /theories/Preorder.v: -------------------------------------------------------------------------------- 1 | From Domains Require Import Preamble. 2 | 3 | Declare Scope preorder_scope. 4 | Delimit Scope preorder_scope with P. 5 | 6 | Open Scope preorder_scope. 7 | 8 | HB.mixin Record PreorderOfType A := 9 | {lt : A → A → Prop; 10 | ltR : ∀ x, lt x x; 11 | ltT : ∀ x y z, lt x y → lt y z → lt x z}. 12 | 13 | HB.structure Definition Preorder := {A of PreorderOfType A}. 14 | 15 | Lemma ltT' {A : Preorder.type} : ∀ x y z : A, lt y z → lt x y → lt x z. 16 | Proof. by move=>???/[swap]; exact: ltT. Qed. 17 | 18 | Infix "≤" := lt : preorder_scope. 19 | -------------------------------------------------------------------------------- /theories/Sierpinski.v: -------------------------------------------------------------------------------- 1 | From Domains Require Import Preamble Preorder Poset Dcpo. 2 | 3 | Definition Σ := Prop. 4 | Definition Σ_lt (x y : Σ) := x → y. 5 | 6 | Lemma Σ_ltR : ∀ x : Σ, x → x. 7 | Proof. by []. Qed. 8 | 9 | Lemma Σ_ltT : ∀ x y z : Σ, (x → y) → (y → z) → x → z. 10 | Proof. by move=>???/[swap]; exact: comp. Qed. 11 | 12 | HB.instance Definition Σ_preorder_axioms := PreorderOfType.Build Σ Σ_lt Σ_ltR Σ_ltT. 13 | 14 | Lemma Σ_ltE : ∀ x y : Σ, (x ≤ y) → (y ≤ x) → x = y. 15 | Proof. by move=> *; apply: propext. Qed. 16 | 17 | HB.instance Definition Σ_poset_axioms := PosetOfPreorder.Build Σ Σ_ltE. 18 | 19 | Lemma Σ_exists_is_lub : ∀ (A : Family Σ), is_lub A (∃ x, A x). 20 | Proof. 21 | move=> A; split=>/=. 22 | - by move=>i; move=>?; exists i. 23 | - move=>? zub; move=> [x ?]. 24 | by apply: (zub x). 25 | Qed. 26 | 27 | Lemma Σ_ltHasDLubs : ∀ (A : Family Σ), is_directed A → ∃ x, is_lub A x. 28 | Proof. 29 | move=> A dir //=. 30 | exists (∃ x, A x). 31 | by apply: Σ_exists_is_lub. 32 | Qed. 33 | 34 | HB.instance Definition Σ_dcpo_axioms := DcpoOfPoset.Build Σ Σ_ltHasDLubs. 35 | 36 | Lemma Σ_ltHasBot : ∃ x : Σ, is_bottom x. 37 | Proof. by exists False=>?. Qed. 38 | 39 | Lemma Σ_ltHasTop : ∃ x : Σ, is_top x. 40 | Proof. by exists True=>?. Qed. 41 | 42 | HB.instance Definition Σ_pointed_poset_axioms := PointedPosetOfPoset.Build Σ Σ_ltHasBot. 43 | HB.instance Definition Σ_bounded_poset_axioms := BoundedPosetOfPointedPoset.Build Σ Σ_ltHasTop. 44 | 45 | Lemma Σ_top_rw : (⊤ : Σ) = True. 46 | Proof. by apply: top_is_unique. Qed. 47 | 48 | Lemma Σ_bot_rw : (⊥ : Σ) = False. 49 | Proof. by apply: bottom_is_unique=>// ?. Qed. 50 | 51 | Lemma Σ_lub_intro (A : Family Σ): ∀ u ϕ, is_lub A ϕ → A u → ϕ. 52 | Proof. by move=> ???; apply: (lub_is_ub A). Qed. 53 | 54 | Lemma Σ_lub_elim {P Q: Σ} {A} : is_lub A P → (∀ x, A x → Q) → P → Q. 55 | Proof. 56 | move=> H J. 57 | rewrite -(lub_unique _ _ _ (Σ_exists_is_lub _) H). 58 | by case; apply: J. 59 | Qed. 60 | -------------------------------------------------------------------------------- /theories/Skeleton.v: -------------------------------------------------------------------------------- 1 | From Domains Require Import Preamble Preorder Poset WF. 2 | 3 | Section Skeleton. 4 | Variable A : Preorder.type. 5 | 6 | Local Definition rel (x y : A) : Prop := 7 | x ≤ y ∧ y ≤ x. 8 | 9 | Instance : RelationClasses.Reflexive rel. 10 | Proof. by move=> x; split. Qed. 11 | 12 | Instance : RelationClasses.Symmetric rel. 13 | Proof. by move=> x y [xy yx]; split. Qed. 14 | 15 | Instance : RelationClasses.Transitive rel. 16 | Proof. 17 | move=> x y z [xy yx] [yz zy]; split. 18 | - by apply: ltT; eauto. 19 | - by apply: ltT; eauto. 20 | Qed. 21 | 22 | Global Instance : RelationClasses.Equivalence rel. 23 | Proof. by split; typeclasses eauto. Defined. 24 | 25 | Definition skel := Quotient.T A rel. 26 | Definition cls : A → skel := Quotient.intro. 27 | 28 | Definition skel_lt (u v : skel) : Prop := 29 | ∀ x y, cls x = u → cls y = v → x ≤ y. 30 | 31 | Lemma skel_ltT : ∀ u v w : skel, skel_lt u v → skel_lt v w → skel_lt u w. 32 | Proof. 33 | apply: Quotient.indp=> x. 34 | apply: Quotient.indp=> y. 35 | apply: Quotient.indp=> z. 36 | move=> xy yz x' z' xx' zz'. 37 | apply: ltT. 38 | - by apply: xy. 39 | - by apply: yz. 40 | Qed. 41 | 42 | Lemma skel_ltR : ∀ u, skel_lt u u. 43 | Proof. 44 | apply: Quotient.indp=> x. 45 | move=> x' x''. 46 | move=>/Quotient.eff [x'x xx']. 47 | move=>/Quotient.eff [x''x xx'']. 48 | by apply: ltT; eauto. 49 | Qed. 50 | 51 | HB.instance Definition _ := PreorderOfType.Build skel skel_lt skel_ltR skel_ltT. 52 | 53 | Lemma skel_ltE : ∀ u v : skel, u ≤ v → v ≤ u → u = v. 54 | Proof. 55 | apply: Quotient.indp=> x. 56 | apply: Quotient.indp=> y. 57 | move=> xy yx. 58 | apply: Quotient.glue; split. 59 | + by apply: xy. 60 | + by apply: yx. 61 | Qed. 62 | 63 | HB.instance Definition _ := PosetOfPreorder.Build skel skel_ltE. 64 | 65 | Lemma cls_mono : is_monotone cls. 66 | Proof. 67 | move=> x y xy x' y'. 68 | move=>/Quotient.eff [x'x xx']. 69 | move=>/Quotient.eff [y'y yy']. 70 | apply: ltT. 71 | - by apply: x'x. 72 | - apply: ltT. 73 | + by apply: xy. 74 | + by apply: yy'. 75 | Qed. 76 | 77 | Lemma cls_full : ∀ x y : A, cls x ≤ cls y → x ≤ y. 78 | Proof. by move=> x y; apply. Qed. 79 | 80 | Lemma skel_lt_char : ∀ x y : A, (x ≤ y) = (cls x ≤ cls y). 81 | Proof. 82 | move=> x y. 83 | apply: propext; split. 84 | - by apply: cls_mono. 85 | - by apply: cls_full. 86 | Qed. 87 | 88 | Lemma cls_surj : surjective cls. 89 | Proof. by apply: Quotient.indp=> x; exists x. Qed. 90 | End Skeleton. 91 | 92 | Arguments cls [A] x. 93 | 94 | Section Wf. 95 | Variable A : WfPreorder.type. 96 | 97 | Definition skel_mem (u v : skel A) : Prop := 98 | ∀ x y, cls x = u → cls y = v → x ≺ y. 99 | 100 | 101 | Lemma skel_mem_char : ∀ x y : A, (x ≺ y) = (skel_mem (cls x) (cls y)). 102 | Proof. 103 | move=> x y; apply: propext; split. 104 | - move=> xy x' y'. 105 | move=>/Quotient.eff [x'x xx']. 106 | move=>/Quotient.eff [y'y yy']. 107 | apply: memL. 108 | + by apply: x'x. 109 | + apply: memR. 110 | * apply: xy. 111 | * apply: yy'. 112 | - by apply. 113 | Qed. 114 | 115 | Lemma skel_memT : ∀ u v w : skel A, skel_mem u v → skel_mem v w → skel_mem u w. 116 | Proof. 117 | apply: Quotient.indp=> x. 118 | apply: Quotient.indp=> y. 119 | apply: Quotient.indp=> z. 120 | rewrite -?skel_mem_char. 121 | apply: memT. 122 | Qed. 123 | 124 | Lemma skel_memL : ∀ u v w : skel A, u ≤ v → skel_mem v w → skel_mem u w. 125 | Proof. 126 | apply: Quotient.indp=> x. 127 | apply: Quotient.indp=> y. 128 | apply: Quotient.indp=> z. 129 | rewrite -?skel_mem_char -skel_lt_char. 130 | by apply: memL. 131 | Qed. 132 | 133 | Lemma skel_memR : ∀ u v w : skel A, skel_mem u v → v ≤ w → skel_mem u w. 134 | Proof. 135 | apply: Quotient.indp=> x. 136 | apply: Quotient.indp=> y. 137 | apply: Quotient.indp=> z. 138 | rewrite -?skel_mem_char -skel_lt_char. 139 | by apply: memR. 140 | Qed. 141 | 142 | Lemma skel_memWf : well_founded skel_mem. 143 | Proof. 144 | apply: Quotient.indp. 145 | apply: (well_founded_induction memWf)=> x ih. 146 | constructor; apply: Quotient.indp=> y hy. 147 | apply: ih. 148 | by rewrite skel_mem_char. 149 | Qed. 150 | 151 | Lemma skel_memLt : ∀ u v : skel A, skel_mem u v → u ≤ v. 152 | Proof. 153 | apply: Quotient.indp=> x. 154 | apply: Quotient.indp=> y. 155 | rewrite -skel_mem_char -skel_lt_char. 156 | by apply: memLt. 157 | Qed. 158 | 159 | HB.instance Definition _ := HasWf.Build (skel A) skel_mem skel_memWf skel_memLt skel_memT skel_memL skel_memR. 160 | End Wf. 161 | -------------------------------------------------------------------------------- /theories/UNat.v: -------------------------------------------------------------------------------- 1 | From Coq Require Import Arith.PeanoNat. 2 | From Domains Require Import Preamble Preorder Poset Dcpo. 3 | 4 | (** The "upper naturals" *) 5 | 6 | Definition UNat : Type := 7 | {P : nat → Prop | ∀ m n : nat, m <= n → P m → P n}. 8 | 9 | Definition UNat_defd : UNat → Prop := 10 | λ x, ∃ k, sval x k. 11 | 12 | Definition UNat_lt (M N : UNat) := 13 | ∀ x, sval M x → sval N x. 14 | 15 | Lemma UNat_ltR : ∀ x, UNat_lt x x. 16 | Proof. by move=>?. Qed. 17 | 18 | Lemma UNat_ltT : ∀ x y z, UNat_lt x y → UNat_lt y z → UNat_lt x z. 19 | Proof. by move=> x y z xy yz u xu; apply/yz/xy. Qed. 20 | 21 | HB.instance Definition UNat_preorder_axioms := PreorderOfType.Build UNat UNat_lt UNat_ltR UNat_ltT. 22 | 23 | Lemma UNat_ltE : ∀ x y : UNat, (x ≤ y) → (y ≤ x) → x = y. 24 | Proof. 25 | move=>x y xy yz. 26 | apply: eq_sig=>//. 27 | apply: funext=>k. 28 | by apply: propext; split; [apply: xy | apply: yz]. 29 | Qed. 30 | 31 | HB.instance Definition UNat_poset_axioms := PosetOfPreorder.Build UNat UNat_ltE. 32 | 33 | Definition UNat_dsum (x : UNat) (y : ∀ u, sval x u → UNat) : UNat. 34 | Proof. 35 | unshelve esplit. 36 | - move=> k. 37 | by exact: (∃ u v (h : sval x u), sval (y u h) v ∧ u <= k ∧ v <= k). 38 | - abstract 39 | (by move=> m n mn /= [u][v][hu][hv][um vm]; 40 | exists u, v, hu; do!split=>//; apply: (Nat.le_trans _ m)). 41 | Defined. 42 | 43 | Definition UNat_exists (I : Type) (y : I → UNat) : UNat. 44 | Proof. 45 | unshelve esplit. 46 | - move=> k. 47 | by exact: (∃ x, sval (y x) k). 48 | - abstract 49 | (by move=> m n mn /= [x hx]; 50 | exists x; apply: (proj2_sig (y x) m)). 51 | Defined. 52 | 53 | Lemma UNat_exists_is_lub : ∀ (A : Family UNat), is_lub A (UNat_exists _ A). 54 | move=> A; split=>/=. 55 | - by move=>i; move=>?; exists i. 56 | - move=> z zub; move=> x [i hxi]. 57 | by apply: (zub i x). 58 | Qed. 59 | 60 | Lemma UNat_ltHasDLubs : ∀ (A : Family UNat), is_directed A → ∃ x, is_lub A x. 61 | Proof. 62 | move=> A dir //=. 63 | exists (UNat_exists _ A). 64 | by apply: UNat_exists_is_lub. 65 | Qed. 66 | 67 | HB.instance Definition UNat_dcpo_axioms := DcpoOfPoset.Build UNat UNat_ltHasDLubs. 68 | 69 | Definition UNat_bot : UNat. 70 | Proof. by exists (λ _, False). Defined. 71 | 72 | Lemma UNat_bot_is_bot : is_bottom UNat_bot. 73 | Proof. by move=> ?. Qed. 74 | 75 | Lemma UNat_ltHasBot : ∃ x : UNat, is_bottom x. 76 | Proof. by exists UNat_bot; apply: UNat_bot_is_bot. Qed. 77 | 78 | Lemma UNat_ltHasTop : ∃ x : UNat, is_top x. 79 | Proof. 80 | by unshelve esplit; first by exists (λ _, True). 81 | Qed. 82 | 83 | HB.instance Definition UNat_pointed_poset_axioms := 84 | PointedPosetOfPoset.Build UNat UNat_ltHasBot. 85 | 86 | HB.instance Definition UNat_bounded_poset_axioms := 87 | BoundedPosetOfPointedPoset.Build UNat UNat_ltHasTop. 88 | 89 | Lemma UNat_lub_intro (A : Family UNat): ∀ u k ϕ, is_lub A ϕ → sval (A u) k → sval ϕ k. 90 | Proof. by move=>????; apply: (lub_is_ub A). Qed. 91 | 92 | Lemma UNat_lub_elim {P : UNat} {Q : nat → Prop} {A} (H : is_lub A P) : (∀ i k (z : sval (A i) k), Q k) → ∀ x (w : sval P x), Q x. 93 | Proof. 94 | move=> J K. 95 | rewrite -(lub_unique _ _ _ (UNat_exists_is_lub _) H). 96 | by case=> ?; apply: J. 97 | Qed. 98 | 99 | Lemma UNat_bot_elim : ∀ A, ∀ z : UNat_defd ⊥, A z. 100 | Proof. 101 | rewrite (_ : ⊥ = UNat_bot). 102 | - by apply/bottom_is_unique/UNat_bot_is_bot. 103 | - move=>? h. 104 | by exfalso; case: h. 105 | Qed. 106 | 107 | Lemma UNat_lub_elim_dep {P : UNat} {Q : ∀ x, sval P x → Prop} {A} (H : is_lub A P) : (∀ i k (z : sval (A i) k) w, Q k w) → ∀ x (w : sval P x), Q x w. 108 | Proof. 109 | move=> J K. 110 | have L := eq_sym (lub_unique _ _ _ (UNat_exists_is_lub _) H). 111 | dependent destruction L. 112 | case=> ? X. 113 | by apply/J/X. 114 | Qed. 115 | -------------------------------------------------------------------------------- /theories/WF.v: -------------------------------------------------------------------------------- 1 | From Domains Require Import Preamble Preorder Poset. 2 | 3 | HB.mixin Record HasWf A of Preorder A := 4 | {mem : A → A → Prop; 5 | memWf : well_founded mem; 6 | memLt : ∀ u v, mem u v → u ≤ v; 7 | memT : ∀ u v w, mem u v → mem v w → mem u w; 8 | memL : ∀ u v w, u ≤ v → mem v w → mem u w; 9 | memR : ∀ u v w, mem u v → v ≤ w → mem u w}. 10 | 11 | HB.structure Definition WfPreorder := {A of HasWf A & Preorder A}. 12 | HB.structure Definition WfPoset := {A of WfPreorder A & Poset A}. 13 | 14 | Infix "≺" := mem (at level 60) : preorder_scope. 15 | 16 | (** Let (K,k) be a pointed type and let A be a well-founded poset. Obviously A^K inherits the poset structure pointwise; I want to define a well-founded order on A^k "anchored" at k using the well-founded order on K; in other words, u ≺ v iff u k ≺ v k where k is the basepoint. *) 17 | Module AnchoredProductOrder. 18 | Section AnchoredProductOrder. 19 | Parameter K : Type. 20 | Parameter k : K. 21 | Parameter A : WfPoset.type. 22 | 23 | Definition multi := K → A. 24 | 25 | Definition multi_lt (u v : multi) := ∀ x, u x ≤ v x. 26 | 27 | Lemma multi_ltR : ∀ u, multi_lt u u. 28 | Proof. by move=>?. Qed. 29 | 30 | Lemma multi_ltT : ∀ u v w, multi_lt u v → multi_lt v w → multi_lt u w. 31 | Proof. 32 | move=> u v w uv vw x. 33 | apply: ltT. 34 | - by apply: uv. 35 | - by apply: vw. 36 | Qed. 37 | 38 | HB.instance Definition _ := PreorderOfType.Build multi multi_lt multi_ltR multi_ltT. 39 | 40 | Lemma multi_ltE : ∀ u v : multi, u ≤ v → v ≤ u → u = v. 41 | Proof. 42 | move=> u v uv vu. 43 | apply: depfunext=> x. 44 | by apply: ltE. 45 | Qed. 46 | 47 | HB.instance Definition _ := PosetOfPreorder.Build multi multi_ltE. 48 | 49 | Definition multi_mem (u v : multi) := (u k ≺ v k) ∧ u ≤ v. 50 | 51 | Lemma multi_memWf : well_founded multi_mem. 52 | Proof. 53 | move=> u. 54 | move e : (u k) => uk. 55 | move: uk u e. 56 | apply: (well_founded_induction memWf)=> ? ih ? e. 57 | constructor=>?[??]. 58 | apply: ih=>//=. 59 | by rewrite -e. 60 | Qed. 61 | 62 | Lemma multi_memLt : ∀ u v, multi_mem u v → u ≤ v. 63 | Proof. by move=>??; case. Qed. 64 | 65 | Lemma multi_memT : ∀ u v w, multi_mem u v → multi_mem v w → multi_mem u w. 66 | Proof. 67 | move=> u v w [uv1 uv2] [vw1 vw2]; split. 68 | - by apply: memT; eauto. 69 | - by apply: ltT; eauto. 70 | Qed. 71 | 72 | Lemma multi_memL : ∀ u v w, u ≤ v → multi_mem v w → multi_mem u w. 73 | Proof. 74 | move=> u v w uv [vw1 vw2]; split. 75 | - by apply: memL; eauto. 76 | - by apply: ltT; eauto. 77 | Qed. 78 | 79 | Lemma multi_memR : ∀ u v w, multi_mem u v → v ≤ w → multi_mem u w. 80 | Proof. 81 | move=> u v w [uv1 uv2] vw; split. 82 | - by apply: memR; eauto. 83 | - by apply: ltT; eauto. 84 | Qed. 85 | 86 | HB.instance Definition _ := HasWf.Build multi multi_mem multi_memWf multi_memLt multi_memT multi_memL multi_memR. 87 | End AnchoredProductOrder. 88 | End AnchoredProductOrder. 89 | --------------------------------------------------------------------------------