├── .dir-locals.el ├── .gitignore ├── .gitmodules ├── .travis.yml ├── LICENSE ├── Makefile ├── README.md ├── _CoqProject ├── etc └── ci │ ├── keep_alive.sh │ └── travis_keep_alive.sh └── src ├── Algebra ├── Category.v ├── Category │ ├── Cartesian.v │ ├── Functor.v │ ├── Monad.v │ ├── Setoid.v │ └── Type.v ├── FrameC.v ├── FreeLattice.v ├── OrderC.v ├── PreOrder.v ├── SetsC.v └── Sublocale.v ├── FormTopC ├── Approx.v ├── Cantor.v ├── Compact.v ├── Concrete.v ├── Cont.v ├── Discrete.v ├── FormTop.v ├── FormalSpace.v ├── IGSubspace.v ├── InfoBase.v ├── Join.v ├── Lift.v ├── Locale.v ├── MReal.v ├── Metric.v ├── NatInfty.v ├── Pattern.v ├── Product.v ├── Scott.v ├── Spaces │ ├── One.v │ └── PosUR.v ├── Subspace.v ├── Sum.v └── Truncate.v ├── Haskell ├── Shim.hs └── test.hs ├── Language ├── ContPL.v └── ContPLProps.v ├── Numbers ├── QFacts.v └── QPosFacts.v ├── StdLib.v ├── Types ├── Equiv.v ├── Finite.v ├── Iso.v ├── List.v ├── Setoid.v └── UIP.v └── clement └── SmallPowers.v /.dir-locals.el: -------------------------------------------------------------------------------- 1 | ;;; Directory Local Variables 2 | ;;; For more information see (info "(emacs) Directory Variables") 3 | 4 | ((coq-mode 5 | (coq-indent-proofstart . 0) 6 | (coq-smie-after-bolp-indentation . 0) 7 | (company-coq-dir-local-symbols . (("~>" . ?↝) ("<|" . ?◁))) 8 | . ((eval . (let* ((project-root (locate-dominating-file buffer-file-name "_CoqProject")) 9 | (dependencies-folder (expand-file-name "dependencies" project-root)) 10 | (coq-path (split-string (or (getenv "COQPATH") "") ":" t))) 11 | (unless (memql dependencies-folder coq-path) 12 | (setenv "COQPATH" (mapconcat #'identity (cons dependencies-folder coq-path) ":")))))))) 13 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | #Coq 2 | *.vo 3 | *.v.d 4 | *.glob 5 | 6 | Makefile.coq 7 | Makefile.coq.bak 8 | html/ 9 | 10 | #Emacs backup files 11 | .#* 12 | 13 | *~ 14 | \#*# 15 | 16 | #Latex 17 | *.bbl 18 | *.aux 19 | *.blg 20 | *.log 21 | *.synctex.gz 22 | *.toc 23 | *.out 24 | *.nav 25 | *.snm 26 | -------------------------------------------------------------------------------- /.gitmodules: -------------------------------------------------------------------------------- 1 | [submodule "corn"] 2 | path = dependencies/CoRN 3 | url = https://github.com/c-corn/corn 4 | -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | language: generic 2 | 3 | sudo: required 4 | 5 | dist: trusty 6 | 7 | addons: 8 | apt: 9 | sources: 10 | - avsm 11 | packages: 12 | - opam 13 | 14 | cache: 15 | apt: true 16 | directories: 17 | - $HOME/.opam 18 | 19 | env: 20 | # - COQ_VERSION="8.6" 21 | - COQ_VERSION="8.6.dev" 22 | - COQ_VERSION="dev" 23 | 24 | #matrix: 25 | # fast_finish: true 26 | # allow_failures: 27 | # - env: COQ_VERSION="8.6.dev" 28 | # - env: COQ_VERSION="dev" 29 | 30 | before_install: 31 | - export NJOBS=2 32 | - if ! [ -e .opam ]; then opam init -j ${NJOBS} --compiler=system -n -y; fi 33 | - opam switch coq-${COQ_VERSION} || opam switch install coq-${COQ_VERSION} --alias-of=system 34 | - opam switch coq-${COQ_VERSION} 35 | - eval $(opam config env) 36 | # - opam config var root 37 | # - opam install -j ${NJOBS} -y camlp5 ocamlfind 38 | - opam list 39 | - opam repo add coq-extra-dev https://coq.inria.fr/opam/extra-dev || true 40 | - opam repo add coq-core-dev https://coq.inria.fr/opam/core-dev || true 41 | - source ./etc/ci/travis_keep_alive.sh 42 | - opam install -j ${NJOBS} -y coq.${COQ_VERSION} coq-corn 43 | 44 | before_script: 45 | - uname -a 46 | 47 | script: make TIMED=1 -j2 48 | 49 | after_success: 50 | - kill $PID_KEEP_ALIVE 51 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | MIT License 2 | 3 | Copyright (c) 2017 Benjamin Sherman 4 | 5 | Permission is hereby granted, free of charge, to any person obtaining a copy 6 | of this software and associated documentation files (the "Software"), to deal 7 | in the Software without restriction, including without limitation the rights 8 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 9 | copies of the Software, and to permit persons to whom the Software is 10 | furnished to do so, subject to the following conditions: 11 | 12 | The above copyright notice and this permission notice shall be included in all 13 | copies or substantial portions of the Software. 14 | 15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 18 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 21 | SOFTWARE. 22 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | .PHONY: coq clean corn 2 | 3 | 4 | COQPATH?="${CURDIR}/dependencies" 5 | export COQPATH 6 | 7 | coq: Makefile.coq 8 | COQPATH=$(COQPATH) $(MAKE) -f Makefile.coq 9 | 10 | Makefile.coq: Makefile _CoqProject 11 | coq_makefile -f _CoqProject -o Makefile.coq 12 | 13 | corn: dependencies/CoRN 14 | $(MAKE) -C dependencies/CoRN 15 | 16 | clean:: Makefile.coq 17 | $(MAKE) -f Makefile.coq clean 18 | rm -f Makefile.coq 19 | 20 | install:: Makefile.coq 21 | $(MAKE) -f Makefile.coq install 22 | 23 | print-coqpath:: 24 | @echo "COQPATH=$$COQPATH" 25 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | A programming language for topology and probability in Coq. 2 | 3 | ## Building 4 | 5 | This project is aimed at Coq version 8.6. 6 | To build, run `make` at the base level of the project directory. 7 | 8 | ## Files 9 | 10 | ### Spec/ 11 | 12 | The "specification" for the continuous programming language, stated 13 | in terms of categories. 14 | 15 | - Category.v : Definition of categories and their properties 16 | - Cartesian monoidal categories (finite products) 17 | - Strong monads (e.g., measures and probability distributions) 18 | - Discrete.v : Discrete spaces 19 | - Every Coq type has an according discrete space, and every Coq function 20 | is a continuous map between the according discrete spaces 21 | - Sum.v : Sum spaces 22 | - The empty space, and binary sums (disjoint) unions of spaces 23 | - Lift.v : Lifted spaces 24 | - Given any space, adjoints a "bottom" element, which can be thought 25 | of as indicating non-termination. The bottom element is a generic point. 26 | Lifted spaces are compact because the new open set for the whole space 27 | must be in every open cover. This allows interpretation of 28 | general recursion. 29 | - Sierpinski.v : The Sierpisnski space 30 | - The Sierpinski space is homeomorphic to the lifting of unit. Perhaps 31 | I will end up defining it this way, but here it is specified as something 32 | on its own. 33 | - Stream.v : Infinite streams 34 | - Real.v : Real numbers 35 | - lower real numbers, non-negative lower-real numbers, 36 | non-located real numbers (upper and lower Dedekind cuts which may have 37 | an entire interval as a gap rather than just a point), 38 | and bona fide real numbers 39 | - Prob.v : Measure and probability spaces 40 | - Definition of open sets and abstraction from maps to the Sierpinski space 41 | - Measure, subprobability, and probability monads 42 | - way-underspecified coinflip distribution and normal distribution 43 | - probabilistic infinite streams 44 | 45 | ### FormTopC/ 46 | 47 | Computationally relevant definitions of formal topology and some 48 | constructions. 49 | 50 | ### Numbers/ 51 | - Qnn.v : Non-negative rational numbers 52 | - semiring (0, 1, addition, multiplication) 53 | - truncated subtraction 54 | 55 | - LPReal.v : Non-negative lower real numbers encoded as lower Dedekind cuts 56 | - semiring (0, 1, addition, multiplication) 57 | - indicators of logical propositions 58 | - supremum, min, max 59 | 60 | ## Algebra/ 61 | - FrameC.v : Computationally-relevant definitions of preorders, partial orders, semilattices, lattices, and frames 62 | - SetsC.v : Computationally-relevant definitions of subsets and notations 63 | - Sets.v : Computationally-irrelevant definitions of subsets and notations 64 | 65 | ### Base directory 66 | - Samplers.v : Random samplers 67 | - Definition of random samplers, proofs and constructions 68 | 69 | - Valuation.v (old, and full of lies!) 70 | - definition of valuations and continuous valuations 71 | - definition of simple functions, integration, and assumption 72 | of many facts about integration 73 | - operations for construction valuations: `unit`, `bind`, `join`, 74 | `map`, `product`, `restrict`, `inject` 75 | - attempted definition of measurability 76 | - supremum and fixpoint valuations, continuity of valuation functionals 77 | - principles for constructing and reasoning about 78 | finite and countable measures 79 | - examples: probabilistic choice, Bernoulli, binomial, geometric 80 | - example of Geom/Geom/1 queue system 81 | 82 | - Sample.v : Definition of random samplers 83 | - Samplers of the form `R -> R * A`, where we sample random values of `A` 84 | from a random seed `R` 85 | - Probability distributions over streams 86 | - Partial computations, partial valuations, and partial samplers 87 | 88 | - PDF.v : (Very incomplete) characterization of PDFs of measures relative 89 | to more standard measures 90 | 91 | ### Types/ 92 | 93 | Facts about types. In particular, facts about isomorphisms/equivalences of 94 | types, and characterization of finite types. 95 | 96 | ### FormTop/ (Old) 97 | 98 | Definitions of formal topology, but computationally relevant parts 99 | were hidden in Prop. 100 | 101 | ### Old 102 | - Prob.v, Prob2.v, Prob3.v : these files are old. They were three different 103 | attempts to encode probability in Coq. In Prob.v and Prob2.v, I was hoping 104 | to base everything off of the Cantor space, where everything is naturally 105 | sample-able. 106 | -------------------------------------------------------------------------------- /_CoqProject: -------------------------------------------------------------------------------- 1 | -R src/ Prob 2 | 3 | src/Types/Iso.v 4 | src/Types/Finite.v 5 | src/Types/Equiv.v 6 | src/Types/Setoid.v 7 | src/Types/List.v 8 | src/Types/UIP.v 9 | 10 | src/Numbers/QFacts.v 11 | src/Numbers/QPosFacts.v 12 | 13 | src/FormTopC/Approx.v 14 | src/FormTopC/Cantor.v 15 | # src/FormTopC/Compact.v 16 | src/FormTopC/Cont.v 17 | src/FormTopC/Discrete.v 18 | src/FormTopC/FormTop.v 19 | src/FormTopC/FormalSpace.v 20 | src/FormTopC/Product.v 21 | src/FormTopC/InfoBase.v 22 | # src/FormTopC/Join.v 23 | src/FormTopC/Lift.v 24 | src/FormTopC/Locale.v 25 | src/FormTopC/Metric.v 26 | src/FormTopC/MReal.v 27 | src/FormTopC/NatInfty.v 28 | src/FormTopC/Subspace.v 29 | src/FormTopC/IGSubspace.v 30 | src/FormTopC/Truncate.v 31 | src/FormTopC/Pattern.v 32 | src/FormTopC/Sum.v 33 | 34 | src/FormTopC/Spaces/One.v 35 | src/FormTopC/Spaces/PosUR.v 36 | 37 | src/Algebra/Category.v 38 | src/Algebra/FrameC.v 39 | src/Algebra/Sublocale.v 40 | src/Algebra/SetsC.v 41 | src/Algebra/OrderC.v 42 | src/Algebra/PreOrder.v 43 | src/Algebra/FreeLattice.v 44 | 45 | src/Algebra/Category/Type.v 46 | src/Algebra/Category/Setoid.v 47 | src/Algebra/Category/Functor.v 48 | src/Algebra/Category/Cartesian.v 49 | src/Algebra/Category/Monad.v 50 | 51 | src/Language/ContPL.v 52 | # src/Language/ContPLProps.v 53 | 54 | src/clement/SmallPowers.v 55 | 56 | src/StdLib.v 57 | -------------------------------------------------------------------------------- /etc/ci/keep_alive.sh: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env bash 2 | 3 | while [ 1 ] 4 | do 5 | echo "" 6 | echo "Travis keep-alive spew" 7 | sleep 5m 8 | done 9 | -------------------------------------------------------------------------------- /etc/ci/travis_keep_alive.sh: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env bash 2 | 3 | # in case we're run from out of git repo 4 | DIR="$( cd "$( dirname "${BASH_SOURCE[0]}" )" && pwd )" 5 | 6 | "$DIR"/keep_alive.sh & export PID_KEEP_ALIVE=$! 7 | -------------------------------------------------------------------------------- /src/Algebra/Category.v: -------------------------------------------------------------------------------- 1 | Set Universe Polymorphism. 2 | 3 | (** I will try to use the same names for the operations 4 | that there are in Coq *) 5 | Require Import 6 | CRelationClasses 7 | CMorphisms 8 | Types.Setoid. 9 | 10 | Reserved Notation "a ~~> b" (at level 75). 11 | Reserved Notation "a == b" (at level 70, no associativity). 12 | Reserved Notation "g ∘ f" (at level 40, left associativity). 13 | 14 | Local Open Scope setoid. 15 | 16 | Record Category@{Ob Arr P} := 17 | { Ob :> Type@{Ob} 18 | ; arrow : Ob -> Ob -> Setoid@{Arr P} where "a ~~> b" := (arrow a b) 19 | ; id : forall {A}, A ~~> A 20 | ; compose : forall {A B C}, B ~~> C -> A ~~> B -> A ~~> C where "g ∘ f" := (compose g f) 21 | ; compose_proper : forall {A B C} (f f' : A ~~> B) (g g' : B ~~> C), 22 | g == g' -> f == f'-> g ∘ f == g' ∘ f' 23 | ; compose_id_left : forall {A B} (f : A ~~> B), id ∘ f == f 24 | ; compose_id_right : forall {A B} (f : A ~~> B), f ∘ id == f 25 | ; compose_assoc : forall {A B C D} (f : A ~~> B) (g : B ~~> C) (h : C ~~> D), h ∘ (g ∘ f) == (h ∘ g) ∘ f 26 | }. 27 | 28 | Arguments arrow {c} A B. 29 | Arguments id {c A}. 30 | Arguments compose {c A B C} f g. 31 | Arguments compose_id_left {c A B} f. 32 | Arguments compose_id_right {c A B} f. 33 | 34 | (** Notation for objects of categories *) 35 | Delimit Scope obj_scope with obj. 36 | Local Open Scope obj. 37 | Infix "~~>" := (arrow) (at level 75) : obj_scope. 38 | Notation "a ~~>[ X ] b" := (arrow (c := X) a b) (at level 75, format "a ~~>[ X ] b") : obj_scope. 39 | 40 | Delimit Scope morph_scope with morph. 41 | Local Open Scope morph. 42 | 43 | Infix "∘" := (compose) (at level 40, left associativity) : morph_scope. 44 | 45 | Notation "g ∘[ X ] f" := (compose (c := X) g f) 46 | (at level 75, format "g ∘[ X ] f", only parsing) : morph_scope. 47 | 48 | Ltac prove_map_Proper := unfold Proper, respectful; intros; 49 | repeat match goal with 50 | | [ H : (_ == _)%morph |- (_ == _)%morph ] => rewrite H; clear H 51 | end; try reflexivity. 52 | 53 | Require Coq.Setoids.Setoid. 54 | Global Instance compose_Proper {U : Category} : forall A B C : U, 55 | Proper (seq (B ~~> C) ==> seq (A ~~> B) ==> seq (A ~~> C)) compose. 56 | Proof. 57 | intros. unfold Proper, respectful. 58 | intros. apply compose_proper; assumption. 59 | Qed. 60 | 61 | Section Defns. 62 | Context {U : Category}. 63 | 64 | Definition Mono {A B : U} (f : A ~~> B) := 65 | forall X (g1 g2 : X ~~> A), f ∘ g1 == f ∘ g2 -> g1 == g2. 66 | 67 | Definition Epi {A B : U} (f : B ~~> A) := 68 | forall X (g1 g2 : A ~~> X), g1 ∘ f == g2 ∘ f -> g1 == g2. 69 | 70 | Lemma Mono_Proper : forall {A B}, Proper (seq _ ==> iffT) (Mono (A:=A) (B:=B)). 71 | Proof. 72 | intros. unfold Proper, respectful. intros. 73 | split. 74 | - intros Mx. unfold Mono; intros. 75 | apply Mx. rewrite X. assumption. 76 | - intros My. 77 | unfold Mono; intros. apply My. rewrite <- X. assumption. 78 | Qed. 79 | 80 | Lemma Mono_Compose : forall {A B C} {f : A ~~> B} {g : B ~~> C}, 81 | Mono f -> Mono g -> Mono (g ∘ f). 82 | Proof. 83 | intros A B C f g Mf Mg. 84 | unfold Mono; intros X h1 h2 H. 85 | rewrite <- !compose_assoc in H. 86 | apply Mg in H. apply Mf in H. exact H. 87 | Qed. 88 | 89 | Record Iso {A B : U} : Type := 90 | { to : A ~~> B 91 | ; from : B ~~> A 92 | ; to_from : to ∘ from == id 93 | ; from_to : from ∘ to == id 94 | }. 95 | 96 | End Defns. 97 | 98 | Arguments Iso {U} A B. 99 | 100 | Infix "≅" := Iso (at level 70, no associativity) : obj_scope. 101 | 102 | Ltac remove_eq_left := 103 | repeat rewrite <- compose_assoc; repeat (apply compose_Proper; try reflexivity). 104 | Ltac remove_eq_right := 105 | repeat rewrite compose_assoc; repeat (apply compose_Proper; try reflexivity). 106 | 107 | Section Iso_Props. 108 | 109 | Universes Ob Arr P. 110 | Context {U : Category@{Ob Arr P}}. 111 | 112 | Lemma Iso_Mono : forall {A B : U} (x : A ≅ B), Mono (to x). 113 | Proof. 114 | intros A B x. destruct x as [f g fg gf]. 115 | simpl. unfold Mono. 116 | intros X h k fhfk. 117 | rewrite <- (compose_id_left h), <- (compose_id_left k). 118 | rewrite <- !gf. 119 | rewrite <- !compose_assoc. 120 | apply compose_Proper; try reflexivity; try assumption. 121 | Qed. 122 | 123 | Lemma Iso_Epi : forall {A B : U} (x : A ≅ B), Epi (to x). 124 | Proof. 125 | intros A B x. destruct x as [f g fg gf]. 126 | simpl. unfold Epi. 127 | intros X h k fhfk. 128 | rewrite <- (compose_id_right h), <- (compose_id_right k). 129 | rewrite <- !fg. 130 | rewrite -> !compose_assoc. 131 | apply compose_Proper; try reflexivity; try assumption. 132 | Qed. 133 | 134 | Lemma Iso_Refl {A : U} : A ≅ A. 135 | Proof. 136 | refine ( {| to := id ; from := id |}); 137 | apply compose_id_left. 138 | Defined. 139 | 140 | Definition Iso_Sym {A B : U} (i : A ≅ B) : B ≅ A := 141 | {| to := from i 142 | ; from := to i 143 | ; to_from := from_to i 144 | ; from_to := to_from i 145 | |}. 146 | 147 | Lemma Iso_Trans {A B C : U} (ab : A ≅ B) (bc : B ≅ C) : A ≅ C. 148 | Proof. 149 | unshelve eapply ({| to := to bc ∘ to ab 150 | ; from := from ab ∘ from bc |}). 151 | - rewrite <- compose_assoc. 152 | rewrite (compose_assoc _ (from bc)). 153 | rewrite to_from. rewrite compose_id_left. 154 | apply to_from. 155 | - rewrite <- compose_assoc. 156 | rewrite (compose_assoc _ (to ab)). 157 | rewrite from_to. rewrite compose_id_left. 158 | apply from_to. 159 | Defined. 160 | 161 | Lemma Hom_Setoid_Iso {A A' B B' : U} 162 | (a : A ≅ A') (b : B ≅ B') 163 | : Setoid.Iso (A ~~> B) (A' ~~> B'). 164 | Proof. 165 | unshelve econstructor; simpl. 166 | - unshelve econstructor. 167 | + exact (fun f => to b ∘ f ∘ from a). 168 | + unfold Proper, respectful. intros x y H. 169 | rewrite H; reflexivity. 170 | - unshelve econstructor. 171 | + exact (fun f => from b ∘ f ∘ to a). 172 | + unfold Proper, respectful. intros x y H. 173 | rewrite H; reflexivity. 174 | - simpl. intros. rewrite !compose_assoc. 175 | rewrite (to_from b). rewrite compose_id_left. 176 | rewrite <- compose_assoc. rewrite to_from. 177 | apply compose_id_right. 178 | - simpl. intros. rewrite !compose_assoc. 179 | rewrite from_to. rewrite compose_id_left. 180 | rewrite <- compose_assoc. rewrite from_to. 181 | apply compose_id_right. 182 | Defined. 183 | 184 | End Iso_Props. 185 | 186 | Record ExistsUnique {A : Setoid} {B : A -> Type} := 187 | { proj1_EU : A 188 | ; proj2_EU : B proj1_EU 189 | ; unique_EU : forall a : A, B a -> a == proj1_EU 190 | }. 191 | 192 | Arguments ExistsUnique {A} B. 193 | 194 | Section Objects. 195 | Context {U : Category}. 196 | 197 | Record Is_Product {Ix : Type} {F : Ix -> U} {Prod : U} := 198 | { Product_proj : forall ix, Prod ~~> F ix 199 | ; Product_least : forall (X : U) (projX : forall ix, X ~~> F ix), 200 | ExistsUnique (fun univ : X ~~> Prod => 201 | forall ix, projX ix == Product_proj ix ∘ univ) 202 | }. 203 | 204 | Arguments Is_Product {Ix} F Prod. 205 | 206 | Definition Is_Binary_Product (A B : U) : U -> Type := 207 | Is_Product (fun b : bool => if b then A else B). 208 | 209 | Definition Is_Terminal_Object : U -> Type := 210 | Is_Product (Empty_set_rect _). 211 | 212 | End Objects. 213 | 214 | Arguments Is_Product {U Ix} F Prod. 215 | -------------------------------------------------------------------------------- /src/Algebra/Category/Cartesian.v: -------------------------------------------------------------------------------- 1 | Require Import 2 | CMorphisms 3 | Types.Setoid 4 | Algebra.Category. 5 | 6 | Set Universe Polymorphism. 7 | 8 | Local Open Scope obj. 9 | Local Open Scope morph. 10 | Local Open Scope setoid. 11 | 12 | Class Cartesian {U : Category} : Type := 13 | { unit : U 14 | ; BProd : U -> U -> U 15 | ; unit_Is_Terminal : Is_Terminal_Object unit 16 | ; BProd_Is_Binary_Product : 17 | forall A B, Is_Binary_Product A B (BProd A B) 18 | }. 19 | 20 | Arguments Cartesian : clear implicits. 21 | 22 | Infix "*" := BProd : obj_scope. 23 | 24 | Section CartesianOps. 25 | Context {U} {CU : Cartesian U}. 26 | 27 | Definition tt {Γ} : Γ ~~> unit. 28 | Proof. 29 | pose proof (Product_least (unit_Is_Terminal)). 30 | specialize (X Γ (Empty_set_rect _)). 31 | apply X. 32 | Defined. 33 | 34 | Definition fst {A B} : A * B ~~> A 35 | := (Product_proj (BProd_Is_Binary_Product A B) true). 36 | 37 | Definition snd {A B} : A * B ~~> B 38 | := (Product_proj (BProd_Is_Binary_Product A B) false). 39 | 40 | Definition pair {Γ A B : U} (f : Γ ~~> A) (g : Γ ~~> B) 41 | : Γ ~~> A * B. 42 | Proof. 43 | pose proof (Product_least 44 | (BProd_Is_Binary_Product A B) Γ). 45 | simpl in X. 46 | specialize (X (fun b : bool => match b as b' return 47 | Γ ~~> (if b' then A else B) with 48 | | true => f 49 | | false => g 50 | end)). 51 | simpl in X. 52 | apply X. 53 | Defined. 54 | 55 | 56 | Global Instance pair_Proper {Γ A B : U} 57 | : Proper (seq _ ==> seq _ ==> seq _)%signature 58 | (@pair Γ A B). 59 | Proof. 60 | Admitted. 61 | 62 | End CartesianOps. 63 | 64 | Notation "⟨ f , g ⟩" := (pair f g) : morph_scope. 65 | 66 | Section MoreCartesianOps. 67 | Context {U} {CU : Cartesian U}. 68 | 69 | Lemma pair_fst : forall {A B C} (f : A ~~> B) (g : A ~~> C), fst ∘ ⟨f, g⟩ == f. 70 | Proof. 71 | Admitted. 72 | 73 | Lemma pair_snd : forall {A B C} (f : A ~~> B) (g : A ~~> C), snd ∘ ⟨f, g⟩ == g. 74 | Proof. 75 | Admitted. 76 | 77 | Lemma unit_uniq : forall {A} (h k : A ~~> unit), h == k. 78 | Proof. 79 | Admitted. 80 | 81 | Definition parallel {A B C D : U} 82 | (f : A ~~> B) (g : C ~~> D) : A * C ~~> B * D := 83 | ⟨ f ∘ fst , g ∘ snd ⟩. 84 | 85 | Local Infix "⊗" := parallel (at level 25) : morph_scope. 86 | 87 | Definition add_unit_left {A : U} : A ~~> unit * A 88 | := ⟨tt, id⟩. 89 | 90 | Definition add_unit_right {A : U} : A ~~> A * unit 91 | := ⟨id, tt⟩. 92 | 93 | Definition prod_assoc_left {A B C : U} 94 | : A * (B * C) ~~> (A * B) * C := 95 | ⟨id ⊗ fst, snd ∘ snd⟩. 96 | 97 | Definition prod_assoc_right {A B C : U} 98 | : (A * B) * C ~~> A * (B * C) := 99 | ⟨fst ∘ fst, snd ⊗ id⟩. 100 | 101 | Lemma pair_uniq : forall {A B C} (h : A ~~> B * C), h == ⟨fst ∘ h, snd ∘ h⟩. 102 | Proof. 103 | Admitted. 104 | 105 | Theorem proj_eq : forall {A B C : U} {f f' : A ~~> B * C}, 106 | (fst ∘ f) == (fst ∘ f') -> (snd ∘ f == snd ∘ f') -> f == f'. 107 | Proof. 108 | intros A B C f f' Hfst Hsnd. 109 | rewrite (pair_uniq f). rewrite (pair_uniq f'). 110 | rewrite Hfst, Hsnd. reflexivity. 111 | Defined. 112 | 113 | Lemma pair_f : forall {A B C D : U} (f : A ~~> B) (h : B ~~> C) (k : B ~~> D), 114 | ⟨h, k⟩ ∘ f == ⟨h ∘ f, k ∘ f⟩. 115 | Proof. 116 | intros A B C D f h k. apply proj_eq. 117 | - rewrite pair_fst, compose_assoc, pair_fst. reflexivity. 118 | - rewrite pair_snd, compose_assoc, pair_snd. reflexivity. 119 | Defined. 120 | 121 | Lemma parallel_compose {A B C A' B' C'} 122 | (f' : A ~~> B) (f : B ~~> C) (g' : A' ~~> B') (g : B' ~~> C') : 123 | f ⊗ g ∘ f' ⊗ g' == (f ∘ f') ⊗ (g ∘ g'). 124 | Proof. 125 | unfold parallel. rewrite pair_f. 126 | apply pair_Proper; rewrite <- !compose_assoc; 127 | (apply compose_Proper; [ reflexivity |]). 128 | rewrite pair_fst. reflexivity. 129 | rewrite pair_snd. reflexivity. 130 | Qed. 131 | 132 | Theorem unit_isom_left : forall {A : U}, (unit * A) ≅ A. 133 | Proof. 134 | intros A. unshelve eapply 135 | (Build_Iso (unit * A) A snd ⟨tt, id⟩ _ _). 136 | - rewrite pair_snd. reflexivity. 137 | - apply proj_eq. 138 | + apply unit_uniq. 139 | + rewrite compose_id_right. rewrite compose_assoc. 140 | rewrite pair_snd. rewrite compose_id_left. 141 | reflexivity. 142 | Defined. 143 | 144 | Theorem unit_isom_right : forall {A : U}, (A * unit) ≅ A. 145 | Proof. 146 | intros A. unshelve eapply 147 | (Build_Iso (A * unit) A fst ⟨id, tt⟩ _ _). 148 | - rewrite pair_fst. reflexivity. 149 | - apply proj_eq. 150 | + rewrite compose_id_right. rewrite compose_assoc. 151 | rewrite pair_fst. rewrite compose_id_left. 152 | reflexivity. 153 | + apply unit_uniq. 154 | Defined. 155 | 156 | Lemma pair_id {A B : U} : 157 | ⟨ fst, snd ⟩ == id (A := A * B). 158 | Proof. 159 | rewrite (pair_uniq id). 160 | rewrite !compose_id_right. reflexivity. 161 | Qed. 162 | 163 | 164 | Lemma parallel_pair : forall {A B C D E : U} (f : A ~~> B) (g : A ~~> C) (h : B ~~> D) (k : C ~~> E), (h ⊗ k) ∘ ⟨f, g⟩ == ⟨h ∘ f, k ∘ g⟩. 165 | Proof. 166 | intros A B C D E f g h k. 167 | unfold parallel. apply proj_eq. 168 | - rewrite compose_assoc. rewrite pair_fst, pair_fst. 169 | rewrite <- compose_assoc. rewrite pair_fst. reflexivity. 170 | - rewrite compose_assoc. rewrite pair_snd, pair_snd. 171 | rewrite <- compose_assoc. rewrite pair_snd. reflexivity. 172 | Defined. 173 | 174 | 175 | Lemma parallel_fst : forall {A B C D : U} (f : A ~~> B) (g : C ~~> D), 176 | fst ∘ (f ⊗ g) == f ∘ fst. (* Have I already proven this somewhere else maybe? *) 177 | Proof. 178 | intros A B C D f g. 179 | unfold parallel. 180 | rewrite pair_fst. 181 | reflexivity. 182 | Qed. 183 | 184 | Lemma parallel_snd : forall {A B C D : U} (f : A ~~> B) (g : C ~~> D), 185 | snd ∘ (f ⊗ g) == g ∘ snd. 186 | Proof. 187 | intros A B C D f g. 188 | unfold parallel. 189 | rewrite pair_snd. 190 | reflexivity. 191 | Qed. 192 | 193 | Lemma parallel_id A B 194 | : id (A := A) ⊗ id (A := B) == id. 195 | Proof. 196 | unfold parallel. rewrite !compose_id_left. 197 | apply pair_id. 198 | Qed. 199 | 200 | Theorem parallel_proper : forall {A B C D} (f f' : A ~~> B) (g g' : C ~~> D), 201 | f == f' -> g == g' -> parallel f g == parallel f' g'. 202 | Proof. 203 | intros A B C D f f' g g' ff' gg'. 204 | unfold parallel. rewrite ff', gg'. reflexivity. 205 | Qed. 206 | 207 | Definition diagonal {A : U} : A ~~> A * A := ⟨ id , id ⟩. 208 | Definition swap {A B : U} : A * B ~~> B * A := ⟨snd, fst⟩. 209 | 210 | Global Instance parallel_Proper : forall A B C D : U, 211 | Proper (seq (A ~~> B) ==> seq (C ~~> D) ==> seq _) parallel. 212 | Proof. 213 | intros. unfold Proper, respectful. 214 | intros. apply parallel_proper; assumption. 215 | Qed. 216 | 217 | Lemma Iso_Prod {A B A' B'} (a : A ≅ A') (b : B ≅ B') 218 | : A * B ≅ A' * B'. 219 | Proof. 220 | refine ( 221 | {| to := to a ⊗ to b 222 | ; from := from a ⊗ from b 223 | |} 224 | ); rewrite parallel_compose. 225 | rewrite !to_from. apply parallel_id. 226 | rewrite !from_to. apply parallel_id. 227 | Defined. 228 | 229 | End MoreCartesianOps. 230 | 231 | Infix "⊗" := parallel (at level 25) : morph_scope. 232 | -------------------------------------------------------------------------------- /src/Algebra/Category/Functor.v: -------------------------------------------------------------------------------- 1 | Require Import 2 | Types.Setoid 3 | Algebra.Category. 4 | 5 | Set Universe Polymorphism. 6 | 7 | Local Open Scope obj. 8 | Local Open Scope morph. 9 | Local Open Scope setoid. 10 | 11 | Require Import Morphisms. 12 | 13 | Section Functor. 14 | 15 | Context {C D : Category}. 16 | 17 | Record Functor : Type := Build_Functor 18 | { fobj :> C -> D 19 | ; fmap : forall {A B : C}, function (A ~~> B) (fobj A ~~> fobj B) 20 | ; fmap_id : forall {A : C}, fmap (id : A ~~> A) == id 21 | ; fmap_compose : forall {X Y Z : C} (f : X ~~> Y) (g : Y ~~> Z), 22 | fmap (g ∘ f) == fmap g ∘ fmap f 23 | }. 24 | 25 | Record NatTrans (F G : Functor) := 26 | { nattrans :> forall (A : C), F A ~~> G A 27 | ; nattrans_ok : forall A B (ext : A ~~> B), 28 | fmap G ext ∘ nattrans A == nattrans B ∘ fmap F ext 29 | }. 30 | 31 | End Functor. 32 | 33 | Arguments Functor C D : clear implicits. 34 | 35 | Definition id_Functor {C : Category} : Functor C C. 36 | Proof. 37 | unshelve econstructor. 38 | - exact (fun x => x). 39 | - simpl. intros. apply Setoid.id. 40 | - simpl. intros; reflexivity. 41 | - simpl. intros; reflexivity. 42 | Defined. 43 | 44 | Delimit Scope cat_scope with cat. 45 | Local Open Scope cat. 46 | 47 | Infix "==>" := Functor (at level 55, right associativity) : cat_scope. 48 | 49 | Delimit Scope functor_scope with functor. 50 | Local Open Scope functor. 51 | 52 | Definition compose_Functor {C D E : Category} 53 | (G : D ==> E) (F : C ==> D) 54 | : C ==> E. 55 | Proof. 56 | unshelve econstructor. 57 | - exact (fun x => G (F x)). 58 | - intros. apply (fmap G ∘ fmap F)%setoidc. 59 | - intros. simpl. rewrite !fmap_id. reflexivity. 60 | - simpl. intros. rewrite !fmap_compose. reflexivity. 61 | Defined. 62 | 63 | Infix "∘" := compose_Functor : functor_scope. 64 | 65 | Definition Faithful {C D} (F : C ==> D) := 66 | forall (A B : C) (f g : A ~~> B), fmap F f == fmap F g -> f == g. 67 | 68 | Definition Full {C D} (F : C ==> D) := 69 | forall (A B : C) (f : F A ~~> F B), 70 | sigT (fun f' : A ~~> B => f == fmap F f'). 71 | 72 | (** Probably not strong enough *) 73 | Record Adjunction {C D : Category} 74 | {F : Functor C D} {G : Functor D C} : Type := 75 | { Adj_Hom_Iso : forall A B, ((A ~~> G B)%obj ≅ (F A ~~> B)%obj)%setoidc 76 | ; commutes : 77 | forall {A A' B B'} (f : A' ~~> A) (g : B ~~> B') 78 | (x : F A ~~> B), 79 | (Setoid.from (Adj_Hom_Iso _ _) (g ∘ x ∘ fmap F f) 80 | == fmap G g ∘ Setoid.from (Adj_Hom_Iso _ _) x ∘ f)%morph 81 | }. 82 | 83 | Arguments Adjunction {C D} F G. 84 | 85 | Infix "-|" := Adjunction (at level 30) : functor_scope. 86 | 87 | Lemma compose_Adjunction 88 | {C D E : Category} 89 | {F : Functor C D} {G : Functor D C} 90 | {F' : Functor D E} {G' : Functor E D} 91 | : F -| G -> F' -| G' -> (F' ∘ F) -| (G ∘ G'). 92 | Proof. 93 | intros. unshelve econstructor. 94 | - intros. eapply Setoid.Iso_Trans. simpl in *. 95 | eapply X. simpl. eapply X0. 96 | - simpl. intros. etransitivity. 97 | Focus 2. apply commutes. 98 | apply sf_proper. apply commutes. 99 | Defined. -------------------------------------------------------------------------------- /src/Algebra/Category/Monad.v: -------------------------------------------------------------------------------- 1 | Require Import 2 | Types.Setoid 3 | Algebra.Category 4 | Algebra.Category.Cartesian. 5 | 6 | Set Universe Polymorphism. 7 | 8 | Local Open Scope obj. 9 | Local Open Scope morph. 10 | Local Open Scope setoid. 11 | 12 | (** Strong monads for cartesian monoidal categories *) 13 | Class SMonad {U : Category} {UC : Cartesian U} {M : U -> U} : Type := 14 | { ret : forall {A}, A ~~> M A 15 | ; map : forall {A B}, Setoid.function (A ~~> B) (M A ~~> M B) 16 | ; strong : forall {A B}, A * M B ~~> M (A * B) 17 | ; join : forall {A}, M (M A) ~~> M A 18 | }. 19 | 20 | Arguments SMonad U {_} M. 21 | 22 | Notation "A -[ f ]-> B" := (f%morph : (arrow A%obj B%obj)) (at level 60) 23 | : morph_scope. 24 | 25 | 26 | 27 | (** See https://ncatlab.org/nlab/show/strong+monad#alternative_definition 28 | *) 29 | Class SMonad_Props {U : Category} {UC : Cartesian U} {M : U -> U} 30 | {smd : SMonad U M} : Type := 31 | { map_compose : forall {A B C} (f : A ~~> B) (g : B ~~> C), map (g ∘ f) == (map g) ∘ (map f) 32 | ; map_id : forall {A}, map (id (A := A)) == id (A := (M A)) 33 | ; ret_nat : forall {A B : U} (f : A ~~> B), ret ∘ f == (map f) ∘ ret 34 | ; join_nat : forall {A B : U} (f : A ~~> B), (map f) ∘ join == join ∘ (map (map f)) 35 | ; join_map_ret : forall {A : U}, join ∘ (map (ret(A:=A))) = id 36 | ; join_ret : forall {A : U}, join ∘ (ret(A:=(M A))) = id 37 | ; join_join : forall {A : U}, join (A:=A) ∘ map join == join ∘ join 38 | ; strength_unit : forall {A}, 39 | (unit * M A) -[ strong ]-> M (unit * A) 40 | == map add_unit_left ∘ snd 41 | ; strength_compose : forall {A B C}, 42 | (A * (B * M C)) -[strong ∘ (id ⊗ strong)]-> (M (A * (B * C))) 43 | == map prod_assoc_right ∘ strong ∘ prod_assoc_left 44 | ; strength_ret : forall {A B}, 45 | strong ∘ (id ⊗ ret) == 46 | (A * B) -[ ret ]-> (M (A * B)) 47 | ; strength_join : forall {A B}, 48 | strong ∘ ((A * M (M B)) -[ id ⊗ join ]-> (A * M B)) 49 | == 50 | join ∘ map strong ∘ strong 51 | ; strong_nat : forall {A A' B B'} (f : A ~~> A') (g : B ~~> B'), strong ∘ (f ⊗ (map g)) == map (f ⊗ g) ∘ strong 52 | ; snd_strong : forall {A B}, (map snd) ∘ (strong (A:=A)(B:=B)) == snd (* Maybe provable from other axioms? *) 53 | }. 54 | 55 | Require Import CMorphisms. 56 | Global Instance map_Proper `{SMonad_Props} : forall A B : U, 57 | Proper (seq (A ~~> B) ==> seq _) map. 58 | Proof. 59 | intros. unfold Proper, respectful. 60 | intros. apply sf_proper; assumption. 61 | Qed. 62 | 63 | Section Basic_SMonad_Props. 64 | Require Coq.Setoids.Setoid. 65 | Context {U} {CU : Cartesian U} {M} 66 | {smd : SMonad U M} {smp : @SMonad_Props U _ M smd}. 67 | 68 | Theorem M_iso : forall {A B : U}, (A ≅ B) -> ((M A) ≅ (M B)). 69 | Proof. 70 | intros A B s. unshelve eapply 71 | (Build_Iso (M A) (M B) (map (to s)) (map (from s))). 72 | - rewrite <- map_compose. rewrite (to_from s). 73 | rewrite map_id. reflexivity. 74 | - rewrite <- map_compose. rewrite (from_to s). 75 | rewrite map_id. reflexivity. 76 | Defined. 77 | 78 | 79 | Definition emap {Γ A B : U} (f : Γ * A ~~> B) : Γ * (M A) ~~> M B := 80 | (map f) ∘ strong. 81 | 82 | Global Instance emap_Proper : forall Γ A B : U, 83 | Proper (seq (Γ * A ~~> B) ==> seq _) emap. 84 | Proof. 85 | unfold emap. prove_map_Proper. 86 | Qed. 87 | 88 | End Basic_SMonad_Props. -------------------------------------------------------------------------------- /src/Algebra/Category/Setoid.v: -------------------------------------------------------------------------------- 1 | Require Import 2 | CMorphisms 3 | Algebra.Category 4 | Types.Setoid. 5 | 6 | Set Universe Polymorphism. 7 | 8 | Local Open Scope setoid. 9 | 10 | (** The universe of level i types lives in 11 | Type i', where i < i'. *) 12 | Definition SetoidC@{A P A'} : Category@{A' A P}. 13 | Proof. 14 | unshelve eapply ( 15 | Build_Category@{A' A P} Setoid@{A P} function@{A P}) 16 | ; simpl; auto. 17 | - intros A. exact id. 18 | - intros A B C. exact compose. 19 | - simpl. intros. auto. 20 | - simpl. intros. apply sf_proper. assumption. 21 | - simpl. intros. apply sf_proper. assumption. 22 | - simpl. intros. apply h. apply g. apply f. assumption. 23 | Defined. 24 | 25 | Definition Pi {A} (B : A -> Type) := forall a, B a. 26 | 27 | 28 | Definition Product {Ix} (F : Ix -> SetoidC) 29 | : SetoidC. 30 | Proof. 31 | unshelve econstructor. 32 | - exact (Pi F). 33 | - exact (fun x y => forall ix, x ix == y ix). 34 | - constructor; unfold Reflexive, Symmetric, Transitive; 35 | simpl; intros. 36 | + reflexivity. 37 | + symmetry. auto. 38 | + etransitivity; eauto. 39 | Defined. 40 | 41 | Definition Has_Products {Ix : Type} (F : Ix -> SetoidC) 42 | : Is_Product F (Product F). 43 | Proof. 44 | unshelve econstructor. 45 | - simpl. intros. unshelve econstructor. 46 | + auto. 47 | + simpl. auto. 48 | - simpl. intros. unshelve econstructor. 49 | + unshelve econstructor. 50 | * intros. simpl. unfold Pi. intros ix. 51 | apply projX. assumption. 52 | * simpl. intros. apply sf_proper. assumption. 53 | + simpl. intros. apply sf_proper. assumption. 54 | + simpl. intros. symmetry. apply X0. symmetry. assumption. 55 | Defined. 56 | 57 | Require Import 58 | Category.Type 59 | Category.Functor. 60 | 61 | Local Open Scope cat. 62 | 63 | Definition Type_Setoid : TypeC ==> SetoidC. 64 | Proof. 65 | unshelve econstructor. 66 | - exact Leib.Leibniz. 67 | - simpl. intros. unshelve econstructor. 68 | + simpl. intros. apply Leib.Leibniz_func. assumption. 69 | + simpl. intros. subst. auto. 70 | - simpl. auto. 71 | - simpl. intros. subst. auto. 72 | Defined. 73 | 74 | Lemma Type_Setoid_Faithful : Faithful Type_Setoid. 75 | Proof. 76 | unfold Faithful. simpl. auto. 77 | Qed. 78 | 79 | Lemma Type_Setoid_Full : Full Type_Setoid. 80 | Proof. 81 | unfold Full. simpl. intros. 82 | exists f. intros. f_equal. assumption. 83 | Qed. 84 | 85 | Require Import Algebra.SetsC. 86 | 87 | Set Printing Universes. 88 | 89 | Definition Powerset@{A P AP AP'} (A : Setoid@{A P}) : Setoid@{AP' AP}. 90 | Proof. 91 | unshelve econstructor. 92 | exact (Subset@{A P} A). 93 | - exact (Same_set@{A P AP}). 94 | - typeclasses eauto. 95 | Defined. -------------------------------------------------------------------------------- /src/Algebra/Category/Type.v: -------------------------------------------------------------------------------- 1 | Require Import 2 | Algebra.Category 3 | Types.Setoid. 4 | 5 | Set Universe Polymorphism. 6 | 7 | Definition function@{A P} (A B : Type@{A}) : Setoid@{A P}. 8 | Proof. 9 | unshelve eapply ( 10 | {| sty := A -> B 11 | ; seq := fun f g => forall x, f x = g x 12 | |}). 13 | constructor; auto. 14 | unfold CRelationClasses.Transitive. 15 | intros. transitivity (y x0); auto. 16 | Defined. 17 | 18 | (** The universe of level i types lives in 19 | Type i', where i < i'. *) 20 | Definition TypeC@{i P i'} : Category@{i' i' P}. 21 | Proof. 22 | unshelve eapply ( 23 | Build_Category@{i' i' P} Type@{i} function@{i' P}) 24 | ; simpl; auto. 25 | simpl. intros. transitivity (g' (f x)); auto. 26 | f_equal. apply H0. 27 | Defined. 28 | 29 | Definition Pi {A} (B : A -> Type) := forall a, B a. 30 | 31 | Definition Has_Products {Ix : Type} (F : Ix -> TypeC) 32 | : Is_Product F (Pi F). 33 | Proof. 34 | unshelve econstructor. 35 | - simpl. intros. apply X. 36 | - simpl. intros. 37 | exists (fun x ix => projX ix x). reflexivity. 38 | simpl. intros. 39 | (* Looks like we need functional extensionality... *) 40 | Abort. -------------------------------------------------------------------------------- /src/Algebra/FreeLattice.v: -------------------------------------------------------------------------------- 1 | Require Import 2 | Algebra.SetsC 3 | Algebra.OrderC 4 | Algebra.PreOrder 5 | Types.List 6 | Coq.Lists.List. 7 | 8 | Import ListNotations. 9 | 10 | Local Open Scope FT. 11 | 12 | Module ML. 13 | Section FreeMeetLattice. 14 | 15 | Context {X : PreOrder} 16 | {POX : PreO.t (le X)}. 17 | 18 | Definition FreeML : PreOrder := 19 | {| PO_car := list X 20 | ; le := fun a b => Each (fun ub => LSome (fun ua => ua <=[X] ub) a) b 21 | |}. 22 | 23 | Global Instance PO : PreO.t (le FreeML). 24 | Proof. 25 | constructor; simpl; intros. 26 | - intros x' mem. econstructor. eassumption. 27 | reflexivity. 28 | - unfold Each. intros. 29 | specialize (X1 x0 X2). simpl in X1. 30 | induction X1. 31 | specialize (X0 _ S_member). simpl in X0. 32 | induction X0. 33 | econstructor. eassumption. 34 | etransitivity; eassumption. 35 | Qed. 36 | 37 | Lemma FSubset_le (xs ys : FreeML) : (ys ⊆ xs)%list -> xs <= ys. 38 | Proof. 39 | simpl. unfold FSubset, Each. 40 | intros H x mem. 41 | eexists x. apply H. assumption. 42 | reflexivity. 43 | Qed. 44 | 45 | Local Open Scope Subset. 46 | 47 | Definition bmeet (xs ys : FreeML) : FreeML := xs ++ ys. 48 | 49 | Local Infix "++" := bmeet. 50 | 51 | Lemma bmeet_le_r (l r : FreeML) 52 | : l ++ r <= r. 53 | Proof. 54 | unfold bmeet. apply FSubset_le. apply FSubset_app_r. 55 | Qed. 56 | 57 | Lemma bmeet_le_l (l r : FreeML) 58 | : l ++ r <= l. 59 | Proof. 60 | unfold bmeet. apply FSubset_le. apply FSubset_app_l. 61 | Qed. 62 | 63 | Lemma app_le (xs ys : FreeML) : 64 | xs <= ys -> xs <= (xs ++ ys). 65 | Proof. 66 | simpl. unfold bmeet, Each. intros H x mem. 67 | apply member_app in mem. induction mem. 68 | - econstructor. eassumption. reflexivity. 69 | - apply H. assumption. 70 | Qed. 71 | 72 | Lemma le_app_r (xs xs' ys : FreeML) 73 | : xs <= xs' -> (xs ++ ys) <= (xs' ++ ys). 74 | Proof. 75 | simpl. unfold Each, bmeet. intros H x mem. 76 | apply member_app in mem. apply LSome_app. 77 | induction mem. 78 | - left. apply H. assumption. 79 | - right. econstructor. eassumption. reflexivity. 80 | Qed. 81 | 82 | Definition inj (a : X) : FreeML := [a]. 83 | 84 | Lemma le_singleton (a b : X) 85 | : a <= b -> inj a <= inj b. 86 | Proof. 87 | simpl; unfold Each, inj; intros H x mem. 88 | apply member_singleton in mem. 89 | subst. econstructor. econstructor. eassumption. 90 | Qed. 91 | 92 | Lemma le_singleton_opp (a b : X) 93 | : inj a <= inj b -> a <= b. 94 | Proof. 95 | simpl; unfold Each, inj; intros H. 96 | specialize (H _ here). induction H. 97 | apply member_singleton in S_member. 98 | subst. assumption. 99 | Qed. 100 | 101 | Lemma bmeet_comm (xs ys : FreeML) 102 | : (xs ++ ys) <= (ys ++ xs). 103 | Proof. 104 | simpl. unfold Each, bmeet. intros x mem. 105 | apply member_app in mem. apply LSome_app. 106 | induction mem; [right | left]; 107 | (econstructor; [eassumption | reflexivity]). 108 | Qed. 109 | 110 | Lemma le_app_l (ys ys' xs : FreeML) 111 | : ys <= ys' -> (ys ++ xs) <= (ys' ++ xs). 112 | Proof. 113 | intros H. 114 | rewrite (bmeet_comm ys). 115 | etransitivity. 116 | Focus 2. eapply le_app_r. eassumption. 117 | apply bmeet_comm. 118 | Qed. 119 | 120 | Lemma le_app_distr {xs xs' ys ys' : FreeML} 121 | : xs <= xs' -> ys <= ys' -> (xs ++ ys) <= (xs' ++ ys'). 122 | Proof. 123 | simpl. unfold Each, bmeet. 124 | intros Hx Hy x mem. 125 | apply member_app in mem. apply LSome_app. 126 | induction mem. 127 | - left. apply Hx. assumption. 128 | - right. apply Hy. assumption. 129 | Qed. 130 | 131 | Lemma le_cons (a b : X) (xs ys : FreeML) 132 | : a <= b -> xs <= ys -> (inj a ++ xs) <=[FreeML] (inj b ++ ys). 133 | Proof. 134 | intros H H'. 135 | apply (@le_app_distr [a] [b] xs ys). 136 | apply le_singleton. assumption. assumption. 137 | Qed. 138 | 139 | Lemma le_cons_r {xs ys : FreeML} {a : X} 140 | (Ha : xs <= inj a) (Hys : xs <= ys) 141 | : xs <=[FreeML] (inj a ++ ys). 142 | Proof. 143 | simpl. unfold Each. 144 | intros x mem. inv mem. 145 | - apply Ha. constructor. 146 | - apply Hys. assumption. 147 | Qed. 148 | 149 | Lemma le_app_each (l x y : FreeML) 150 | (lx : l <= x) (ly : l <= y) 151 | : l <= (x ++ y). 152 | Proof. 153 | simpl. unfold Each, bmeet. intros u mem. 154 | apply member_app in mem. destruct mem. 155 | - apply lx. assumption. 156 | - apply ly. assumption. 157 | Qed. 158 | 159 | Lemma down_app (b c : FreeML) : (eq b ↓ eq c) === ⇓ (eq (b ++ c) : FreeML -> Prop). 160 | Proof. 161 | apply Same_set_iff. 162 | intros bc. split; intros. 163 | - destruct X0. le_downH d. le_downH d0. 164 | le_down. 165 | apply le_app_each; assumption. 166 | - le_downH X0. split; le_down. 167 | etransitivity. eassumption. apply FSubset_le. 168 | apply FSubset_app_l. 169 | etransitivity. eassumption. apply FSubset_le. 170 | apply FSubset_app_r. 171 | Qed. 172 | 173 | Lemma Each_monotone (P : X -> Type) 174 | (Pmono : forall x y, x <= y -> P x -> P y) 175 | (xs ys : FreeML) 176 | (H : xs <= ys) : Each P xs -> Each P ys. 177 | Proof. 178 | intros E x mem. specialize (H x mem). 179 | simpl in H. induction H. 180 | eapply Pmono. eassumption. apply E. assumption. 181 | Qed. 182 | 183 | End FreeMeetLattice. 184 | End ML. 185 | 186 | 187 | Arguments ML.FreeML : clear implicits. 188 | 189 | Delimit Scope FreeML_scope with FreeML. 190 | Infix "∧" := ML.bmeet (at level 60) : FreeML_scope. 191 | -------------------------------------------------------------------------------- /src/Algebra/PreOrder.v: -------------------------------------------------------------------------------- 1 | Require Import 2 | Algebra.SetsC 3 | Algebra.OrderC 4 | CMorphisms 5 | Prob.StdLib 6 | Types.UIP. 7 | 8 | Set Universe Polymorphism. 9 | 10 | Local Open Scope Subset. 11 | 12 | Record PreOrder := 13 | { PO_car :> Type 14 | (** The type of basic opens, i.e., observable property *) 15 | ; le : crelation PO_car 16 | (** a preorder on [S] which indicates when one basic open lies in another, 17 | i.e., one observable property implies another *) 18 | }. 19 | 20 | Infix "<=" := (le _) : FT_scope. 21 | Notation "a <=[ X ] b" := (le X a b) (at level 40, format "a <=[ X ] b"). 22 | 23 | Definition Open@{A P} (A : PreOrder@{A P}) := Subset@{A P} A. 24 | Delimit Scope FT_scope with FT. 25 | 26 | Local Open Scope FT. 27 | 28 | Set Printing Universes. 29 | 30 | Definition downset@{A P} {A : PreOrder@{A P}} (U : Open A) : Open A := 31 | union U (fun x y => y <= x). 32 | 33 | Notation "⇓ U" := (downset U) (at level 30). 34 | 35 | Definition down@{A P} {A : PreOrder@{A P}} (U V : Open A) : Open A := 36 | ⇓ U ∩ ⇓ V. 37 | 38 | Infix "↓" := (down) (at level 30). 39 | 40 | Section Down_Props. 41 | Context {A : PreOrder}. 42 | 43 | Lemma downset_included {PO : PreO.t (le A)} : forall (V : Open A), 44 | V ⊆ ⇓ V. 45 | Proof. 46 | intros. unfold Included, pointwise_rel, arrow; intros. 47 | econstructor. eassumption. reflexivity. 48 | Qed. 49 | 50 | Lemma downset_Proper_impl : Proper (Included ==> Included) 51 | (@downset A). 52 | Proof. 53 | unfold Proper, respectful. 54 | intros. unfold Included, In, pointwise_rel, arrow. 55 | firstorder. unfold downset. exists a0. apply X. assumption. assumption. 56 | Qed. 57 | 58 | Instance downset_Proper : Proper (Same_set ==> Same_set) (@downset A). 59 | Proof. 60 | unfold Proper, respectful. intros. 61 | apply Same_set_Included in X. destruct X. 62 | apply Included_Same_set; apply downset_Proper_impl; try assumption; 63 | unfold respectful, arrow; intros; subst. 64 | Qed. 65 | 66 | Context {PO : PreO.t (le A)}. 67 | 68 | Lemma down_intersection {U V : Subset A} : 69 | U ∩ V ⊆ U ↓ V. 70 | Proof. 71 | apply Included_impl. intros. destruct X. 72 | unfold down. split; exists x; 73 | (assumption || reflexivity). 74 | Qed. 75 | 76 | Lemma downset_down_incl {U V : Subset A} : 77 | ⇓ (U ↓ V) === ⇓ (U ∩ V). 78 | Proof. 79 | Abort. 80 | 81 | Lemma downset_down {U V : Subset A} : 82 | ⇓ (U ↓ V) === U ↓ V. 83 | Proof. 84 | apply Included_Same_set. 85 | - unfold down. apply Intersection_Included. 86 | + apply Included_impl; intros. destruct X. 87 | destruct i. destruct d. 88 | eexists. eassumption. etransitivity; eassumption. 89 | + apply Included_impl; intros. destruct X. 90 | destruct i. destruct d0. eexists. eassumption. 91 | etransitivity; eassumption. 92 | - apply downset_included. 93 | Qed. 94 | 95 | Lemma downset_idempotent (U : Subset A) : 96 | ⇓ (⇓ U) === ⇓ U. 97 | Proof. 98 | unfold downset. apply Same_set_iff. intros. split; intros. 99 | - destruct X. destruct i. econstructor. eassumption. 100 | etransitivity; eassumption. 101 | - exists x. assumption. reflexivity. 102 | Qed. 103 | 104 | Lemma down_assoc {U V W : Subset A} : 105 | (U ↓ V) ↓ W === U ↓ (V ↓ W). 106 | Proof. 107 | unfold down at 1 3. 108 | rewrite !downset_down. unfold down. 109 | symmetry. 110 | apply Intersection_assoc. 111 | Qed. 112 | 113 | Lemma le_down {a b : A} : a <=[A] b 114 | -> eq a ↓ eq b === ⇓ (eq a). 115 | Proof. 116 | intros H. apply Included_Same_set. 117 | - unfold down. apply Intersection_Included_l. 118 | - apply Included_impl. intros. destruct X. 119 | unfold In in i. subst. split. 120 | eexists. reflexivity. eassumption. eexists. 121 | reflexivity. etransitivity; eassumption. 122 | Qed. 123 | 124 | Lemma down_eq {a b : A} 125 | : forall c : A, ((c <= a) * (c <= b))%type <--> (eq a ↓ eq b) c. 126 | Proof. 127 | intros. split; intros. 128 | - destruct X. split; (eexists; [reflexivity | eassumption]). 129 | - destruct X. destruct d, d0. unfold In in *. subst. 130 | split; assumption. 131 | Qed. 132 | 133 | Lemma down_Proper {U V U' V' : Subset A} : 134 | U ⊆ U' -> V ⊆ V' -> U ↓ V ⊆ U' ↓ V'. 135 | Proof. 136 | intros HU HV. unfold down. 137 | apply Intersection_Included. 138 | - etransitivity. apply Intersection_Included_l. 139 | apply downset_Proper_impl. assumption. 140 | - etransitivity. apply Intersection_Included_r. 141 | apply downset_Proper_impl; assumption. 142 | Qed. 143 | 144 | Lemma down_comm {U V : Subset A} 145 | : U ↓ V === V ↓ U. 146 | Proof. 147 | unfold down. apply Intersection_comm. 148 | Qed. 149 | 150 | End Down_Props. 151 | 152 | Lemma le_down1@{A P} {A : PreOrder@{A P}} {H : PreO.t@{A P} (le A)} (a b : A) 153 | : a <=[A] b <--> (⇓ eq b) a. 154 | Proof. 155 | split; intros X. 156 | - exists b. reflexivity. assumption. 157 | - destruct X. unfold In in i. subst. assumption. 158 | Qed. 159 | 160 | Lemma union_down {A B : PreOrder} 161 | (U : Subset A) 162 | (F : A -> B -> Type) 163 | : union U (fun a => ⇓ F a) === ⇓ union U F. 164 | Proof. 165 | intros b; split. 166 | - intros H. destruct H. destruct d. 167 | eexists. 2:eassumption. 168 | econstructor; eassumption. 169 | - intros H. destruct H. destruct i. 170 | eexists. eassumption. eexists; eassumption. 171 | Qed. 172 | 173 | Ltac le_down := rewrite <- !le_down1. 174 | Ltac le_downH H := rewrite <- !le_down1 in H. 175 | 176 | Lemma downset_eq_le {A : PreOrder} 177 | {PO : PreO.t (le A)} 178 | (a b : A) : 179 | a <=[A] b -> 180 | ⇓ eq a ⊆ ⇓ eq b. 181 | Proof. 182 | intros Hle x H. 183 | le_downH H. 184 | le_down. etransitivity; eassumption. 185 | Qed. 186 | 187 | Definition BProdPO (A B : PreOrder) : PreOrder := 188 | {| PO_car := A * B 189 | ; le := prod_op (le A) (le B) |}. 190 | 191 | Section Sum. 192 | Universes A P Ix. 193 | Context {Ix : Type@{Ix}}. 194 | Context {Ix_UIP : EqdepFacts.UIP_ Ix}. 195 | Context {X : Ix -> PreOrder@{A P}}. 196 | 197 | (** See 198 | https://www.cs.bham.ac.uk/~sjv/InfiniteTych.pdf 199 | *) 200 | Record SomeOpen_car@{} : Type@{A} := 201 | { SOIx : Ix 202 | ; SOOpen : X SOIx 203 | }. 204 | 205 | Inductive SomeOpen_le : SomeOpen_car -> SomeOpen_car -> Type := 206 | | MkSomeOpen_le : forall ix (aix bix : X ix), 207 | aix <=[X ix] bix 208 | -> SomeOpen_le (Build_SomeOpen_car ix aix) (Build_SomeOpen_car ix bix). 209 | 210 | Definition SomeOpen : PreOrder := 211 | {| PO_car := SomeOpen_car 212 | ; le := SomeOpen_le 213 | |}. 214 | 215 | Definition MkSomeOpen (ix : Ix) (u : X ix) : SomeOpen 216 | := Build_SomeOpen_car ix u. 217 | 218 | Context {PO : forall ix : Ix, PreO.t (le (X ix))}. 219 | 220 | Instance Sum_PO : PreO.t SomeOpen_le. 221 | Proof. 222 | constructor; simpl; intros. 223 | - destruct x. econstructor. reflexivity. 224 | - induction X0. UIP_inv X1. 225 | econstructor. etransitivity; eassumption. 226 | Qed. 227 | 228 | End Sum. 229 | 230 | Arguments SomeOpen {Ix} X. -------------------------------------------------------------------------------- /src/Algebra/SetsC.v: -------------------------------------------------------------------------------- 1 | Require Import Prob.StdLib Coq.Classes.CRelationClasses. 2 | 3 | Set Universe Polymorphism. 4 | 5 | Delimit Scope Subset_scope with Subset. 6 | Local Open Scope Subset. 7 | 8 | Infix "<-->" := iffT (at level 75) : Subset_scope. 9 | 10 | Definition Subset@{A P} (A : Type@{A}) := A -> Type@{P}. 11 | 12 | Section Defns. 13 | Universes A. 14 | Context {A : Type@{A}}. 15 | 16 | Definition In@{P} (U : Subset@{A P} A) (x : A) := U x. 17 | 18 | Definition pointwise_op@{P Q PQ} (f : Type@{P} -> Type@{Q} -> Type@{PQ}) 19 | (U : Subset@{A P} A) (V : Subset@{A Q} A) : Subset@{A PQ} A 20 | := fun a : A => f (U a) (V a). 21 | 22 | Definition pointwise_rel@{P Q PQ} (f : Type@{P} -> Type@{Q} -> Type@{PQ}) 23 | (U : Subset@{A P} A) (V : Subset@{A Q} A) : Type@{PQ} 24 | := forall a : A, f (U a) (V a). 25 | 26 | Definition Intersection@{P Q PQ} : Subset@{A P} A -> Subset@{A Q} A -> Subset@{A PQ} A := pointwise_op prod. 27 | Definition Union@{P Q PQ} : Subset@{A P} A -> Subset@{A Q} A -> Subset@{A PQ} A := pointwise_op sum. 28 | 29 | Inductive Inhabited@{P} {U : Subset@{A P} A} := 30 | Inhabited_intro : forall a : A, In U a -> Inhabited. 31 | End Defns. 32 | 33 | Definition Included@{A P} {A} : 34 | Subset@{A P} A -> Subset@{A P} A -> Type@{max(A,P)} := 35 | fun U V => forall a : A, U a -> V a. 36 | 37 | Definition Same_set@{A P AP} {A} : 38 | Subset@{A P} A -> Subset@{A P} A -> Type@{AP} := 39 | fun U V => forall a : A, U a <--> V a. 40 | 41 | Arguments Inhabited {A} U. 42 | 43 | 44 | Infix "⊆" := Included (at level 60) : Subset_scope. 45 | Infix "∩" := Intersection (at level 50) : Subset_scope. 46 | Infix "∪" := Union (at level 55) : Subset_scope. 47 | Infix "===" := Same_set (at level 70) : Subset_scope. 48 | 49 | Definition RelIncl@{A B P ABP} 50 | {A : Type@{A}} {B : Type@{B}} : 51 | (A -> B -> Type@{P}) -> (A -> B -> Type@{P}) -> Type@{ABP} := 52 | fun F G => forall a : A, Included@{B P} (F a) (G a). 53 | 54 | Definition RelSame@{A B P ABP} 55 | {A : Type@{A}} {B : Type@{B}} : 56 | (A -> B -> Type@{P}) -> (A -> B -> Type@{P}) -> Type@{ABP} := 57 | fun F G => forall a : A, Same_set@{B P ABP} (F a) (G a). 58 | 59 | Infix "⊑" := RelIncl (at level 60) : Subset_scope. 60 | Infix "====" := RelSame (at level 70) : Subset_scope. 61 | 62 | Definition compose {S T U} (F : S -> T -> Type) 63 | (G : T -> U -> Type) (s : S) (u : U) : Type := 64 | { t : T & (F s t * G t u)%type }. 65 | 66 | Theorem Included_impl@{A P AP} {A} (U V : Subset@{A P} A) : 67 | (forall x : A, U x -> V x) <--> (U ⊆ V : Type@{AP}). 68 | Proof. firstorder. Qed. 69 | 70 | Theorem Same_set_iff@{A P AP} A (U V : Subset@{A P} A) : 71 | (forall x, U x <--> V x) <--> (Same_set@{A P AP} U V). 72 | Proof. 73 | firstorder. 74 | Qed. 75 | 76 | Inductive union@{S T PS PT} {S T} (U : Subset@{S PS} S) 77 | (f : S -> Subset@{T PT} T) (b : T) : Type@{PT} := 78 | union_intro : forall a, In U a -> f a b -> In (union U f) b. 79 | 80 | Theorem Union_union : forall (A B : Type) (a b : Subset A) (f : A -> Subset B), 81 | union a f ∪ union b f === union (a ∪ b) f. 82 | Proof. 83 | intros. constructor; unfold Included; intros X. 84 | - destruct X; destruct u; econstructor; eauto; firstorder. 85 | - destruct X; destruct i; [ left | right]; econstructor; eauto. 86 | Qed. 87 | 88 | Theorem union_Intersection : 89 | forall (A B : Type) (a b : Subset A) (f : A -> Subset B), 90 | union (a ∩ b) f ⊆ union a f ∩ union b f. 91 | Proof. 92 | intros. apply Included_impl; intros. 93 | destruct X. destruct i. constructor; econstructor; eassumption. 94 | Qed. 95 | 96 | Lemma union_eq A B (x: A) (f : A -> Subset B) : 97 | union (eq x) f ⊆ f x. 98 | Proof. 99 | apply Included_impl; intros. 100 | destruct X. induction i. assumption. 101 | Qed. 102 | 103 | 104 | Theorem Intersection_Included_l : forall A (U V : Subset A), 105 | U ∩ V ⊆ U. 106 | Proof. 107 | firstorder. 108 | Qed. 109 | 110 | Theorem Intersection_Included_r : forall A (U V : Subset A), 111 | U ∩ V ⊆ V. 112 | Proof. 113 | firstorder. 114 | Qed. 115 | 116 | Lemma Intersection_Included {T} {A B C : Subset T} : 117 | A ⊆ B -> A ⊆ C -> A ⊆ B ∩ C. 118 | Proof. 119 | firstorder. 120 | Qed. 121 | 122 | Lemma Intersection_assoc {T} {A B C : Subset T} : 123 | A ∩ (B ∩ C) === (A ∩ B) ∩ C. 124 | Proof. 125 | firstorder. 126 | Qed. 127 | 128 | Lemma Intersection_comm {T} {A B : Subset T} : 129 | A ∩ B === B ∩ A. 130 | Proof. 131 | firstorder. 132 | Qed. 133 | 134 | Theorem Union_Included_l : forall A (U V : Subset A), 135 | U ⊆ U ∪ V. 136 | Proof. 137 | firstorder. 138 | Qed. 139 | 140 | Theorem Union_Included_r : forall A (U V : Subset A), 141 | V ⊆ U ∪ V. 142 | Proof. 143 | firstorder. 144 | Qed. 145 | 146 | Require Import CMorphisms. 147 | 148 | Instance Intersection_Proper_le : forall U, 149 | Proper (Included ==> Included ==> Included) (@Intersection U). 150 | Proof. 151 | intros. unfold Proper, respectful. 152 | firstorder. 153 | Qed. 154 | 155 | Instance Intersection_Proper : forall U, 156 | Proper (Same_set ==> Same_set ==> Same_set) (@Intersection U). 157 | Proof. 158 | intros. unfold Proper, respectful. 159 | firstorder. 160 | Qed. 161 | 162 | Instance Union_Proper_le : forall U, 163 | Proper (Included ==> Included ==> Included) (@Union U). 164 | Proof. 165 | intros. unfold Proper, respectful. 166 | firstorder. 167 | Qed. 168 | 169 | Set Printing Universes. 170 | Instance Included_Reflexive@{A P AP'} : forall U, Reflexive@{AP' AP'} (@Included@{A P} U). 171 | Proof. 172 | intros. unfold Reflexive. firstorder. 173 | Qed. 174 | 175 | Instance Included_Transitive@{A P AP'} : forall U, Transitive@{AP' AP'} (@Included@{A P} U). 176 | Proof. 177 | intros. unfold Transitive. firstorder. 178 | Qed. 179 | 180 | Instance Included_subrelation : forall U, subrelation (@Same_set U) (@Included U). 181 | Proof. 182 | intros. unfold subrelation. firstorder. 183 | Qed. 184 | 185 | Instance Included_Proper : forall U, Proper (@Same_set U ==> @Same_set U ==> iffT) 186 | (@Included U). 187 | Proof. 188 | intros. unfold Proper, respectful. firstorder. 189 | Qed. 190 | 191 | Require RelationClasses. 192 | Instance RelIncl_PreOrder : forall A B, PreOrder (@RelIncl A B). 193 | Proof. 194 | intros. constructor; unfold Reflexive, Transitive, RelIncl; intros. 195 | - reflexivity. 196 | - transitivity (y a); auto. 197 | Qed. 198 | 199 | Instance Same_set_Equivalence@{A P AP AP'} : 200 | forall U, Equivalence@{AP' AP} (@Same_set@{A P AP} U). 201 | Proof. intros. unfold Same_set. constructor; 202 | unfold Reflexive, Symmetric, Transitive; firstorder. 203 | Qed. 204 | 205 | 206 | Instance RelSame_Equivalence : forall A B, Equivalence (@RelSame A B). 207 | Proof. intros. unfold RelSame. constructor; 208 | unfold Reflexive, Symmetric, Transitive; intros. 209 | - reflexivity. 210 | - symmetry. auto. 211 | - transitivity (y a); auto. 212 | Qed. 213 | 214 | Require Coq.Setoids.Setoid. 215 | Instance RelIncl_Proper : forall A B, Proper (RelSame ==> RelSame ==> iffT) 216 | (@RelIncl A B). 217 | Proof. 218 | intros. unfold Proper, respectful, RelIncl, RelSame. intros. 219 | split; intros; apply Included_impl; intros. 220 | - apply X0. apply X1. apply X. assumption. 221 | - apply X0. apply X1. apply X. assumption. 222 | Qed. 223 | 224 | Lemma Included_Same_set@{A P AP} : forall A (U V : Subset@{A P} A), 225 | U ⊆ V -> V ⊆ U -> Same_set@{A P AP} U V. 226 | Proof. 227 | firstorder. 228 | Qed. 229 | 230 | Lemma Same_set_Included@{A P AP} {A} (U V : Subset@{A P} A) : 231 | Same_set@{A P AP} U V -> ((U ⊆ V) * (V ⊆ U))%type. 232 | Proof. 233 | intros H. unfold Same_set, pointwise_rel, iffT in H. 234 | unfold Included, pointwise_rel, arrow. 235 | split; apply H. 236 | Qed. 237 | 238 | Lemma RelIncl_RelSame : forall A B (F G : A -> B -> Type), 239 | F ⊑ G -> G ⊑ F -> F ==== G. 240 | Proof. 241 | unfold RelIncl, RelSame; intros. apply Included_Same_set; auto. 242 | Qed. 243 | 244 | Lemma RelSame_RelIncl@{A B P ABP} (A : Type@{A}) B (F F' : A -> Subset@{B P} B) : 245 | RelSame@{A B P ABP} F F' -> F ⊑ F'. 246 | Proof. 247 | unfold RelSame, RelIncl. 248 | intros. unfold Included, pointwise_rel, arrow; intros. 249 | apply X. assumption. 250 | Qed. 251 | 252 | Lemma RelSame_iffT {A B} (R S : A -> B -> Type) : 253 | (forall a b, R a b <--> S a b) <--> (R ==== S). 254 | Proof. 255 | firstorder. 256 | Qed. 257 | 258 | Instance RelSame_Proper : forall A B, Proper (RelSame ==> RelSame ==> iffT) 259 | (@RelSame A B). 260 | Proof. 261 | intros. unfold Proper, respectful, RelSame. intros. split; intros. 262 | - rewrite <- X, <- X0. auto. 263 | - rewrite X, X0. auto. 264 | Qed. 265 | 266 | Lemma union_compose : forall A B C (H : Subset A) (G : A -> Subset B) 267 | (F : B -> Subset C), 268 | union (union H G) F === union H (compose G F). 269 | Proof. 270 | intros. apply Same_set_iff. intros; split; intros. 271 | - destruct X. destruct i. repeat (econstructor || eauto). 272 | - destruct X. destruct c. destruct p. 273 | repeat (econstructor || eauto). 274 | Qed. 275 | 276 | Lemma union_idx_monotone : forall A B (U V : Subset A) (F : A -> B -> Type), 277 | U ⊆ V -> union U F ⊆ union V F. 278 | Proof. 279 | intros. apply Included_impl; intros. 280 | destruct X0. econstructor; eauto. 281 | apply X. assumption. 282 | Qed. 283 | 284 | Lemma union_monotone : forall A B (U : Subset A) (F G : A -> B -> Type), 285 | F ⊑ G -> union U F ⊆ union U G. 286 | Proof. 287 | intros. apply Included_impl; intros. 288 | destruct X0. econstructor. eassumption. apply X. assumption. 289 | Qed. 290 | 291 | Local Instance union_Proper : forall A B, 292 | Proper (Included ==> RelIncl ==> Included) (@union A B). 293 | Proof. 294 | intros. unfold Proper, respectful. 295 | intros. etransitivity. apply union_idx_monotone. eassumption. 296 | apply union_monotone. assumption. 297 | Qed. 298 | 299 | Local Instance Union_Proper_eq : forall A, 300 | Proper (Same_set ==> Same_set ==> Same_set) (@Union A). 301 | Proof. 302 | firstorder. 303 | Qed. 304 | 305 | Instance Union_Proper_le_flip : forall A, 306 | Proper (Included --> Included --> flip Included) (@Union A). 307 | Proof. 308 | firstorder. 309 | Qed. 310 | 311 | Lemma Same_set_iff_In: 312 | forall (A : Type) (U V : Subset A), 313 | (forall x : A, In U x <--> In V x) -> U === V. 314 | Proof. 315 | apply Same_set_iff. 316 | Qed. 317 | 318 | Instance In_Proper : forall A, 319 | Proper (Included ==> eq ==> arrow) (@In A). 320 | Proof. 321 | unfold Proper, respectful, arrow. intros. 322 | subst. apply X. assumption. 323 | Qed. 324 | 325 | Instance In_Proper2 : forall A, 326 | Proper (Included --> eq --> flip arrow) (@In A). 327 | Proof. 328 | unfold Proper, respectful, flip, arrow. intros. 329 | subst. apply X. assumption. 330 | Qed. 331 | 332 | Lemma Inhabited_mono {A} {U V : Subset A} : U ⊆ V -> Inhabited U -> Inhabited V. 333 | Proof. 334 | intros. destruct X0. exists a. apply X. assumption. 335 | Qed. 336 | 337 | Instance Inhabited_Proper_le {A} : Proper (Included ==> arrow) (@Inhabited A). 338 | Proof. 339 | unfold Proper, respectful, arrow. intros. eapply Inhabited_mono; eassumption. 340 | Qed. 341 | 342 | Lemma Intersection_Assoc {A : Type} (P Q R : Subset A) 343 | : P ∩ (Q ∩ R) === (P ∩ Q) ∩ R. 344 | Proof. 345 | firstorder. 346 | Qed. 347 | 348 | Lemma Intersection_Comm {A : Type} (P Q : Subset A) 349 | : P ∩ Q === Q ∩ P. 350 | Proof. firstorder. Qed. 351 | 352 | Lemma compose_assoc {A B C D} {F : A -> B -> Type} 353 | {G : B -> C -> Type} {H : C -> D -> Type} 354 | : compose F (compose G H) ==== compose (compose F G) H. 355 | Proof. 356 | firstorder. 357 | Qed. -------------------------------------------------------------------------------- /src/FormTopC/Approx.v: -------------------------------------------------------------------------------- 1 | Require Import 2 | Algebra.FrameC 3 | Algebra.SetsC 4 | Algebra.OrderC 5 | Algebra.PreOrder 6 | FormTopC.Locale 7 | FormTopC.FormTop 8 | FormTopC.InfoBase 9 | FormTopC.FormalSpace 10 | CMorphisms 11 | Prob.StdLib 12 | FormTopC.Spaces.One 13 | Types.Setoid. 14 | 15 | Set Universe Polymorphism. 16 | 17 | Local Open Scope FT. 18 | 19 | Require Import FormalSpace. 20 | 21 | 22 | Local Open Scope Subset. 23 | 24 | Require Import FormTopC.Cont. 25 | 26 | 27 | Existing Instances Frame Frame.type 28 | FOps LOps. 29 | Local Open Scope loc. 30 | 31 | Section Approx. 32 | 33 | Context {A : t}. 34 | 35 | Definition framePt (pt : One ~~> A) 36 | : Frame.point (FOps A) := 37 | Frame.cmap_compose 38 | One_type_cmap (@toCmap One A _ (mp_ok (LA := One) (LB := A) pt)). 39 | 40 | Inductive liesIn {pt : One ~~> A} {U : Subset (S A)} 41 | := MkliesIn : forall u : S A, U u -> mp pt u tt -> liesIn. 42 | Arguments liesIn : clear implicits. 43 | 44 | Infix "⊧" := liesIn (at level 40). 45 | 46 | Lemma liesIn_finv (pt : One ~~> A) 47 | U : iffT (pt ⊧ U) (Frame.finv (framePt pt) U). 48 | Proof. 49 | split; intros H. 50 | - destruct H. simpl. 51 | unfold Cont.Cont.frame. exists u; assumption. 52 | - destruct H. econstructor; eauto. 53 | Qed. 54 | 55 | Definition evalPt (U : Subset (S A)) 56 | {Ix} (V : Ix -> Subset (S A)) 57 | (pt : One ~~> A) 58 | : pt ⊧ U 59 | -> L.le U (Frame.sup V) 60 | -> {i : Ix & pt ⊧ V i }. 61 | Proof. 62 | intros X X0. 63 | pose proof (Frame.point_cov (framePt pt) (U := U) (V := V)) as X1. 64 | pose proof (liesIn_finv pt U) as X2. 65 | destruct X2 as [lf fl]. 66 | specialize (X1 X0 (lf X)). 67 | destruct X1. 68 | exists x. apply liesIn_finv. assumption. 69 | Qed. 70 | 71 | End Approx. 72 | 73 | Inductive Approx {A : t} {I : Type} := 74 | MkApprox : forall (U : Subset (S A)) (V : I -> Subset (S A)) 75 | , L.le U (Frame.sup V) -> Approx. 76 | 77 | Arguments Approx : clear implicits. 78 | 79 | Infix "⤋" := Approx (at level 40). -------------------------------------------------------------------------------- /src/FormTopC/Cantor.v: -------------------------------------------------------------------------------- 1 | Require Import 2 | CMorphisms 3 | FormTopC.FormTop 4 | Algebra.OrderC 5 | Algebra.SetsC 6 | Algebra.PreOrder 7 | FormTopC.FormalSpace. 8 | 9 | Local Open Scope Subset. 10 | 11 | (** An inductively generated formal topology for the Cantor space. 12 | See Section 4.1 of [1]. *) 13 | Section Cantor. 14 | 15 | Variable A : Type. 16 | 17 | Require Import Coq.Lists.List. 18 | Import ListNotations. 19 | 20 | Inductive C {s : list A} {i : True} {s' : list A} : Type := 21 | | CSplit : forall b, s' = s ++ [b] -> C. 22 | 23 | Arguments C : clear implicits. 24 | 25 | Inductive LE {xs ys : list A} : Type := 26 | | IsLE : forall zs, xs = ys ++ zs -> LE. 27 | Arguments LE : clear implicits. 28 | 29 | Definition CantorPO : PreOrder := 30 | {| PO_car := list A 31 | ; le := LE |}. 32 | 33 | Local Instance LE_PO : @PO.t (list A) LE eq. 34 | Proof. 35 | constructor; intros. 36 | - constructor; intros. 37 | + exists nil. rewrite app_nil_r. reflexivity. 38 | + destruct X, X0. 39 | exists (zs0 ++ zs). rewrite e, e0. 40 | rewrite app_assoc. reflexivity. 41 | - unfold Proper, respectful. 42 | intros. subst. reflexivity. 43 | - destruct X, X0. 44 | rewrite e0 in e. rewrite <- app_assoc in e. 45 | rewrite <- app_nil_r in e at 1. 46 | apply app_inv_head in e. 47 | symmetry in e. apply app_eq_nil in e. 48 | destruct e. subst. rewrite app_nil_r. 49 | reflexivity. 50 | Defined. 51 | 52 | Definition PreCantor : PreISpace.t := 53 | {| PreISpace.S := CantorPO 54 | ; PreISpace.C := C |}. 55 | 56 | Local Instance loc : FormTop.localized PreCantor. 57 | Proof. 58 | unfold FormTop.localized. 59 | intros a c H i. simpl in *. destruct i. exists I. 60 | intros s H0. destruct H0. 61 | simpl in H. destruct H. destruct zs. 62 | - subst. rewrite !app_nil_r. 63 | split. exists c. reflexivity. 64 | simpl. econstructor. reflexivity. 65 | exists (c ++ [b]). econstructor. reflexivity. 66 | reflexivity. 67 | - subst. split. eexists. reflexivity. 68 | simpl. rewrite <- app_assoc. eexists. 69 | rewrite <- app_assoc. reflexivity. 70 | rewrite <- app_assoc. simpl. 71 | econstructor. exists a0. reflexivity. 72 | econstructor. rewrite <- app_assoc. simpl. 73 | reflexivity. 74 | Qed. 75 | 76 | Hypothesis inhabited : A. 77 | 78 | (* This actually needs 'A' to be inhabited. *) 79 | Local Instance pos : FormTop.gtPos PreCantor. 80 | Proof. 81 | apply gall_Pos. 82 | intros. destruct X. subst. 83 | induction zs. 84 | - exists (b ++ [inhabited]). 85 | split. econstructor. reflexivity. 86 | rewrite app_nil_r. econstructor. reflexivity. 87 | econstructor. Focus 2. reflexivity. 88 | econstructor. reflexivity. 89 | - econstructor. 90 | Admitted. 91 | 92 | Definition Cantor : IGt := 93 | {| IGS := PreCantor 94 | |}. 95 | 96 | End Cantor. 97 | -------------------------------------------------------------------------------- /src/FormTopC/Compact.v: -------------------------------------------------------------------------------- 1 | (* Spaces whose points are compact sets 2 | i.e., some version of Smyth power domains 3 | See Vickers' *Topology via Logic* 4 | 5 | We should have 6 | 7 | pt : A ~~> P+(A) 8 | OR : P+(A) * P+(A) ~~> P+(A) 9 | 10 | approx : Approximator A X -> Approximator P+(A) X 11 | 12 | which behaves by arbitrarily choosing an option 13 | in the powerdomain. *) 14 | 15 | (* It appears that there is a formulation of the Smyth powerdomain 16 | in formal topology in Vickers' 2005 17 | "Some constructive roads to Tychonoff" 18 | *) 19 | 20 | Require Import 21 | FormTopC.FormTop 22 | Algebra.SetsC 23 | Algebra.OrderC 24 | FormTopC.Join 25 | FormTopC.Cont. 26 | 27 | Set Asymmetric Patterns. 28 | Set Universe Polymorphism. 29 | Local Open Scope Subset. 30 | 31 | Module Compact. 32 | Section Defn. 33 | 34 | Context {S : PreISpace.t} 35 | {POS : PreO.t (le S)}. 36 | 37 | Definition le := JoinTop.leL (le := le S). 38 | 39 | Instance PO : PreO.t le := JoinTop.joinPreO. 40 | 41 | Require Import Coq.Lists.List Types.List. 42 | Import ListNotations. 43 | 44 | Inductive Splits : list S -> list S -> list S -> Type := 45 | | SplitNil : Splits nil nil nil 46 | | SplitL : forall a {xs ys zs}, Splits xs ys zs 47 | -> Splits (a :: xs) ys (a :: zs) 48 | | SplitR : forall b {xs ys zs}, Splits xs ys zs 49 | -> Splits xs (b :: ys) (b :: zs). 50 | 51 | Definition IxS := PreISpace.Ix S. 52 | 53 | Inductive Ix {xs : list S} : Type := 54 | | MkIx : forall a s : list S, Each IxS a 55 | -> Splits a s xs -> Ix. 56 | 57 | Arguments Ix : clear implicits. 58 | 59 | Definition Ixnil : Ix nil. 60 | Proof. 61 | econstructor. apply Each_nil. 62 | apply SplitNil. 63 | Defined. 64 | 65 | Inductive KFinite {U : S -> Type} : list S -> Type := 66 | | KNil : KFinite nil 67 | | KCons : forall x, U x -> forall {xs}, KFinite xs -> KFinite (x :: xs). 68 | 69 | Arguments KFinite : clear implicits. 70 | 71 | Require Import CMorphisms. 72 | Lemma KFinite_Proper_impl : Proper (Same_set ==> eq ==> arrow) 73 | KFinite. 74 | Proof. 75 | unfold Proper, respectful, arrow. intros. 76 | subst. induction X0. apply KNil. 77 | apply KCons. apply X. assumption. assumption. 78 | Qed. 79 | 80 | Instance KFinite_Proper : Proper (Same_set ==> eq ==> iffT) 81 | KFinite. 82 | Proof. 83 | unfold Proper, respectful. intros. split; intros. 84 | - eapply KFinite_Proper_impl; eassumption. 85 | - eapply KFinite_Proper_impl. symmetry. eassumption. 86 | symmetry. eassumption. assumption. 87 | Qed. 88 | 89 | Definition Each_get {A B} {xs : list A} {x : A} 90 | (e : Each B xs) 91 | (mem : member x xs) : B x. 92 | Proof. 93 | induction e. 94 | - inv mem. 95 | - inv mem. assumption. apply IHe. assumption. 96 | Defined. 97 | 98 | Definition CS := PreISpace.C S. 99 | 100 | Inductive axunion {a : list S} {axioms : Each IxS a} 101 | : Subset S := 102 | | Mkaxunion : forall (s : S) x (el : member x a), 103 | CS _ (Each_get axioms el) s -> axunion s. 104 | 105 | Arguments axunion {a} axioms _. 106 | 107 | Lemma axunion_nil_false : forall s, 108 | axunion Each_nil s -> False. 109 | Proof. 110 | intros. induction X. 111 | inv el. 112 | Qed. 113 | 114 | Lemma axunion_nil : axunion Each_nil === fun _ => False. 115 | Proof. 116 | apply Same_set_iff. intros. split; intros. 117 | - eapply axunion_nil_false; eassumption. 118 | - contradiction. 119 | Qed. 120 | 121 | Inductive Covering {a s : list S} {axioms : Each IxS a} 122 | {s' : list S} : Type := 123 | | MkCovering : forall t, Splits t s s' -> 124 | forall u, KFinite (axunion axioms) u -> le t u -> Covering. 125 | 126 | Arguments Covering : clear implicits. 127 | 128 | Definition C (xs : list S) (split : Ix xs) : Subset (list S) := 129 | match split with 130 | | MkIx a s axioms mem => Covering a s axioms 131 | end. 132 | 133 | Definition CompactPreO : FormTop.PreOrder := 134 | {| PO_car := list S 135 | ; FormTop.le := le |}. 136 | 137 | Definition Compact : PreISpace.t := 138 | {| PreISpace.S := CompactPreO 139 | ; PreISpace.Ix := Ix 140 | ; PreISpace.C := C |}. 141 | 142 | Lemma member_le : forall a b, member a b -> [a] <=[Compact] b. 143 | Proof. 144 | intros. simpl. unfold le, JoinTop.leL. intros. 145 | inv X0. Focus 2. inv X1. 146 | exists a. split. reflexivity. assumption. 147 | Qed. 148 | 149 | Lemma leS_le : forall a b, a <=[S] b -> [a] <=[Compact] [b]. 150 | Proof. 151 | intros. simpl. unfold le, JoinTop.leL. intros. 152 | inv X0. Focus 2. inv X1. exists b. split. assumption. 153 | constructor. 154 | Qed. 155 | 156 | Lemma SplitsR_All xs : Splits nil xs xs. 157 | Proof. 158 | induction xs. constructor. constructor. assumption. 159 | Qed. 160 | 161 | Lemma Splits_KFinite {U xs ys zs} : 162 | Splits xs ys zs -> KFinite U xs -> KFinite U ys 163 | -> KFinite U zs. 164 | Proof. 165 | intros. induction X. 166 | - assumption. 167 | - inv X0. apply KCons. assumption. apply IHX; assumption. 168 | - inv X1. apply KCons. assumption. apply IHX; assumption. 169 | Qed. 170 | 171 | Lemma KFinite_nil {xs} : 172 | KFinite (fun _ : S => False) xs -> xs = nil. 173 | Proof. 174 | intros H. induction H. reflexivity. 175 | contradiction. 176 | Qed. 177 | 178 | Lemma le_nil {xs} : le xs [] -> xs = []. 179 | Proof. 180 | intros. induction xs. 181 | - reflexivity. 182 | - unfold le, JoinTop.leL in X. 183 | destruct (X a here). destruct p. inv m. 184 | Qed. 185 | 186 | Lemma Splits_length {xs ys zs} : Splits xs ys zs 187 | -> length xs + length ys = length zs. 188 | Proof. 189 | intros H. induction H. 190 | - reflexivity. 191 | - simpl. rewrite IHSplits. reflexivity. 192 | - simpl. rewrite <- plus_n_Sm. rewrite IHSplits. 193 | reflexivity. 194 | Qed. 195 | 196 | Lemma Splits_nil {xs} : Splits [] [] xs 197 | -> xs = []. 198 | Proof. 199 | intros H. apply Splits_length in H. simpl in H. 200 | apply length_zero_iff_nil. symmetry. assumption. 201 | Qed. 202 | 203 | Lemma C_nil {xs} : C [] Ixnil xs -> xs = []. 204 | Proof. 205 | simpl. intros. 206 | induction X. 207 | eapply KFinite_Proper in k. 208 | 2: symmetry. 2: apply axunion_nil. 209 | 2: reflexivity. pose proof (KFinite_nil k). 210 | subst. pose proof (le_nil l). subst. 211 | apply Splits_nil in s. subst. 212 | reflexivity. 213 | Qed. 214 | 215 | Hypothesis locS : FormTop.localized S. 216 | 217 | Lemma Splits_nil_opp {xs ys} : Splits xs ys [] 218 | -> xs = [] /\ ys = []. 219 | Proof. 220 | intros H. inv H. auto. 221 | Qed. 222 | 223 | Require Import Coq.Logic.Eqdep_dec. 224 | 225 | Inductive Empty {A} : list A -> Prop := 226 | | IsEmpty : Empty []. 227 | 228 | Lemma Each_nil_unique_helper {A B} {xs : list A} 229 | (e : @Each A B xs) : 230 | match xs as xs' return @Each A B xs' -> Type with 231 | | [] => fun e => e = Each_nil 232 | | _ => fun _ => True 233 | end e. 234 | Proof. 235 | induction e. reflexivity. auto. 236 | Qed. 237 | 238 | Lemma Each_nil_unique {A B} 239 | (e : @Each A B []) : e = Each_nil. 240 | Proof. 241 | apply (Each_nil_unique_helper e). 242 | Qed. 243 | 244 | Lemma SplitNil_unique_helper {xs ys zs : list S} 245 | (s : Splits xs ys zs) : 246 | (match zs with 247 | | [] => match xs with 248 | | [] => match ys with 249 | | [] => fun e => e = SplitNil 250 | | _ => fun _ => True 251 | end 252 | | _ => fun _ => True 253 | end 254 | | _ => fun _ => True 255 | end) s. 256 | Proof. 257 | induction s; (reflexivity || auto). 258 | Qed. 259 | 260 | Lemma SplitNil_unique 261 | (s : Splits [] [] []) : s = SplitNil. 262 | Proof. 263 | apply (SplitNil_unique_helper s). 264 | Qed. 265 | 266 | Lemma Ixnil_unique : forall (i : Ix []), i = Ixnil. 267 | Proof. 268 | intros. induction i. unfold Ixnil. 269 | destruct (Splits_nil_opp s0). subst. 270 | pose proof (Each_nil_unique e). subst. 271 | pose proof (SplitNil_unique s0). subst. 272 | reflexivity. 273 | Qed. 274 | 275 | 276 | Lemma loc : FormTop.localized Compact. 277 | Proof. 278 | unfold FormTop.localized. 279 | intros. 280 | unfold FormTop.localized in locS. 281 | generalize dependent a. 282 | induction c. 283 | - intros. apply le_nil in X. subst. 284 | exists Ixnil. intros. 285 | pose proof (C_nil X). subst. 286 | exists []. split. 287 | Focus 2. split; reflexivity. 288 | pose proof (Ixnil_unique i). subst. 289 | assumption. 290 | - intros. induction i. simpl. 291 | Abort. 292 | 293 | Definition inj : Cont.map S Compact := fun xs x => [x] <=[Compact] xs. 294 | 295 | Definition inj_cont : IGCont.t S Compact inj. 296 | Proof. 297 | constructor; intros. 298 | - apply FormTop.grefl. exists [a]. unfold SetsC.In. constructor. 299 | unfold inj. reflexivity. 300 | - unfold inj in *. apply FormTop.grefl. 301 | exists [a]. 2: reflexivity. split; assumption. 302 | - unfold inj in *. etransitivity. apply leS_le. 303 | eassumption. eassumption. 304 | - unfold inj in *. etransitivity; eassumption. 305 | - induction j. simpl. induction a0. 306 | + apply FormTop.grefl. unfold inj in *. 307 | exists (a :: s). 2: apply member_le; constructor. 308 | simpl in X. 309 | econstructor. apply SplitL. apply SplitsR_All. 310 | 2: eassumption. apply (Splits_KFinite s0). 311 | apply KNil. 312 | unfold inj in *. 313 | Admitted. 314 | 315 | Definition Ix_singleton {a} (i : IxS a) : Ix [a]. 316 | Proof. 317 | econstructor. 2: eapply SplitL. 2: econstructor. 318 | econstructor. assumption. econstructor. 319 | Defined. 320 | 321 | Axiom undefined : forall A, A. 322 | 323 | Require Import CRelationClasses. 324 | Lemma lift_Cov_Ax : forall a (i : IxS a) u, 325 | CS a i u -> C [a] (Ix_singleton i) [u]. 326 | Proof. 327 | intros. simpl. econstructor. apply SplitL. econstructor. 328 | 2: reflexivity. econstructor. 329 | constructor 1 with a here. apply X. 330 | constructor. 331 | Qed. 332 | 333 | Local Open Scope FT. 334 | 335 | Lemma Cov_nil {U} : [] <|[Compact] U. 336 | Proof. 337 | apply FormTop.ginfinity with Ixnil. 338 | simpl. intros. induction X. 339 | eapply KFinite_Proper in k. 340 | 2: symmetry. 2: apply axunion_nil. 341 | 2: reflexivity. pose proof (KFinite_nil k). 342 | subst. pose proof (le_nil l). subst. 343 | apply Splits_nil in s. subst. 344 | Abort. 345 | 346 | Lemma Cov_each : forall U (xs : list S), 347 | (forall x : S, member x xs -> [x] <|[Compact] U) 348 | -> xs <|[Compact] U. 349 | Proof. 350 | intros. induction xs. 351 | - apply FormTop.ginfinity with Ixnil. 352 | simpl. intros. induction X0. 353 | eapply KFinite_Proper in k. 354 | 2: symmetry. 2: apply axunion_nil. 355 | 2: reflexivity. pose proof (KFinite_nil k). 356 | subst. pose proof (le_nil l). subst. 357 | apply Splits_nil in s. subst. 358 | Abort. 359 | 360 | Lemma lift_Cov : forall a U, a <|[S] U 361 | -> [a] <|[Compact] Each U. 362 | Proof. 363 | intros. 364 | induction X. 365 | - apply FormTop.grefl. constructor. assumption. 366 | constructor. 367 | - simpl in *. eapply FormTop.gle_left. 2: eassumption. 368 | apply leS_le. assumption. 369 | - unshelve eapply FormTop.ginfinity. 370 | apply Ix_singleton. assumption. 371 | simpl. intros. 372 | induction X0. 373 | econstructor. 374 | Abort. 375 | 376 | (** This actually doesn't work, because the 377 | empty compact set is a valid point of the space. *) 378 | Definition nondet_run : forall a U, FormTop.GCov S a U 379 | -> forall (F : Subset (list S)), IGCont.pt Compact F 380 | -> SetsC.In F [a] -> { b : S & SetsC.In U b }. 381 | Proof. 382 | intros. 383 | induction X. 384 | - exists a. assumption. 385 | - apply IHX. unfold SetsC.In. 386 | eapply (IGCont.pt_le_right (T := Compact) (F := F) X0). 387 | eassumption. apply leS_le. assumption. 388 | - pose proof (IGCont.pt_cov X0 X1 (Ix_singleton i)) as H. 389 | induction H. 390 | Abort. 391 | 392 | 393 | End Defn. 394 | End Compact. -------------------------------------------------------------------------------- /src/FormTopC/Concrete.v: -------------------------------------------------------------------------------- 1 | Require Import Algebra.FrameC FormTopC.FormTop FormTopC.Cont Algebra.SetsC. 2 | 3 | Set Universe Polymorphism. 4 | Set Asymmetric Patterns. 5 | 6 | (** A definition of concrete topological spaces. These are formal topologies 7 | which are related to a type of points in the expected way, through a 8 | relation which I call [In]. See Definition 1.2 in [1]. Their relation 9 | which I call [In] looks like [||-], and they read as "lies in" or 10 | "forces". 11 | *) 12 | Module Concrete. 13 | Section Concrete. 14 | 15 | Variable X S : Type. 16 | Variable In : X -> Subset S. 17 | 18 | Definition le (s t : S) : Type := 19 | forall x : X, In x s -> In x t. 20 | 21 | Instance SPO : @PO.t S le _ := PO.map (fun s x => In x s) (PO.subset X). 22 | 23 | Record t : Type := 24 | { here : forall x, { s : S & In x s } 25 | ; local : forall (a b : S) x, In x a -> In x b 26 | -> { c : S & (In x c * FormTop.down le a b c)%type } 27 | }. 28 | 29 | (** Every concrete topological space can be presented as an 30 | inductively generated formal topology. See Section 4.4 31 | of [1]. *) 32 | Definition Ix {a : S} : Type := (forall (x : X), In x a -> {s : S & In x s}). 33 | 34 | Arguments Ix : clear implicits. 35 | 36 | Inductive C {a : S} {g : Ix a} {s : S} : Type := 37 | MkC : (forall (x : X) (prf : In x a), le (projT1 (g x prf)) s) -> C. 38 | 39 | Arguments C : clear implicits. 40 | 41 | Theorem loc : t -> FormTop.localized le C. 42 | Proof. 43 | intros conc. destruct conc. 44 | unfold FormTop.localized. 45 | intros a c X0 g. 46 | exists (fun (x : X) (xina : In x a) => g x (X0 x xina)). 47 | intros. induction X1. 48 | exists s. 49 | split. econstructor. intros. 50 | Abort. 51 | 52 | End Concrete. 53 | End Concrete. 54 | 55 | Arguments Concrete.Ix : clear implicits. 56 | Arguments Concrete.C : clear implicits. 57 | 58 | Module ConcFunc. 59 | Section ConcFunc. 60 | Generalizable All Variables. 61 | Context {S} `{Conc1 : Concrete.t A S In1}. 62 | Context {T} `{Conc2 : Concrete.t B T In2}. 63 | 64 | Let leS := Concrete.le A S In1. 65 | Let CovS := @FormTop.GCov S leS 66 | (Concrete.Ix A S In1) (Concrete.C A S In1). 67 | 68 | Let leT := Concrete.le B T In2. 69 | Let CovT := @FormTop.GCov T leT 70 | (Concrete.Ix B T In2) (Concrete.C B T In2). 71 | 72 | Require Import CRelationClasses. 73 | Definition cmap (f : A -> B) (g : Cont.map S T) := 74 | forall (t : T) (a : A), iffT (In2 (f a) t) { s : S & (g t s * In1 a s)%type}. 75 | 76 | Theorem cont : forall f g, cmap f g 77 | -> Cont.t leS leT CovS CovT g. 78 | Proof. 79 | intros. unfold cmap in X. constructor; intros. 80 | Abort. 81 | 82 | End ConcFunc. 83 | End ConcFunc. 84 | -------------------------------------------------------------------------------- /src/FormTopC/Discrete.v: -------------------------------------------------------------------------------- 1 | Require Import 2 | Prob.StdLib 3 | Types.Setoid 4 | Coq.Classes.CMorphisms 5 | FormTopC.FormTop 6 | FormTopC.Cont 7 | FormTopC.InfoBase 8 | FormTopC.FormalSpace 9 | Algebra.SetsC 10 | Algebra.OrderC 11 | Algebra.PreOrder. 12 | 13 | Set Universe Polymorphism. 14 | Set Asymmetric Patterns. 15 | 16 | Set Printing Universes. 17 | 18 | Local Open Scope FT. 19 | 20 | Module Discrete. 21 | Section Discrete. 22 | 23 | Universes A A'. 24 | Variable A : Type@{A}. 25 | 26 | Definition DiscretePO@{} : PreOrder@{A A} := 27 | {| PO_car := A 28 | ; le := Logic.eq 29 | |}. 30 | 31 | Instance discretePO@{} : PreO.t Logic.eq := PreO.discrete@{A A} A. 32 | 33 | Set Printing Universes. 34 | 35 | Definition DiscI@{} : IGt@{A A A A'} := InfoBase.InfoBase@{A A A'} DiscretePO. 36 | 37 | Definition Disc@{} : PreSpace.t := 38 | {| PreSpace.S := DiscretePO 39 | ; PreSpace.Cov := fun a U => In U a |}. 40 | 41 | Local Open Scope Subset. 42 | 43 | Lemma CovG_Cov a U : a <|[DiscI] U <--> In U a. 44 | Proof. 45 | split; intros H. 46 | - induction H. 47 | + simpl in *. subst. assumption. 48 | + simpl in *. subst. assumption. 49 | + induction i. 50 | - apply FormTop.refl. assumption. 51 | Qed. 52 | 53 | Instance isCov@{} : FormTop.t Disc. 54 | Proof. 55 | econstructor; try (simpl; eauto). 56 | - intros. subst. eauto. 57 | - intros. split; unfold downset; exists a; 58 | (assumption || reflexivity). 59 | Qed. 60 | 61 | Definition pt_ok (x : A) : Cont.pt Disc (eq x). 62 | Proof. 63 | constructor. 64 | - econstructor. reflexivity. 65 | - intros. subst. 66 | repeat (econstructor || eauto). 67 | - intros. subst. econstructor. 68 | econstructor. reflexivity. assumption. 69 | Qed. 70 | 71 | Lemma pt_singleton (U : Subset A) : 72 | Cont.pt Disc U -> forall x y : A, U x -> U y -> x = y. 73 | Proof. 74 | intros H x y Ux Uy. 75 | pose proof (Cont.pt_local H Ux Uy). 76 | destruct X. destruct i. 77 | apply down_eq in d. destruct d. destruct l, l0. 78 | reflexivity. 79 | Qed. 80 | 81 | Definition pt_eval (U : Subset A) (x : Cont.pt Disc U) 82 | := match Cont.pt_here x with 83 | | Inhabited_intro y _ => y 84 | end. 85 | 86 | End Discrete. 87 | End Discrete. 88 | 89 | Require Import 90 | FormTopC.Cont 91 | FormTopC.Product. 92 | 93 | Local Open Scope loc. 94 | 95 | Definition discrete@{A A'} : Type@{A} -> IGt@{A A A A'} := Discrete.DiscI. 96 | 97 | Module DiscreteFunc. 98 | 99 | Section Func. 100 | 101 | Universes A A' B P I BPI. 102 | Context {A : Type@{A}}. 103 | Variable B : IGt@{A P I BPI}. 104 | 105 | Variable (f : A -> Subset (S B)). 106 | 107 | Definition pointwise : Cont.map (discrete A) B := 108 | fun (y : S B) (x : A) => In (f x) y. 109 | 110 | Hypothesis fpt : forall a, Cont.pt B (f a). 111 | 112 | Theorem pointwise_cont : Cont.t (Discrete.Disc A) B pointwise. 113 | Proof. 114 | constructor; simpl; intros. 115 | - destruct (Cont.pt_here (fpt a)). 116 | exists a0. constructor. assumption. 117 | - unfold pointwise in *. subst. assumption. 118 | - unfold pointwise in *. 119 | pose proof (Cont.pt_local (fpt a) X X0). 120 | destruct X1. destruct i. exists a0; assumption. 121 | - unfold pointwise in X. 122 | pose proof (Cont.pt_cov (fpt a) X X0). 123 | destruct X1. destruct i. exists a0; assumption. 124 | Qed. 125 | 126 | End Func. 127 | 128 | Section DFunc. 129 | Universes A A' B B'. 130 | Context {A : Type@{A}} {B : Type@{B}}. 131 | Definition discrF (f : A -> B) (y : B) (x : A) : Prop := f x = y. 132 | 133 | Instance POB@{} : PO.t Logic.eq Logic.eq := PO.discrete B. 134 | 135 | (* 136 | Theorem fCont (f : A -> B) : 137 | Cont.t Logic.eq (le (discrete B)) (Discrete.Cov A) (Discrete.Cov B) (discrF f). 138 | Proof. 139 | apply pointwise_cont. intros. apply Discrete.pt_ok. 140 | Qed. 141 | *) 142 | 143 | (** Should be able to get this from the above just from 144 | rewriting, but it's not working... *) 145 | Theorem fContI (f : A -> B) : 146 | Cont.t (discrete@{A A'} A) (discrete@{B B'} B) (discrF f). 147 | Proof. 148 | constructor; intros. 149 | - apply FormTop.refl. exists (f a); constructor. 150 | - unfold discrF in *. simpl in X. subst. reflexivity. 151 | - inv H. inv H0. apply FormTop.refl. 152 | exists (f a). split; le_down; simpl; reflexivity. 153 | reflexivity. 154 | - apply FormTop.refl. exists b; unfold In; auto. induction X; auto. 155 | simpl in *. subst. apply IHX. assumption. induction i. 156 | Qed. 157 | 158 | (** Same story here... *) 159 | Definition pt_okI (x : A) : Cont.pt (discrete A) (Logic.eq x). 160 | Proof. 161 | constructor. 162 | - econstructor. reflexivity. 163 | - intros. subst. 164 | repeat (econstructor || eauto). 165 | - intros. subst. econstructor. 166 | econstructor. reflexivity. induction X. 167 | + assumption. 168 | + simpl in *. subst. assumption. 169 | + destruct i. 170 | Qed. 171 | 172 | (** This is only true for finitary products! *) 173 | (** Show that (discrete A * discrete B ≅ discrete (A * B) *) 174 | 175 | 176 | End DFunc. 177 | 178 | End DiscreteFunc. 179 | 180 | (** For some reason, I get a universe inconsistency if I try to do 181 | this in normal definition mode. *) 182 | Definition discrete_f {A B : Type} (f : A -> B) : discrete A ~~> discrete B. 183 | Proof. 184 | unshelve econstructor. 185 | - exact (DiscreteFunc.discrF f). 186 | - exact (DiscreteFunc.fContI f). 187 | Defined. -------------------------------------------------------------------------------- /src/FormTopC/FormalSpace.v: -------------------------------------------------------------------------------- 1 | Require Import 2 | Prob.StdLib 3 | Algebra.Category 4 | CMorphisms 5 | Algebra.SetsC 6 | Algebra.OrderC 7 | Algebra.PreOrder 8 | Types.Setoid 9 | FormTopC.FormTop 10 | FormTopC.Cont. 11 | 12 | Set Universe Polymorphism. 13 | 14 | (** Bundle the definitions together *) 15 | (* Inductively generated formal topology *) 16 | Record IGt@{A P I API} : Type := 17 | { IGS :> PreISpace.t@{A P I} 18 | ; IGPO : PreO.t (le IGS) 19 | (** the proof that [le] is a preorder *) 20 | (* ; IGpos : FormTop.gtPos@{A P I API} IGS 21 | (** The space must have a positivity predicate. *) *) 22 | }. 23 | 24 | Global Instance IGT_PreO@{A P I API} 25 | (X : IGt@{A P I API}) : PreO.t (le X) := IGPO X. 26 | Global Instance IGTFT@{A P I API API'} (X : IGt@{A P I API}) : 27 | FormTop.t (toPSL (IGS X)) := 28 | FormTop.GCovL_formtop@{A P I API API'} _. 29 | 30 | 31 | Record t@{A P I} : Type := 32 | { S :> PreSpace.t@{A P I} 33 | ; PO : PreO.t@{A P} (le S) 34 | ; isFT : FormTop.t S 35 | }. 36 | 37 | Local Open Scope FT. 38 | 39 | Delimit Scope loc_scope with loc. 40 | Local Open Scope loc. 41 | 42 | Definition fromIGt@{A P I API API'} (A : IGt@{A P I API}) : t@{A P I} := 43 | {| S := toPSL (IGS A) 44 | ; isFT := IGTFT@{A P I API API'} A|}. 45 | 46 | Coercion fromIGt : IGt >-> t. 47 | 48 | Local Instance FT (A : t) : FormTop.t A := isFT A. 49 | Local Instance PreO (X : t) : PreO.t (le (PreSpace.S X)) := PO X. 50 | 51 | Section Properness. 52 | Require Import CMorphisms. 53 | Context {A : t}. 54 | 55 | Definition refl a U : In U a -> a <|[A] U. 56 | Proof. 57 | intros. apply FormTop.refl. assumption. 58 | Qed. 59 | 60 | Definition le_left (a b : S A) (U : Open A) 61 | : a <=[PreSpace.S A] b -> b <|[A] U -> a <|[A] U. 62 | Proof. 63 | intros; eapply FormTop.le_left; eassumption. 64 | Qed. 65 | 66 | Definition trans {a U} : 67 | a <|[A] U -> forall V, U <<|[A] V -> a <|[A] V. 68 | Proof. 69 | intros. eapply FormTop.trans; eassumption. 70 | Qed. 71 | 72 | Local Open Scope Subset. 73 | 74 | Definition le_right {a U V} : 75 | a <|[A] U -> a <|[A] V -> 76 | a <|[A] U ↓ V. 77 | Proof. 78 | auto using @FormTop.le_right with typeclass_instances. 79 | Qed. 80 | 81 | Definition monotone (U V : Subset (S A)) 82 | : U ⊆ V -> forall a : S A, a <|[A] U -> a <|[A] V. 83 | Proof. 84 | apply FormTop.monotone. 85 | Qed. 86 | 87 | Instance Cov_Proper : 88 | Proper (le (PreSpace.S A) --> Included ==> Basics.arrow) (PreSpace.Cov A). 89 | Proof. 90 | apply FormTop.Cov_Proper. 91 | Qed. 92 | 93 | (** This is just a flipped version of what's above. It 94 | shouldn't be needed. *) 95 | 96 | Instance Cov_Proper3 : 97 | Proper (le (PreSpace.S A) ==> Included --> flip Basics.arrow) (PreSpace.Cov A). 98 | Proof. 99 | apply FormTop.Cov_Proper3. 100 | Qed. 101 | 102 | Instance Cov_Proper2 : Proper (eq ==> Same_set ==> iffT) (PreSpace.Cov A). 103 | Proof. 104 | apply FormTop.Cov_Proper2. 105 | Qed. 106 | 107 | End Properness. 108 | 109 | Ltac trans H := apply (trans H); let T := type of H in 110 | match constr:(T) with 111 | | _ _ ?a _ => clear a H; intros a H 112 | end. 113 | 114 | Ltac etrans := match goal with 115 | | [ H : ?Cov ?X ?a _ |- ?Cov ?X ?a _ ] => try (trans H) 116 | end. 117 | 118 | Ltac join H1 H2 := let H := fresh H1 in 119 | pose proof (le_right H1 H2) as H; clear H1 H2. 120 | 121 | Ltac ejoin := repeat match goal with 122 | | [ H1 : ?Cov ?A ?a _, H2 : ?Cov ?A ?a _ |- ?Cov ?A ?a _ ] => join H1 H2 123 | end. 124 | 125 | Record cmap_car {LA LB : t} : Type := 126 | { mp : Cont.map LA LB 127 | ; mp_ok : Cont.t LA LB mp 128 | }. 129 | 130 | Arguments cmap_car LA LB : clear implicits. 131 | 132 | Require Import Types.Setoid. 133 | 134 | Lemma Equivalence_on {A B} 135 | {R : crelation B} 136 | {H : Equivalence R} 137 | (f : A -> B) 138 | : Equivalence (fun x y => R (f x) (f y)). 139 | Proof. 140 | econstructor; unfold Reflexive, Symmetric, Transitive; intros. 141 | - reflexivity. 142 | - symmetry; assumption. 143 | - etransitivity; eassumption. 144 | Qed. 145 | 146 | Definition cmap (LA LB : t) : Setoid. 147 | Proof. 148 | unshelve eapply ( 149 | {| sty := cmap_car LA LB 150 | ; seq := fun f g => Cont.func_EQ (mp f) (mp g) 151 | |}). 152 | apply Equivalence_on. 153 | Defined. 154 | 155 | Infix "~~>" := cmap (at level 75) : loc_scope. 156 | 157 | Definition id {LA : t} : LA ~~> LA := 158 | {| mp := Cont.id 159 | ; mp_ok := Cont.t_id |}. 160 | 161 | Definition comp {LA LB LD : t} 162 | (f : LB ~~> LD) (g : LA ~~> LB) : LA ~~> LD := 163 | {| mp := SetsC.compose (mp f) (mp g) 164 | ; mp_ok := Cont.t_compose (mp g) (mp f) (mp_ok g) (mp_ok f) 165 | |}. 166 | 167 | Infix "∘" := comp (at level 40, left associativity) : loc_scope. 168 | 169 | Definition LE_map {A B : t} (f g : A ~~> B) 170 | := Cont.func_LE (S := A) (mp f) (mp g). 171 | 172 | Local Open Scope setoid. 173 | 174 | Lemma LE_map_antisym {A B : t} (f g : A ~~> B) 175 | : LE_map f g -> LE_map g f -> f == g. 176 | Proof. 177 | unfold LE_map. intros. 178 | apply Cont.func_LE_antisym; assumption. 179 | Qed. 180 | 181 | Lemma EQ_map_LE {A B : t} (f g : A ~~> B) 182 | : f == g -> LE_map f g. 183 | Proof. 184 | unfold LE_map. intros. 185 | apply Cont.func_EQ_LE. assumption. 186 | Qed. 187 | 188 | Require Import CRelationClasses. 189 | 190 | Instance LE_map_PreOrder {A B} : PreOrder (@LE_map A B). 191 | Proof. 192 | constructor; unfold Reflexive, Transitive, LE_map; 193 | intros. 194 | - reflexivity. 195 | - etransitivity; eassumption. 196 | Qed. 197 | 198 | Lemma LE_map_compose {A B C} {f f' : A ~~> B} 199 | {g g' : B ~~> C} 200 | : LE_map f f' -> LE_map g g' 201 | -> LE_map (g ∘ f) (g' ∘ f'). 202 | Proof. 203 | unfold LE_map in *. 204 | intros. apply Cont.compose_proper_LE; 205 | try assumption. apply f'. 206 | Qed. 207 | 208 | Lemma EQ_map_compose {A B C} {f f' : A ~~> B} 209 | {g g' : B ~~> C} 210 | : f == f' -> g == g' 211 | -> g ∘ f == g' ∘ f'. 212 | Proof. 213 | intros. apply Cont.compose_proper; 214 | (apply mp_ok || assumption). 215 | Qed. 216 | 217 | Definition map_Sat {A B : t} (f : A ~~> B) 218 | : A ~~> B. 219 | Proof. 220 | unshelve eapply ( 221 | {| mp := Cont.Sat (S := A) (mp f) |}). 222 | apply Cont.t_Sat. apply mp_ok. 223 | Defined. 224 | 225 | Lemma map_Sat_EQ {A B : t} (f : A ~~> B) 226 | : f == map_Sat f. 227 | Proof. 228 | apply Cont.Sat_idempotent. 229 | Qed. 230 | 231 | Lemma EQ_map_Sat {A B : t} {f g : A ~~> B} 232 | : f == g 233 | -> map_Sat f == map_Sat g. 234 | Proof. 235 | eapply Cont.func_EQ_Sat. 236 | Qed. 237 | 238 | Local Open Scope Subset. 239 | 240 | Lemma Sat_Proper {A B : PreSpace.t} 241 | `{FTA : FormTop.t A} {F_ G_ : Cont.map A B} 242 | : F_ ==== G_ -> Cont.Sat F_ ==== Cont.Sat G_. 243 | Proof. 244 | intros H. 245 | apply RelIncl_RelSame; apply Cont.Sat_mono; 246 | apply RelSame_RelIncl. assumption. 247 | symmetry. assumption. 248 | Qed. 249 | 250 | Definition t_Cat : Category. 251 | Proof. 252 | unshelve eapply ( 253 | {| Ob := t 254 | ; Category.arrow := cmap 255 | ; Category.id := @id 256 | ; Category.compose := @comp |}); intros. 257 | - apply EQ_map_compose; assumption. 258 | - simpl. unfold Cont.id. 259 | unfold Cont.func_EQ, Cont.Sat. 260 | intros b a. split; intros H. 261 | + FormTop.etrans. destruct H as (x & l & m). 262 | apply cov_singleton in l. 263 | pose proof (Cont.cov (mp_ok f) (eq b) m l). 264 | clear m l x. 265 | eapply FormTop.monotone. 2: eassumption. 266 | apply union_eq. 267 | + eapply FormTop.monotone. 2: eassumption. 268 | intros x fx. 269 | unfold compose. exists b. split. reflexivity. 270 | assumption. 271 | - apply Sat_Proper. simpl. intros b a. 272 | split; intros H. 273 | + destruct H as (? & ? & ?). 274 | unfold Cont.id in *. 275 | eapply (Cont.le_left (mp_ok f)); eassumption. 276 | + exists a. split. assumption. unfold Cont.id. reflexivity. 277 | - simpl. unfold Cont.func_EQ. 278 | apply Sat_Proper. apply compose_assoc. 279 | Defined. 280 | 281 | Require Import CRelationClasses. 282 | Lemma truncate_Equiv A (f : crelation A) : 283 | Equivalence f -> RelationClasses.Equivalence (fun x y => inhabited (f x y)). 284 | Proof. 285 | intros H. constructor; 286 | unfold RelationClasses.Reflexive, 287 | RelationClasses.Symmetric, 288 | RelationClasses.Transitive; intros. 289 | - constructor. reflexivity. 290 | - destruct H0. constructor. symmetry. assumption. 291 | - destruct H0, H1. constructor. etransitivity; eassumption. 292 | Qed. 293 | 294 | Section IGProps. 295 | 296 | Context {A : IGt}. 297 | 298 | Lemma igl_ax_cov {a b : A} 299 | (H : a <=[A] b) (ix : PreISpace.Ix A b) 300 | : a <|[A] eq a ↓ PreISpace.C A b ix. 301 | Proof. 302 | apply FormTop.gle_infinity with b ix. 303 | assumption. 304 | intros. eapply (FormTop.refl (A := A)). assumption. 305 | Qed. 306 | 307 | Lemma ig_ax_cov (a : A) 308 | (ix : PreISpace.Ix A a) : 309 | a <|[A] PreISpace.C A a ix. 310 | Proof. 311 | pose proof (@igl_ax_cov a a (PreO.le_refl a) ix) as X. 312 | apply cov_downset. 313 | eapply FormTop.gmonotoneL. 314 | eapply Intersection_Included_r. 315 | apply X. 316 | Qed. 317 | 318 | 319 | End IGProps. -------------------------------------------------------------------------------- /src/FormTopC/IGSubspace.v: -------------------------------------------------------------------------------- 1 | Require Import 2 | Algebra.PreOrder 3 | Algebra.OrderC 4 | Algebra.SetsC 5 | FormTopC.FormTop 6 | FormTopC.FormalSpace 7 | FormTopC.Subspace. 8 | 9 | Local Open Scope FT. 10 | Local Open Scope Subset. 11 | 12 | (** Inductively generated spaces have arbitrary meets *) 13 | Section Meet. 14 | Context {A : PreOrder}. 15 | Context {Ix : Type}. 16 | Context {Ax : Ix -> A -> Type}. 17 | Variable (C : forall (ix : Ix) (a : A), Ax ix a -> Open A). 18 | 19 | Inductive MIx {a : A} : Type := 20 | | MkMIx : forall (ix : Ix), Ax ix a -> MIx. 21 | 22 | Arguments MIx : clear implicits. 23 | 24 | Definition MC (a : A) (ax : MIx a) : Open A := match ax with 25 | | MkMIx ix ax' => C ix a ax' 26 | end. 27 | 28 | Definition Component (ix : Ix) : PreISpace.t := 29 | {| PreISpace.S := A 30 | ; PreISpace.Ix := Ax ix 31 | ; PreISpace.C := C ix 32 | |}. 33 | 34 | Definition Meet : PreISpace.t := 35 | {| PreISpace.S := A 36 | ; PreISpace.Ix := MIx 37 | ; PreISpace.C := MC 38 | |}. 39 | 40 | Existing Instance GCovL_formtop. 41 | 42 | Lemma Meet_AxiomSetRefine_le (ix : Ix) 43 | : AxiomSetRefine (C ix) MC. 44 | Proof. 45 | unshelve econstructor. 46 | econstructor. eassumption. 47 | simpl. reflexivity. 48 | Qed. 49 | 50 | Lemma Meet_AxiomSetRefine_least I' (C' : forall s, I' s -> Open A) 51 | (H : forall ix : Ix, AxiomSetRefine (C ix) C') 52 | : AxiomSetRefine MC C'. 53 | Proof. 54 | unfold AxiomSetRefine. 55 | intros s i. destruct i as [ix a]. 56 | destruct (H ix s a) as [x s0]. 57 | exists x. simpl. assumption. 58 | Qed. 59 | 60 | Lemma Meet_le (ix : Ix) 61 | {a : A} {U : Open A} 62 | : a <|[toPSL (Component ix)] U -> a <|[toPSL Meet] U. 63 | Proof. 64 | apply AxRefineCovL. apply Meet_AxiomSetRefine_le. 65 | Qed. 66 | 67 | Hypothesis pos : forall ix : Ix, FormTop.gtPos (Component ix). 68 | 69 | Lemma loc_mono {A' : PreSpace.t} {FTA' : FormTop.t A'} 70 | {tPos : tPos A'} (a : A') (U : Open A') 71 | : Pos a -> a <|[A'] U -> Inhabited (eq a ↓ U ∩ Pos). 72 | Proof. 73 | intros H H'. 74 | eapply FormTop.mono. eassumption. 75 | apply le_right_eq. assumption. 76 | Qed. 77 | 78 | Lemma loc_top {A' : PreSpace.t} {FTA' : FormTop.t A'} 79 | {tPos : tPos A'} (a : A') 80 | : Pos a -> Inhabited (⇓ eq a ∩ Pos). 81 | Proof. 82 | intros H. 83 | pose proof (loc_mono a (fun _ => True) H). 84 | eapply Inhabited_mono. 2: eapply X. 85 | apply Intersection_Proper_le. apply Intersection_Included_l. 86 | reflexivity. apply FormTop.refl. unfold In. auto. 87 | Qed. 88 | 89 | Lemma MeetPos : FormTop.gtPos Meet. 90 | Proof. 91 | unshelve econstructor. 92 | - exact (fun x => forall ix : Ix, gPos (A := Component ix) x). 93 | - simpl. intros. eapply gmono_le; eauto. 94 | - simpl. intros. 95 | induction i; simpl. 96 | pose proof (gmono_ax b a0 a X (X0 ix)). 97 | revert X1. apply Inhabited_mono. 98 | simpl. apply Intersection_Proper_le. 99 | reflexivity. intros x Px. 100 | Abort. 101 | (** I don't think it's actually possible to compute the 102 | positivity predicate for meets of subspaces. Or, at the least, 103 | the positivity predicate isn't just the intersection of the 104 | respective positivity predicates for the subspaces. 105 | *) 106 | 107 | End Meet. 108 | 109 | (** Open and closed subspaces are inductively generated. *) 110 | Section OpenClosed. 111 | 112 | Context {A : PreOrder}. 113 | 114 | Variable V : Open A. 115 | 116 | Inductive ClosedIx {a : A} : Type := 117 | | InV : V a -> ClosedIx. 118 | 119 | Arguments ClosedIx : clear implicits. 120 | 121 | Definition ClosedC (a : A) (i : ClosedIx a) : Open A := 122 | match i with 123 | | InV _ => fun _ => False 124 | end. 125 | 126 | Inductive OpenIx {a : A} : Type := 127 | | MkOpenIx. 128 | 129 | Arguments OpenIx : clear implicits. 130 | 131 | Definition OpenC (a : A) (_ : OpenIx a) : Open A := V. 132 | 133 | Definition LocalizedPS (X : PreISpace.t) : PreSpace.t := 134 | {| PreSpace.S := PreISpace.S X 135 | ; PreSpace.Cov := FormTop.GCovL X 136 | |}. 137 | 138 | Definition A' : PreISpace.t := 139 | {| PreISpace.S := A 140 | ; PreISpace.C := ClosedC 141 | |}. 142 | 143 | (* 144 | Theorem same : PreSpace.Cov (LocalizedPS A') ==== PreSpace.Cov (Closed (A := fromIGt A) V). 145 | Proof. 146 | apply RelSame_iffT. intros a U. simpl. unfold CovC. split; intros H. 147 | - induction H. 148 | + apply FormTop.refl. right. assumption. 149 | + apply FormTop.le_left with b. assumption. 150 | assumption. 151 | + destruct i. 152 | * apply (FormTop.gle_infinity (A := A) a (V ∪ U) b i l). 153 | apply X. 154 | * rewrite l. apply FormTop.refl. left. assumption. 155 | - simpl in H. simpl in U. 156 | remember ((V : Open (PreISpace.S A)) ∪ (U : Open (PreISpace.S A))) as U' in H. 157 | induction H; subst. 158 | + destruct u. 159 | * eapply FormTop.gmonotoneL. Focus 2. 160 | pose proof (PreO.le_refl a) as aa. 161 | pose proof (FormTop.gle_infinity (A := A') a (fun _ => False) a (InV v) 162 | aa) as H0. 163 | apply H0. intros u H1. simpl in *. 164 | destruct H1. destruct d0. destruct i. firstorder. 165 | * apply FormTop.glrefl. assumption. 166 | + simpl in *. apply (FormTop.glle_left (A := A')) with b. assumption. apply IHGCovL. 167 | reflexivity. 168 | + apply (FormTop.gle_infinity (A := A') a _ b (Orig i)). 169 | assumption. intros. apply X. assumption. reflexivity. 170 | Qed. 171 | *) 172 | 173 | End OpenClosed. -------------------------------------------------------------------------------- /src/FormTopC/InfoBase.v: -------------------------------------------------------------------------------- 1 | Require Import 2 | CMorphisms 3 | Coq.Program.Basics 4 | FormTopC.FormTop 5 | FormTopC.Cont 6 | FormTopC.FormalSpace 7 | Algebra.OrderC 8 | Algebra.PreOrder 9 | Algebra.SetsC 10 | Prob.StdLib. 11 | 12 | Set Universe Polymorphism. 13 | Set Asymmetric Patterns. 14 | 15 | Local Open Scope Subset. 16 | Local Open Scope FT. 17 | 18 | (** Information bases, which are the predicative versions of 19 | Scott domains. Perhaps, see Definition 1.9 of [2]. 20 | Though my formulation is a little different; I build off 21 | of a pre-existing notion of a meet semi-lattice. 22 | 23 | Also, I directly show that this formal topology is 24 | inductively generated by generating it with an axiom set. *) 25 | Module InfoBase. 26 | Section InfoBase. 27 | 28 | Set Printing Universes. 29 | Universes A P AP. 30 | Variable (S : PreOrder@{A P}). 31 | 32 | Context {PO : PreO.t@{A P} (le S)}. 33 | 34 | (** The axiom set essentially says that if [s <= t], then 35 | [s] is covered by the singleton set [{t}]. *) 36 | Inductive Ix@{} {s : S} : Type@{P} := . 37 | 38 | Arguments Ix : clear implicits. 39 | 40 | Definition C@{} (s : S) (s' : Ix s) : Subset@{A P} S := match s' with 41 | end. 42 | 43 | Definition IBInd@{} : PreISpace.t@{A P P} := 44 | {| PreISpace.S := S 45 | ; PreISpace.Ix := Ix 46 | ; PreISpace.C := C 47 | |}. 48 | 49 | Definition Cov (s : S) (U : Subset@{A P} S) : Type@{P} := 50 | In (⇓ U) s. 51 | 52 | Definition IB@{} : PreSpace.t@{A P P} := 53 | {| PreSpace.S := S 54 | ; PreSpace.Cov := Cov |}. 55 | 56 | (** This axiom set is localized. *) 57 | Local Instance loc@{} : FormTop.localized@{A P P} IBInd. 58 | Proof. 59 | unfold FormTop.localized. intros. induction i. 60 | Qed. 61 | 62 | Theorem CovEquiv : PreSpace.Cov IB ==== GCovL IBInd. 63 | Proof. 64 | intros a U. simpl. unfold Cov. split; intros. 65 | - destruct X as [t Ut st]. 66 | apply FormTop.glle_left with t. assumption. 67 | apply FormTop.glrefl. assumption. 68 | - induction X. 69 | + exists a. assumption. reflexivity. 70 | + destruct IHX as [t Ut bt]. 71 | exists t. assumption. etransitivity; eassumption. 72 | + destruct i. 73 | Qed. 74 | 75 | (** The proof that [Cov] is a valid formal topology. *) 76 | Local Instance isCovG : FormTop.t (toPSL IBInd) := 77 | FormTop.GCovL_formtop _. 78 | 79 | (** Should prove this via homeomorphism with IBInd. *) 80 | Local Instance isCov@{} : FormTop.t IB. 81 | Proof. 82 | Admitted. 83 | 84 | Local Instance Pos : FormTop.gtPos IBInd. 85 | Proof. 86 | apply FormTop.gall_Pos. 87 | intros. destruct i. 88 | Qed. 89 | 90 | Definition InfoBase@{} : IGt@{A P P AP} := 91 | {| IGS := IBInd |}. 92 | 93 | End InfoBase. 94 | End InfoBase. 95 | 96 | Arguments InfoBase.Ix : clear implicits. 97 | 98 | Module InfoBaseCont. 99 | Section InfoBaseCont. 100 | 101 | Generalizable All Variables. 102 | 103 | Context {S : PreSpace.t} {POS : PreO.t (le (PreSpace.S S))}. 104 | Context {T : PreOrder} {POT : PreO.t (le T)}. 105 | 106 | Record ptNM {F : Subset T} : Type := 107 | { ptNM_local : forall {a b}, F a -> F b -> 108 | Inhabited (F ∩ (eq a ↓ eq b)) 109 | ; ptNM_le_right : forall a b, a <=[T] b -> F a -> F b 110 | ; ptNM_here : Inhabited F 111 | }. 112 | 113 | Arguments ptNM : clear implicits. 114 | 115 | Instance ptNM_proper : Proper ((eq ==> iffT) ==> iffT) ptNM. 116 | Proof. 117 | Admitted. 118 | 119 | 120 | (** I have no idea whether this is in fact 121 | a good definition *) 122 | Record tNM {F_ : Cont.map S (InfoBase.IB T)} := 123 | { NMle_left : forall a b c, a <=[PreSpace.S S] b -> F_ c b -> F_ c a 124 | ; NMle_right : forall a b c, F_ b a -> b <=[T] c -> F_ c a 125 | ; NMlocal : forall {a b c}, F_ b a -> F_ c a -> 126 | Inhabited ((fun t => F_ t a) ∩ (eq b ↓ eq c)) 127 | ; NMhere : forall s : S, In (union (fun _ => True) F_) s 128 | }. 129 | 130 | Arguments tNM : clear implicits. 131 | 132 | Hypothesis FTS : FormTop.t S. 133 | 134 | Theorem contNM : forall (F : Cont.map S (InfoBase.IB T)), 135 | tNM F 136 | -> Cont.t S (InfoBase.IB T) F. 137 | Proof. 138 | intros. constructor; intros. 139 | - unfold InfoBase.Cov. apply FormTop.refl. 140 | apply (NMhere X). 141 | - eapply (NMle_left X); eassumption. 142 | - unfold InfoBase.Cov. apply FormTop.refl. 143 | pose proof (NMlocal X X0 X1). 144 | destruct X2. destruct i. 145 | econstructor; eassumption. 146 | - simpl in *. unfold InfoBase.Cov in *. 147 | destruct X1 as [t0 Vt0 bt0]. 148 | apply FormTop.refl. exists t0. assumption. 149 | apply (NMle_right X) with b; assumption. 150 | Qed. 151 | 152 | End InfoBaseCont. 153 | 154 | Arguments tNM : clear implicits. 155 | Arguments ptNM : clear implicits. 156 | 157 | (* 158 | Section InfoBaseML. 159 | 160 | Context {S : PreSpace.t} {POS : PreO.t (le S)}. 161 | Context {T} `{MeetLat.t T}. 162 | 163 | Record pt {F : Subset T} : Type := 164 | { pt_local : forall {a b}, F a -> F b -> F (MeetLat.min a b) 165 | ; pt_le_right : forall a b, MeetLat.le a b -> F a -> F b 166 | ; pt_here : Inhabited F 167 | }. 168 | 169 | Arguments pt : clear implicits. 170 | 171 | Instance pt_proper : Proper ((eq ==> iffT) ==> iffT) pt. 172 | Proof. 173 | Admitted. 174 | 175 | Lemma down_min : forall a b, 176 | In (FormTop.down MeetLat.le a b) (MeetLat.min a b). 177 | Proof. 178 | intros. constructor; apply MeetLat.min_ok. 179 | Qed. 180 | 181 | Theorem pt_ptNM : forall F, pt F -> ptNM MeetLat.le F. 182 | Proof. 183 | intros F H0. destruct H0. constructor; eauto. 184 | intros. constructor 1 with (MeetLat.min a b). 185 | econstructor. unfold In. eauto. apply down_min. 186 | Qed. 187 | 188 | (** I have no idea whether this is in fact 189 | a good definition *) 190 | Record t {F_ : Cont.map S T} := 191 | { le_left : forall a b c, leS a b -> F_ c b -> F_ c a 192 | ; le_right : forall a b c, F_ b a -> MeetLat.le b c -> F_ c a 193 | ; local : forall {a b c}, F_ b a -> F_ c a -> 194 | F_ (MeetLat.min b c) a 195 | ; here : forall s : S, In (union (fun _ => True) F_) s 196 | }. 197 | 198 | Arguments t : clear implicits. 199 | 200 | Variable CovS : S -> Subset S -> Type. 201 | Hypothesis FTS : FormTop.t leS CovS. 202 | Let CovT : T -> Subset T -> Type := @InfoBase.Cov _ MeetLat.le. 203 | 204 | Theorem cont : forall (F : Cont.map S T), 205 | t F -> Cont.t leS MeetLat.le CovS CovT F. 206 | Proof. 207 | intros. apply contNM. assumption. 208 | destruct X. constructor; eauto. 209 | intros. specialize (local0 _ _ _ X X0). 210 | constructor 1 with (MeetLat.min b c). 211 | constructor; eauto. apply down_min. 212 | Qed. 213 | 214 | Definition above_pt (x : T) : pt (MeetLat.le x). 215 | Proof. 216 | constructor; intros. 217 | - apply MeetLat.min_ok; assumption. 218 | - etransitivity; eassumption. 219 | - econstructor. unfold In. reflexivity. 220 | Qed. 221 | 222 | Definition lift_op (f : S -> T) (y : T) (x : S) : Type := 223 | MeetLat.le (f x) y. 224 | 225 | Definition lift_monotone (f : S -> T) 226 | (fmono : forall x y, leS x y -> MeetLat.le (f x) (f y)) 227 | : t (lift_op f). 228 | Proof. 229 | constructor; unfold lift_op; intros. 230 | - etransitivity. apply fmono. eassumption. assumption. 231 | - etransitivity; eassumption. 232 | - apply MeetLat.min_ok; assumption. 233 | - econstructor. unfold In. constructor. reflexivity. 234 | Qed. 235 | 236 | End InfoBaseML. 237 | 238 | Arguments t {_} leS {_ _} F_. 239 | Arguments pt {_} {_} F. 240 | Arguments lift_op {_ _ _} f y x. 241 | 242 | Section Product. 243 | 244 | Context {S} `{MeetLat.t S}. 245 | Context {T} `{MeetLat.t T}. 246 | Context {U} `{MeetLat.t U}. 247 | 248 | Definition lift_binop (f : S -> T -> U) 249 | (result : U) (args : S * T) : Type := 250 | let (l, r) := args in MeetLat.le (f l r) result. 251 | 252 | Existing Instances MeetLat.product_ops MeetLat.product. 253 | 254 | Theorem lift_binop_monotone : forall (f : S -> T -> U) 255 | (fmono : forall x x' y y', MeetLat.le x x' -> MeetLat.le y y' 256 | -> MeetLat.le (f x y) (f x' y')) 257 | , t MeetLat.le (lift_binop f). 258 | Proof. 259 | intros. unfold lift_binop. constructor; intros. 260 | - destruct a, b. simpl in *. unfold prod_op in *. 261 | destruct X. rewrite <- X0. apply fmono; assumption. 262 | - destruct a. rewrite <- X0. assumption. 263 | - destruct a. apply MeetLat.min_ok; assumption. 264 | - destruct s. econstructor. constructor. 265 | reflexivity. 266 | Qed. 267 | 268 | End Product. 269 | 270 | 271 | Section Compose. 272 | 273 | Context {S} {leS : crelation S} {SOps} {MLS : MeetLat.t S SOps}. 274 | 275 | Instance OneOps : MeetLat.Ops True := MeetLat.one_ops. 276 | 277 | Theorem to_pt : forall (F : Cont.map True S), t MeetLat.le F -> 278 | pt (fun s => F s I). 279 | Proof. 280 | intros F H. constructor; intros. 281 | - apply (local H); assumption. 282 | - eapply (le_right H); eassumption. 283 | - pose proof (here H I) as X. destruct X. 284 | econstructor; eauto. 285 | Qed. 286 | 287 | Theorem from_pt : forall (F : Subset S), pt F -> t MeetLat.le (fun t' _ => F t'). 288 | Proof. 289 | intros F H. constructor; intros. 290 | - assumption. 291 | - eapply (pt_le_right H); eassumption. 292 | - apply (pt_local H); assumption. 293 | - pose proof (pt_here H) as X. destruct X. 294 | repeat (econstructor || eauto). 295 | Qed. 296 | 297 | Context {T TOps} {MLT : MeetLat.t T TOps}. 298 | Context {U UOps} {MLU : MeetLat.t U UOps}. 299 | 300 | Theorem t_compose (F : Cont.map S T) (G : Cont.map T U) 301 | : t MeetLat.le F -> t MeetLat.le G 302 | -> t MeetLat.le (compose G F). 303 | Proof. 304 | intros HF HG. 305 | constructor; unfold compose; intros. 306 | - destruct X0 as (t & Fbt & Gtc). 307 | exists t. split. 308 | + assumption. 309 | + eapply (le_left HF); eassumption. 310 | - destruct X as (t & Fat & Gtb). 311 | exists t. split. eapply (le_right HG); eassumption. 312 | assumption. 313 | - destruct X as (t & Fat & Gtb). 314 | destruct X0 as (t' & Fat' & Gt'c). 315 | exists (MeetLat.min t t'). split. 316 | + apply (local HG); eapply (le_left HG). 317 | apply MeetLat.min_l. assumption. 318 | apply MeetLat.min_r. assumption. 319 | + apply (local HF); assumption. 320 | - destruct (here HF s). destruct (here HG a). 321 | exists a0. constructor. exists a. auto. 322 | Qed. 323 | 324 | End Compose. 325 | 326 | Section EvalPt. 327 | 328 | Context {S SOps} {MLS : MeetLat.t S SOps}. 329 | Context {T TOps} {MLT : MeetLat.t T TOps}. 330 | 331 | Definition eval (F : Cont.map S T) (x : Subset S) (t : T) : Type := 332 | Inhabited (x ∩ F t). 333 | 334 | Theorem eval_pt (F : Cont.map S T) (x : Subset S) 335 | : pt x -> t MeetLat.le F -> pt (eval F x). 336 | Proof. 337 | intros Hx HF. 338 | pose proof (t_compose (fun t _ => x t) F (from_pt _ Hx) HF) as H. 339 | apply to_pt in H. 340 | eapply pt_proper. 2: eassumption. simpl_crelation. 341 | unfold eval. split; intros. 342 | - destruct X. destruct i. econstructor; eauto. 343 | - destruct X. destruct p. repeat (econstructor || eauto). 344 | Qed. 345 | 346 | End EvalPt. 347 | *) 348 | 349 | End InfoBaseCont. 350 | 351 | (* 352 | Arguments InfoBaseCont.t {S} leS {T} {TOps} F : rename, clear implicits. 353 | *) 354 | 355 | Module One. 356 | Section One. 357 | 358 | Definition OnePO : PreOrder := 359 | {| PO_car := True 360 | ; le := fun _ _ => True 361 | |}. 362 | 363 | Definition One : PreISpace.t := InfoBase.IBInd OnePO. 364 | 365 | Section One_intro. 366 | 367 | Context {S : PreSpace.t} {FTS : FormTop.t S}. 368 | 369 | Definition One_intro : Cont.map S (toPSL One) := 370 | fun (_ : True) (s : S) => True. 371 | 372 | Theorem One_intro_cont : 373 | Cont.t S (toPSL One) One_intro. 374 | Proof. 375 | constructor; unfold One_intro; intros; simpl; try auto. 376 | - apply FormTop.refl. unfold In; simpl. constructor 1 with I. 377 | unfold In; simpl; constructor. constructor. 378 | - apply FormTop.refl. unfold In; simpl. 379 | exists I. destruct b, c. unfold In. 380 | apply (down_eq (A := toPSL One)). auto. auto. 381 | - apply FormTop.refl. constructor 1 with I. 382 | induction X. destruct a0. assumption. 383 | assumption. destruct i. auto. 384 | Qed. 385 | 386 | End One_intro. 387 | 388 | Context {S : PreSpace.t} {POS : PreO.t (le (PreSpace.S S))}. 389 | 390 | Definition Point (f : Subset S) := Cont.t (toPSL One) S (fun t _ => f t). 391 | 392 | End One. 393 | End One. 394 | 395 | Module Sierpinski. 396 | 397 | Definition SierpPO : PreOrder := 398 | {| PO_car := bool 399 | ; le := Bool.leb |}. 400 | 401 | Definition Sierp := InfoBase.IBInd SierpPO. 402 | 403 | (* 404 | Definition sand : Cont.map (InfoBase.IBInd (ProdPO SierpPO SierpPO)) 405 | Sierp := 406 | InfoBaseCont.lift_binop andb. 407 | 408 | Existing Instances MeetLat.product MeetLat.product_ops. 409 | 410 | Theorem sand_cont : InfoBaseCont.t MeetLat.le sand. 411 | Proof. 412 | apply InfoBaseCont.lift_binop_monotone. 413 | simpl. intros. destruct x, x', y, y'; auto. 414 | Qed. 415 | 416 | Definition sor : Cont.map (bool * bool) bool := 417 | InfoBaseCont.lift_binop orb. 418 | 419 | Theorem sor_cont : InfoBaseCont.t MeetLat.le sor. 420 | Proof. 421 | apply InfoBaseCont.lift_binop_monotone. 422 | simpl. intros. destruct x, x', y, y'; auto; congruence. 423 | Qed. 424 | 425 | Definition const_cont (b : bool) : InfoBaseCont.pt (MeetLat.le (negb b)). 426 | Proof. 427 | apply InfoBaseCont.above_pt. 428 | Qed. 429 | *) 430 | 431 | End Sierpinski. -------------------------------------------------------------------------------- /src/FormTopC/Join.v: -------------------------------------------------------------------------------- 1 | Require Import 2 | FormTopC.FormTop 3 | Algebra.SetsC 4 | Algebra.OrderC. 5 | 6 | Module JoinTop. 7 | 8 | Section JoinTop. 9 | (** We assume we have some type [S] equipped 10 | with a partial order. *) 11 | (** NO! This context gives us two (different) preorders on S. 12 | Will need to fix this. *) 13 | Context {S : PreSpace.t} {ops : JoinLat.Ops S} {JL : JoinLat.t S ops}. 14 | 15 | Variable bot : S. 16 | 17 | Local Open Scope FT. 18 | 19 | Class t : Type := 20 | { FT :> FormTop.t S 21 | ; bot_ok : @PreO.bottom _ JoinLat.le bot 22 | ; bot_Cov : forall U, bot <| U 23 | ; join_left : forall a b U, a <| U -> b <| U -> JoinLat.max a b <| U 24 | }. 25 | 26 | Hypothesis FTS : t. 27 | (** Check properties we expect to hold *) 28 | 29 | Definition singleton (s s' : S) : Prop := s = s'. 30 | 31 | Lemma join_right : forall a b c, a <| (singleton b) 32 | -> a <| singleton (JoinLat.max b c). 33 | Proof. 34 | intros. eapply FormTop.trans. apply X. clear X. clear a. 35 | intros a sba. unfold singleton in sba. subst. 36 | apply FormTop.le_left with (JoinLat.max a c). 37 | apply JoinLat.max_ok. 38 | apply FormTop.refl. unfold In in *. subst. reflexivity. 39 | Qed. 40 | 41 | End JoinTop. 42 | 43 | (** Given a formal topology, we can always produce a join-closed formal 44 | topology by taking "free join" elements (i.e., the free monoid, a list) 45 | and interpreting the cover relation accordingly. 46 | *) 47 | Require Import Coq.Lists.List Types.List. 48 | Section Joinify. 49 | Context {S} {le : S -> Subset S} {PO : PreO.t le}. 50 | 51 | Definition leL (xs ys : list S) := forall x, 52 | member x xs -> { y : S & (le x y * member y ys)%type }. 53 | 54 | Definition eqL (xs ys : list S) : Type := leL xs ys * leL ys xs. 55 | 56 | Definition joinL (xs ys : list S) : list S := xs ++ ys. 57 | 58 | Definition ops' : JoinLat.Ops (list S) := 59 | {| JoinLat.le := leL 60 | ; JoinLat.eq := eqL 61 | ; JoinLat.max := joinL 62 | |}. 63 | 64 | Instance ops : JoinLat.Ops (list S) := ops'. 65 | 66 | 67 | Require Import CMorphisms. 68 | 69 | Instance joinPreO : @PreO.t (list S) leL. 70 | Proof. 71 | constructor; intros. 72 | - simpl. unfold leL. intros. exists x0. 73 | split. apply PreO.le_refl. assumption. 74 | - simpl in *. unfold leL in *. intros. 75 | destruct (X x0 X1). destruct p. 76 | destruct (X0 x1 m). destruct p. 77 | exists x2. split. eapply PreO.le_trans; eassumption. 78 | assumption. 79 | Qed. 80 | 81 | Instance joinPO : @PO.t (list S) leL JoinLat.eq. 82 | Proof. 83 | constructor. 84 | - apply joinPreO. 85 | - repeat intro. 86 | destruct X, X0. split; intros. 87 | transitivity x. assumption. transitivity x0; eassumption. 88 | transitivity y; try assumption. transitivity y0; eassumption. 89 | - intros. split; assumption. 90 | Qed. 91 | 92 | Lemma joinLE (xs ys xs' ys' : list S) : leL xs xs' -> leL ys ys' 93 | -> leL (xs ++ ys) (xs' ++ ys'). 94 | Proof. 95 | unfold leL in *. 96 | intros H H0 x H1. 97 | apply member_app in H1. 98 | destruct H1 as [In1 | In2]. 99 | - destruct (H x In1). exists x0. destruct p. 100 | split. assumption. apply member_app. left. assumption. 101 | - destruct (H0 x In2). exists x0. destruct p. 102 | split. assumption. apply member_app. right. assumption. 103 | Qed. 104 | 105 | 106 | Theorem JL : JoinLat.t (list S) ops. 107 | Proof. 108 | constructor. 109 | - apply joinPO. 110 | - repeat intro. simpl in *. unfold joinL. 111 | unfold eqL in *. destruct X, X0. 112 | auto using joinLE. 113 | - intros. simpl. unfold joinL. constructor; unfold leL; intros. 114 | + exists x. split. apply PreO.le_refl. apply member_app. auto. 115 | + exists x. split. apply PreO.le_refl. apply member_app. auto. 116 | + apply member_app in X1. destruct X1; [apply X | apply X0]; assumption. 117 | Qed. 118 | 119 | Variable Cov : S -> (Subset S) -> Prop. 120 | 121 | Definition LCov (a : list S) (U : Subset (list S)) := 122 | forall s : S, member s a -> Cov s (fun s' => { xs : list S & (member s' xs * U xs)%type }). 123 | 124 | Instance joinify : FormTop.t le Cov -> t nil LCov. 125 | Proof. 126 | intros FTS. 127 | constructor. 128 | - constructor. 129 | + unfold LCov. intros. apply FormTop.refl. 130 | exists a. split; assumption. 131 | + unfold LCov. intros. eapply FormTop.trans. 132 | eapply H. assumption. simpl. 133 | clear s X. intros. 134 | destruct X as (xs & Inxs & Uxs). 135 | eapply H0. eassumption. assumption. 136 | + simpl. unfold LCov. intros. unfold leL in *. 137 | specialize (X s X0). destruct X as (y & sy & Inyb). 138 | apply FormTop.le_left with y. assumption. 139 | apply H. assumption. 140 | + unfold LCov. intros. 141 | pose proof (fun (s' : S) (insa : member s' a) => 142 | @FormTop.le_right _ _ _ _ s' _ _ (H s' insa) (H0 s' insa)). 143 | eapply FormTop.monotone. 2: apply (H1 s X). simpl. 144 | unfold Included, pointwise_rel, arrow; intros. 145 | destruct X0. destruct d, d0. unfold flip, SetsC.In in *. 146 | destruct i as (xs & Inxs & Uxs). 147 | destruct i0 as (ys & Inys & Vys). 148 | exists (cons a0 nil). split. left. 149 | constructor; (econstructor; [eassumption|]); 150 | unfold flip, leL; intros x' inx; simpl in inx; inv inx; subst; 151 | match goal with 152 | | [ H: member ?z ?xs |- { y : _ & (_ * member y ?xs)%type } ] => exists z; split; auto 153 | end. 154 | inv X0. inv X0. 155 | - unfold PreO.bottom. simpl. unfold leL. intros. 156 | inv X. 157 | - unfold LCov. intros. inv X. 158 | - unfold LCov. simpl. unfold joinL. intros. 159 | apply member_app in X. destruct X. 160 | + apply H; assumption. 161 | + apply H0; assumption. 162 | Qed. 163 | 164 | End Joinify. 165 | 166 | End JoinTop. 167 | -------------------------------------------------------------------------------- /src/FormTopC/Lift.v: -------------------------------------------------------------------------------- 1 | Require Import 2 | Coq.Classes.CMorphisms 3 | Algebra.SetsC 4 | Algebra.OrderC 5 | Algebra.PreOrder 6 | FormTopC.FormTop 7 | FormTopC.FormalSpace 8 | FormTopC.Cont. 9 | 10 | Set Universe Polymorphism. 11 | Set Asymmetric Patterns. 12 | 13 | Local Open Scope FT. 14 | Local Open Scope Subset. 15 | 16 | Module Lift. 17 | 18 | Section Lift. 19 | 20 | Variable (S : IGt). 21 | 22 | Definition lift_subset (U : Subset S) : Subset (option S) := 23 | fun ms => match ms with 24 | | Some x => In U x 25 | | None => False 26 | end. 27 | 28 | Definition unlift_subset (U : Subset (option S)) : Subset S := 29 | fun s => U (Some s). 30 | 31 | Definition le (mx my : option S) : Type := match my with 32 | | None => True 33 | | Some y => match mx with 34 | | None => False 35 | | Some x => x <=[S] y 36 | end 37 | end. 38 | 39 | Local Instance PreO_le : PreO.t le. 40 | Proof. 41 | constructor; intros. 42 | - destruct x; simpl; auto. reflexivity. 43 | - destruct x, y, z; simpl in *; 44 | constructor || contradiction || 45 | (etransitivity ; eassumption) || eassumption. 46 | Qed. 47 | 48 | Definition Ix (ma : option S) : Type := match ma with 49 | | Some a => PreISpace.Ix S a 50 | | None => False 51 | end. 52 | 53 | Definition C (ma : option S) : Ix ma -> Subset (option S) := 54 | match ma as ma' return Ix ma' -> _ with 55 | | Some a => fun i => lift_subset (PreISpace.C S a i) 56 | | None => fun contra => False_rect _ contra 57 | end. 58 | 59 | Definition LiftedPO : PreOrder := 60 | {| PO_car := option S 61 | ; PreOrder.le := le 62 | |}. 63 | 64 | Definition Lifted : PreISpace.t := 65 | {| PreISpace.S := LiftedPO 66 | ; PreISpace.Ix := Ix 67 | ; PreISpace.C := C 68 | |}. 69 | 70 | Local Instance loc (H : FormTop.localized S) : FormTop.localized Lifted. 71 | Proof. 72 | unfold FormTop.localized in *. 73 | intros. destruct c; try contradiction. 74 | destruct a; try contradiction. 75 | destruct (H p0 p X i). 76 | exists x. simpl. intros. simpl in X. 77 | intros u Pu. destruct u; try contradiction. 78 | simpl in Pu. destruct (i0 _ Pu). clear i0. 79 | le_downH d. destruct d0. 80 | split. le_down. assumption. 81 | exists (Some a). unfold In. simpl. assumption. assumption. 82 | Qed. 83 | 84 | Inductive bottom : Subset (option S) := 85 | | MkBottom : bottom None. 86 | 87 | Theorem Cov_None V : None <|[toPSL Lifted] V -> In V None. 88 | Proof. 89 | intros cov. remember None as none. 90 | induction cov; subst; simpl in *; try contradiction; auto. 91 | - destruct b; simpl in *. contradiction. 92 | apply IHcov. reflexivity. 93 | - induction b; simpl in *; contradiction. 94 | Qed. 95 | 96 | Theorem pt_bottom : Cont.pt (toPSL Lifted) bottom. 97 | Proof. 98 | constructor. 99 | - constructor 1 with None. constructor. 100 | - intros b c X X0. induction X, X0. 101 | constructor 1 with None. 102 | repeat (econstructor || eauto). 103 | - intros. constructor 1 with None. 104 | destruct X; try contradiction. 105 | constructor. constructor. apply Cov_None. assumption. 106 | Qed. 107 | 108 | Definition inj : Cont.map S (toPSL Lifted) := fun my x => match my with 109 | | None => True 110 | | Some y => x <=[S] y 111 | end. 112 | 113 | Local Open Scope Subset. 114 | 115 | Lemma inj_lift V x : In (union (lift_subset V) inj) x -> 116 | x <|[S] V. 117 | Proof. intros X. destruct X. unfold In in *. 118 | destruct a; simpl in *. apply FormTop.le_left with p. 119 | assumption. apply FormTop.refl. assumption. 120 | contradiction. 121 | Qed. 122 | 123 | Theorem inj_cont : Cont.t S (toPSL Lifted) inj. 124 | Proof. 125 | constructor; intros. 126 | - apply FormTop.refl. constructor 1 with None. 127 | constructor. simpl. constructor. 128 | - destruct b; simpl in *. 129 | etransitivity; eassumption. constructor. 130 | - apply FormTop.refl. destruct b; simpl in *. 131 | + constructor 1 with (Some a). 132 | split; le_down; assumption. simpl. reflexivity. 133 | + destruct c; simpl in *. 134 | * constructor 1 with (Some a). split; le_down; assumption. 135 | simpl. reflexivity. 136 | * constructor 1 with None. split; le_down; constructor. 137 | simpl. constructor. 138 | - destruct b; simpl in *. 139 | + remember (Some p) as somes. 140 | assert (le (Some a) somes). subst. simpl. assumption. clear Heqsomes. 141 | clear X. 142 | generalize dependent a. 143 | induction X0; intros. 144 | * destruct a; simpl in *. 145 | { apply FormTop.le_left with p0. assumption. 146 | apply FormTop.refl. constructor 1 with (Some p0). 147 | assumption. simpl. reflexivity. } 148 | { apply FormTop.glrefl. constructor 1 with None. 149 | assumption. simpl. assumption. } 150 | * apply IHX0. etransitivity; eassumption. 151 | * destruct a; try contradiction. 152 | simpl in *. 153 | apply FormTop.le_left with p0. assumption. 154 | destruct b. simpl in l. 155 | simpl in i. 156 | apply FormTop.gle_infinity with p1 i. assumption. 157 | intros. destruct X0. le_downH d. destruct d0. 158 | eapply X. split. le_down. instantiate (1 := Some u). 159 | eassumption. exists (Some a). simpl. unfold In. 160 | simpl. assumption. simpl. assumption. reflexivity. 161 | induction i. 162 | induction b; simpl in *; contradiction. 163 | + apply FormTop.glrefl. constructor 1 with None. 164 | apply Cov_None. assumption. simpl. constructor. 165 | Qed. 166 | 167 | End Lift. 168 | 169 | End Lift. -------------------------------------------------------------------------------- /src/FormTopC/Locale.v: -------------------------------------------------------------------------------- 1 | Require Import 2 | CMorphisms 3 | FormTopC.FormTop 4 | Algebra.SetsC 5 | Algebra.OrderC 6 | Algebra.PreOrder 7 | Algebra.FrameC 8 | FormTopC.FormalSpace. 9 | 10 | Set Universe Polymorphism. 11 | 12 | Local Open Scope Subset. 13 | Local Open Scope FT. 14 | 15 | Existing Instances FormalSpace.Cov_Proper 16 | FormalSpace.Cov_Proper2 17 | FormalSpace.Cov_Proper3 18 | FormalSpace.FT 19 | FormalSpace.PreO 20 | FormTop.Cov_Proper 21 | FormTop.Cov_Proper2 22 | FormTop.Cov_Proper3. 23 | 24 | Import FormTop. 25 | 26 | Section ToFrame. 27 | Universe Variables A P X P'. 28 | Variable (A : FormalSpace.t@{A P X}). 29 | 30 | Definition T : Type@{P'} := Open (S A). 31 | 32 | Definition Sat (U : T) : T := fun s => s <|[A] U. 33 | 34 | Definition leA (U V : T) : Type@{P'} := Sat U ⊆ Sat V. 35 | 36 | Definition eqA (U V : T) : Type@{P'} := Sat U === Sat V. 37 | 38 | Definition minA (U V : T) : T := U ↓ V. 39 | 40 | Inductive supA I (f : I -> T) : T := 41 | MksupA : forall i s, f i s -> In (supA I f) s. 42 | 43 | Definition LOps : Lattice.Ops T := 44 | {| Lattice.le := leA 45 | ; Lattice.eq := eqA 46 | ; Lattice.max := Union 47 | ; Lattice.min := minA 48 | |}. 49 | 50 | Instance LOps' : Lattice.Ops T := LOps. 51 | 52 | Definition FOps : @Frame.Ops T := 53 | {| Frame.LOps := LOps 54 | ; Frame.top := fun _ => True 55 | ; Frame.sup := supA 56 | |}. 57 | 58 | Instance FOps' : @Frame.Ops T := FOps. 59 | 60 | Axiom undefined : forall A, A. 61 | 62 | Theorem FramePreO : @PreO.t T leA. 63 | Proof. 64 | constructor; unfold leA; intros. 65 | - reflexivity. 66 | - etransitivity; eassumption. 67 | Qed. 68 | 69 | Theorem FramePO : @PO.t T leA eqA. 70 | Proof. 71 | constructor; unfold eqA; intros. 72 | - apply FramePreO. 73 | - unfold leA. unfold Proper, respectful. 74 | intros. admit. (*rewrite X, X0. reflexivity. *) 75 | - unfold leA in *. split; intros. 76 | apply X. assumption. apply X0. assumption. 77 | Admitted. 78 | 79 | 80 | Theorem Sat_Intersection : forall U V, 81 | Sat (U ∩ V) ⊆ Sat U ∩ Sat V. 82 | Proof. 83 | intros. constructor; unfold Sat, In in *. 84 | rewrite <- (Intersection_Included_l _ U V); eassumption. 85 | rewrite <- (Intersection_Included_r _ U V); eassumption. 86 | Qed. 87 | 88 | Theorem Sat_Union : forall U V : Subset A, 89 | Sat U ∪ Sat V ⊆ Sat (U ∪ V). 90 | Proof. 91 | intros. unfold Included, pointwise_rel, arrow; intros a H. 92 | destruct H; unfold In, Sat in *. 93 | rewrite <- (Union_Included_l _ U V). assumption. 94 | rewrite <- Union_Included_r. assumption. 95 | Qed. 96 | 97 | Theorem Sat_mono : forall U, U ⊆ Sat U. 98 | Proof. 99 | intros. unfold Included, pointwise_rel, arrow, Sat. 100 | intros. apply refl. assumption. 101 | Qed. 102 | 103 | Theorem Sat_mono2 : forall U V, U ⊆ V -> Sat U ⊆ Sat V. 104 | Proof. 105 | intros U V H. unfold Included, pointwise_rel, arrow, Sat. 106 | intros a X. rewrite <- H. assumption. 107 | Qed. 108 | 109 | Theorem Cov_Sat : forall a U, iffT (a <|[A] U) (a <|[A] Sat U). 110 | Proof. 111 | intros. split; intros. rewrite <- Sat_mono. assumption. 112 | etrans. assumption. 113 | Qed. 114 | 115 | Theorem Sat_downset : forall U, Sat U === Sat (⇓ U). 116 | Proof. 117 | intros. split. 118 | - apply Sat_mono2. unfold Included, In, downset. 119 | intros. econstructor. eassumption. reflexivity. 120 | - unfold Included, Sat, In, downset. 121 | intros H. etrans. destruct H. 122 | rewrite l. apply refl. assumption. 123 | Qed. 124 | 125 | Existing Instances Union_Proper_le_flip Union_Proper_eq. 126 | 127 | Theorem FrameLatt : Lattice.t T LOps. 128 | Proof. 129 | constructor; intros. 130 | - admit. (*apply FramePO. *) 131 | - simpl. unfold Proper, respectful, eqA. intros x y H x0 y0 H0. 132 | split; unfold Included, In, Sat; intros. 133 | + apply Cov_Sat. rewrite <- Sat_Union. 134 | eapply FormTop.Cov_Proper. reflexivity. 135 | eapply Union_Proper_le; apply Same_set_Included; symmetry; 136 | eassumption. 137 | rewrite <- !Sat_mono. assumption. 138 | + apply Cov_Sat. rewrite <- Sat_Union. 139 | eapply FormTop.Cov_Proper. reflexivity. 140 | eapply Union_Proper_le; apply Same_set_Included; 141 | eassumption. 142 | rewrite <- !Sat_mono. assumption. 143 | - constructor. 144 | + simpl. unfold leA. apply Sat_mono2. 145 | apply Union_Included_l. 146 | + simpl. unfold leA. apply Sat_mono2. 147 | apply Union_Included_r. 148 | + simpl. unfold leA. intros. 149 | unfold Sat, Included, pointwise_rel, arrow. 150 | intros a H. etrans. rewrite Cov_Sat. destruct H. 151 | * apply refl. apply X. apply refl. assumption. 152 | * apply refl. apply X0. apply refl. assumption. 153 | - simpl. unfold Proper, respectful, eqA, minA. 154 | intros x y H x0 y0 H0. 155 | apply Included_Same_set. 156 | + 157 | (* universes broke rewriting 158 | rewrite Sat_Intersection. 159 | rewrite <- Sat_downset. 160 | rewrite H, H0. unfold Included, pointwise_rel, arrow; 161 | intros a H1. 162 | destruct H1. unfold Sat, In in *. 163 | join s s0. assumption. 164 | *) admit. 165 | + 166 | (* universes broke rewriting 167 | rewrite Sat_Intersection. 168 | rewrite <- !Sat_downset. 169 | rewrite <- H, <- H0. unfold Included, pointwise_rel, arrow; 170 | intros a H1. 171 | destruct H1. unfold Sat, In in *. 172 | join s s0; assumption. *) 173 | admit. 174 | - simpl. constructor; unfold leA, minA; intros. 175 | + unfold Sat, Included, pointwise_rel, arrow; intros a H. 176 | etrans. destruct H as (H0 & H1). destruct H0. 177 | rewrite l0. apply refl. assumption. 178 | + unfold Sat, Included, pointwise_rel, arrow; intros a H. 179 | etrans. destruct H as (H0 & H1). destruct H1. 180 | rewrite l0. apply refl. assumption. 181 | + unfold Sat, Included, pointwise_rel, arrow; intros a H. 182 | etrans. apply le_right. apply Cov_Sat. 183 | apply refl. apply X. apply refl. assumption. 184 | apply Cov_Sat. apply refl. apply X0. apply refl. 185 | assumption. 186 | Admitted. 187 | 188 | Theorem Frame : @Frame.t T FOps. 189 | Proof. 190 | constructor; intros. 191 | - apply FrameLatt. 192 | - simpl. unfold PreO.top, leA. 193 | intros. apply Sat_mono2. unfold Included, In, pointwise_rel, arrow. 194 | auto. 195 | - simpl. unfold eqA, pointwise_relation. 196 | unfold Proper, respectful. intros. 197 | split; unfold Included, Sat; intros. 198 | + etrans. destruct X0. 199 | apply (trans (U := y i)). 200 | apply Cov_Sat. apply refl. apply (X i). apply refl. assumption. 201 | specialize (X i). 202 | intros. apply refl. econstructor. eassumption. 203 | + etrans. destruct X0. 204 | apply (trans (U := x i)). 205 | apply Cov_Sat. apply refl. apply (X i). apply refl. assumption. 206 | intros. 207 | apply refl. econstructor; eassumption. 208 | - simpl. constructor; unfold leA; intros. 209 | + apply Sat_mono2. unfold Included, pointwise_rel, arrow; intros. 210 | econstructor; eassumption. 211 | + unfold Included, Sat, pointwise_rel, arrow; intros. 212 | etrans. destruct X0. 213 | apply Cov_Sat. apply refl. apply (X i). apply refl. assumption. 214 | - simpl. unfold minA, eqA. 215 | split; apply Sat_mono2. 216 | + unfold Included, pointwise_rel, arrow. 217 | intros a0 H. destruct H as (H & H0). 218 | destruct H0. destruct i. 219 | repeat (econstructor; try eassumption). 220 | + unfold Included, pointwise_rel, arrow. 221 | intros a0 H. destruct H. 222 | eapply down_Proper. 3: eassumption. reflexivity. 223 | econstructor; eassumption. 224 | Qed. 225 | 226 | End ToFrame. 227 | 228 | Require Import FormTopC.Cont. 229 | 230 | Section FrameMorphism. 231 | 232 | Context {A B : FormalSpace.t}. 233 | 234 | Variable F_ : Cont.map A B. 235 | Hypothesis cont : Cont.t A B F_. 236 | 237 | Local Instance POFS : @PO.t (T A) (leA A) (eqA A). 238 | Proof. 239 | eapply FramePO. 240 | Qed. 241 | 242 | Local Instance POFT : @PO.t (T B) (leA B) (eqA B). 243 | Proof. 244 | eapply FramePO. 245 | Qed. 246 | 247 | Require Import FormTopC.Cont. 248 | 249 | Theorem monotone : PreO.morph (leA B) (leA A) 250 | (Cont.frame F_). 251 | Proof. 252 | unfold PreO.morph. intros. unfold Cont.frame. 253 | simpl. unfold leA, Sat. 254 | unfold Included, pointwise_rel, arrow. 255 | intros a' H. FormTop.trans H. 256 | destruct H as [t' at' Fa't']. 257 | apply (Cont.cov cont _ Fa't'). apply X. unfold Sat. 258 | apply FormTop.refl. assumption. 259 | Qed. 260 | 261 | 262 | Require Import CMorphisms. 263 | 264 | Theorem Sat_Proper : forall A, 265 | Proper (Same_set ==> Same_set) (Sat A). 266 | Proof. 267 | intros. unfold Proper, respectful. intros. unfold Sat. 268 | apply Same_set_iff. intros. apply FormTop.subset_equiv. 269 | assumption. 270 | Qed. 271 | 272 | Existing Instances FormTop.Cov_Proper union_Proper. 273 | 274 | (** This shouldn't be necessary. It should essentially 275 | follow from union_Proper. *) 276 | Local Instance union_Proper_flip : 277 | forall A B, Proper ((@Included A) --> eq ==> flip (@Included B)) union. 278 | Proof. 279 | intros. unfold Proper, respectful; intros. subst. 280 | apply union_Proper. assumption. reflexivity. 281 | Qed. 282 | 283 | Theorem toFrame : Frame.morph (FOps B) (FOps A) (Cont.frame F_). 284 | Proof. 285 | unshelve eapply Frame.morph_easy. 286 | - eapply Frame. 287 | - eapply Frame. 288 | - repeat intro. split; apply monotone; simpl in X; 289 | apply Same_set_Included; repeat (eassumption || symmetry). 290 | - unfold Cont.frame. simpl. unfold eqA, Sat. 291 | intros. split; unfold Included, In; intros. 292 | + apply FormTop.refl. unfold In. auto. 293 | + pose proof (Cont.here cont a). 294 | FormTop.ejoin. FormTop.etrans. 295 | destruct X1. destruct d, d0. 296 | destruct i0. clear i i0. clear l. 297 | rewrite l0. apply FormTop.refl. 298 | repeat (econstructor; try eassumption). 299 | - intros. unfold Cont.frame. simpl. apply Included_Same_set; 300 | unfold leA, Sat, Included, pointwise_rel, arrow; intros. 301 | * FormTop.trans X. unfold minA in X. 302 | destruct X. destruct i. destruct d, d0. 303 | unfold minA. 304 | apply FormTop.le_right; 305 | apply (Cont.cov cont _ f). 306 | apply FormTop.le_left with a1. assumption. 307 | apply FormTop.refl. assumption. 308 | apply FormTop.le_left with a2. assumption. 309 | apply FormTop.refl. assumption. 310 | * FormTop.trans X. unfold minA in *. 311 | destruct X. destruct d, d0. destruct i, i0. 312 | apply (Cont.le_left cont _ _ _ l) in f. 313 | apply (Cont.le_left cont _ _ _ l0) in f0. 314 | pose proof (Cont.local cont f f0) as H. 315 | clear f f0. 316 | eapply FormTop.trans. eassumption. 317 | intros. destruct X. destruct i1. 318 | destruct d, d0. unfold In in *. subst. 319 | apply FormTop.refl. 320 | exists a5. split; eexists; eassumption. eassumption. 321 | - unfold Cont.frame. simpl. intros. 322 | unfold eqA. eapply Sat_Proper; try eassumption. 323 | intros; split; unfold Included, In; intros. 324 | + destruct X. destruct i. repeat econstructor; eauto. 325 | + destruct X. destruct u. repeat econstructor; eauto. 326 | Qed. 327 | 328 | Definition toCmap : Frame.cmap (FOps A) (FOps B) := 329 | {| Frame.finv := Cont.frame F_ 330 | ; Frame.cont := toFrame |}. 331 | 332 | End FrameMorphism. 333 | -------------------------------------------------------------------------------- /src/FormTopC/MReal.v: -------------------------------------------------------------------------------- 1 | Require Import 2 | FormTopC.FormTop 3 | FormTopC.Cont 4 | Algebra.OrderC 5 | Algebra.PreOrder 6 | Numbers.QPosFacts 7 | CoRN.metric2.Metric 8 | FormTopC.Metric 9 | CoRN.model.totalorder.QposMinMax 10 | QArith.Qminmax 11 | CoRN.algebra.COrdAbs 12 | CoRN.model.ordfields.Qordfield 13 | CoRN.model.metric2.Qmetric 14 | CoRN.metric2.ProductMetric 15 | Algebra.SetsC. 16 | 17 | Definition unit_RSetoid : RSetoid. 18 | Proof. 19 | refine ( 20 | {| st_car := unit 21 | ; st_eq := fun _ _ => True |}); firstorder. 22 | Defined. 23 | 24 | (* One-point metric space *) 25 | Definition MOne : MetricSpace. 26 | Proof. 27 | unshelve econstructor. 28 | - exact (unit_RSetoid). 29 | - exact (fun _ _ _ => True). 30 | - simpl. intros. split; intros; auto. 31 | - simpl. constructor. 32 | + unfold Reflexive. auto. 33 | + unfold Symmetric. auto. 34 | + auto. 35 | + auto. 36 | + simpl. auto. 37 | Defined. 38 | 39 | Import Metric. 40 | 41 | Existing Instances PreO PreO.PreOrder_I. 42 | 43 | Lemma tt_cont : IGCont.pt Metric (fun _ : Ball MOne => True). 44 | Proof. 45 | constructor. 46 | - exists (tt, Qpos1). unfold In. auto. 47 | - intros. destruct b, c. destruct m, m0. 48 | exists (tt, Qpos_min q q0). split. 49 | split; le_down; apply le_ball_center. 50 | apply Qpos_min_lb_l. apply Qpos_min_lb_r. 51 | auto. 52 | - auto. 53 | - intros a c ix l H. destruct ix. 54 | destruct a, c. destruct H. destruct m, m0. 55 | simpl. 56 | + exists (tt, Qpos_min q0 q). split. auto. 57 | split. le_down. apply le_ball_center. apply Qpos_min_lb_l. 58 | exists (tt, q). reflexivity. 59 | apply le_ball_center. apply Qpos_min_lb_r. 60 | + simpl in *. destruct a, c, H. 61 | destruct m, m0. 62 | destruct (Qpos_smaller q). 63 | exists (tt, x). split. auto. 64 | split. le_down. 65 | apply le_ball_center. apply Qlt_le_weak. assumption. 66 | exists (tt, x). unfold In. apply lt_ball_center. 67 | apply (@le_ball_radius MOne (tt, q) (tt, q0)) in l. 68 | simpl in l. 69 | eapply Qlt_le_trans; eassumption. reflexivity. 70 | Qed. 71 | 72 | Section Yoneda. 73 | Context {X : MetricSpace}. 74 | 75 | Lemma from_One_lip 76 | (f : MOne -> X) (k : Qpos) : Lipschitz f k. 77 | Proof. 78 | unfold Lipschitz. 79 | simpl. intros. destruct x, x'. 80 | apply ball_refl. 81 | Qed. 82 | 83 | (** Applying this map to the unique point in the 84 | one-point space will give us the point which is 85 | the embedding of 86 | [x: X] into its metric completion. 87 | *) 88 | Definition from_One_cont (x : X) : 89 | IGCont.t (toPSL Metric) Metric 90 | (lift (fun _ : MOne => x) Qpos1). 91 | Proof. 92 | apply Cont. apply from_One_lip. 93 | Qed. 94 | 95 | End Yoneda. 96 | 97 | (** Now let's get to the real numbers. *) 98 | 99 | Definition MQ : MetricSpace := Q_as_MetricSpace. 100 | 101 | Definition binop (f : MQ -> MQ -> MQ) (p : ProductMS MQ MQ) : MQ := 102 | let (x, y) := p in f x y. 103 | 104 | Lemma Qle_eq {x y : Q} : x == y -> x <= y. 105 | Proof. 106 | intros xeqy. rewrite xeqy. reflexivity. 107 | Qed. 108 | 109 | Lemma plus_Lip : Lipschitz (binop Qplus) (Qpos1 + Qpos1). 110 | Proof. 111 | unfold Lipschitz. intros. 112 | destruct x, x', H. 113 | unfold binop. 114 | eapply ball_weak_le. 115 | Focus 2. eapply Qball_plus; eassumption. 116 | simpl. apply Qle_eq. ring. 117 | Qed. 118 | 119 | Local Open Scope Q. 120 | 121 | (* This lemma is taken from 122 | [QboundBelow_uc_prf] here: 123 | https://github.com/robbertkrebbers/corn/blob/8b864e218dd1a682746c25c4b56e225f120be957/reals/fast/CRGroupOps.v#L396 124 | *) 125 | Lemma Qball_between : 126 | forall e a b0 b1, Qball e b0 b1 -> b0 <= a <= b1 -> Qball e a b1. 127 | Proof. 128 | intros e a b0 b1 H [H1 H2]. 129 | unfold Qball in *. 130 | unfold AbsSmall in *. 131 | split. 132 | apply Qle_trans with (b0-b1). 133 | tauto. 134 | apply (minus_resp_leEq _ b0). 135 | assumption. 136 | apply Qle_trans with 0. 137 | apply (shift_minus_leEq _ a). 138 | stepr b1. 139 | assumption. 140 | simpl; ring. 141 | apply Qpos_nonneg. 142 | Qed. 143 | 144 | 145 | Lemma max_Lip : Lipschitz (binop Qmax) Qpos1. 146 | Proof. 147 | unfold Lipschitz. intros. 148 | destruct x, x', H. unfold binop. simpl. 149 | simpl in *. 150 | eapply ball_weak_le. eapply Qle_eq. simpl. ring_simplify. 151 | reflexivity. 152 | apply Q.max_case_strong. 153 | intros. rewrite <- H1. assumption. 154 | apply Q.max_case_strong. intros. rewrite <- H1. 155 | auto. auto. intros. 156 | eapply Qball_between. 157 | admit. admit. 158 | apply Q.max_case_strong. intros. rewrite <- H1. auto. 159 | intros. 160 | admit. 161 | auto. 162 | Admitted. 163 | 164 | Lemma min_Lip : Lipschitz (binop Qmin) Qpos1. 165 | Admitted. -------------------------------------------------------------------------------- /src/FormTopC/NatInfty.v: -------------------------------------------------------------------------------- 1 | Require Import 2 | Coq.Arith.Compare_dec 3 | 4 | Prob.StdLib 5 | Algebra.SetsC 6 | Algebra.OrderC 7 | Algebra.PreOrder 8 | FormTopC.FormTop 9 | FormTopC.Cont 10 | FormTopC.Discrete. 11 | 12 | Set Universe Polymorphism. 13 | (* The Alexandroff compactification of the natural numbers. *) 14 | 15 | Inductive O : Set := 16 | | MoreThan : nat -> O 17 | | Exactly : nat -> O. 18 | 19 | Inductive le : O -> O -> Set := 20 | | MoreThan_le : forall n m, m <= n -> le (MoreThan n) (MoreThan m) 21 | | Eventually_le : forall n m, n < m -> le (Exactly m) (MoreThan n) 22 | | Exactly_le : forall n m, m = n -> le (Exactly m) (Exactly n). 23 | 24 | Local Instance le_PreO : PreO.t le. 25 | Proof. 26 | constructor; intros. 27 | - destruct x; constructor. reflexivity. reflexivity. 28 | - destruct H. inv H0. constructor. 29 | eapply PeanoNat.Nat.le_trans; eassumption. 30 | inv H0. constructor. 31 | eapply PeanoNat.Nat.le_lt_trans; eassumption. 32 | subst. assumption. 33 | Qed. 34 | 35 | Inductive Next {n : nat} : O -> Set := 36 | | Next_Later : Next (MoreThan (S n)) 37 | | Next_Now : Next (Exactly (S n)). 38 | 39 | Arguments Next : clear implicits. 40 | 41 | (** This axiom set is not localized. However, 42 | doing the localization procedure will 43 | generate the right thing! *) 44 | Inductive Ix : O -> Set := 45 | | IxNext : forall n, Ix (MoreThan n). 46 | 47 | Definition C (a : O) (ix : Ix a) : Subset O := match ix with 48 | | IxNext n => Next n 49 | end. 50 | 51 | Definition NatInfPO : PreOrder := 52 | {| PO_car := O 53 | ; PreOrder.le := le 54 | |}. 55 | 56 | Definition NatInf : PreISpace.t := 57 | {| PreISpace.S := NatInfPO 58 | ; PreISpace.C := C 59 | |}. 60 | 61 | Definition exactly (n : nat) : Subset O := le (Exactly n). 62 | 63 | Arguments exactly : clear implicits. 64 | 65 | Inductive infty : Subset O := 66 | | in_infty : forall n, infty (MoreThan n). 67 | 68 | Definition is_pt := IGCont.pt NatInf. 69 | 70 | Lemma pt_infty : is_pt infty. 71 | Proof. 72 | constructor; intros. 73 | - exists (MoreThan 0). constructor. 74 | - destruct H, H0. exists (MoreThan (max n n0)). 75 | econstructor. split; le_down; constructor. 76 | apply Max.le_max_l. apply Max.le_max_r. 77 | constructor. 78 | - destruct H. inv H0. constructor. 79 | - destruct j as [m]. simpl. 80 | simpl in H. destruct H0 as [n]. 81 | inv H. 82 | destruct (Compare_dec.le_lt_eq_dec _ _ H2). 83 | + exists (MoreThan n). split. constructor. 84 | split. le_down. simpl. econstructor. reflexivity. 85 | exists (MoreThan (S m)). constructor. 86 | constructor. assumption. 87 | + subst. exists (MoreThan (S n)). split. constructor. 88 | split. le_down. simpl. constructor. apply Le.le_n_Sn. 89 | exists (MoreThan (S n)). constructor. 90 | simpl. constructor. reflexivity. 91 | Qed. 92 | 93 | Lemma pt_exactly n : is_pt (exactly n). 94 | Proof. 95 | constructor; unfold exactly; intros. 96 | - exists (Exactly n). unfold In. reflexivity. 97 | - exists (Exactly n). split. split; le_down; assumption. 98 | reflexivity. 99 | - etransitivity; eassumption. 100 | - destruct j as [m]. simpl. 101 | inv H0. 102 | + inv H. 103 | exists (Exactly n). constructor. reflexivity. 104 | destruct (Compare_dec.lt_eq_lt_dec (S m) n) as [[LT | EQ] | GT]. 105 | * split. le_down. simpl. constructor. assumption. 106 | exists (MoreThan (S m)). constructor. simpl. constructor. 107 | assumption. 108 | * subst. split. le_down. simpl. constructor. 109 | assumption. exists (Exactly (S m)). constructor. 110 | reflexivity. 111 | * exfalso. eapply Lt.le_not_lt. 2: eassumption. 112 | etransitivity. 2: eapply H2. apply Le.le_n_S. assumption. 113 | + inv H. exists (Exactly n0). 114 | split. constructor. reflexivity. 115 | split. le_down. reflexivity. 116 | exists (MoreThan (S m)). constructor. 117 | simpl. constructor. admit. 118 | Admitted. 119 | 120 | Lemma Pos : FormTop.gtPos NatInf. 121 | Proof. 122 | apply FormTop.gall_Pos. 123 | intros b i a. induction a. 124 | - (** MoreThan n - take the point infty as an example. *) 125 | intros H. 126 | pose proof (IGCont.pt_cov pt_infty (MoreThan n) b i H). 127 | assert (H1 : infty (MoreThan n)) by constructor. 128 | specialize (H0 H1). 129 | destruct H0. destruct i0. eexists; eassumption. 130 | - (** Exactly n - take the point (exactly n) as an example. *) 131 | intros H. 132 | pose proof (IGCont.pt_cov (pt_exactly n) (Exactly n) b i H). 133 | assert (H1 : exactly n (Exactly n)). 134 | unfold exactly. reflexivity. 135 | specialize (H0 H1). destruct H0. destruct i0. 136 | eexists; eassumption. 137 | Qed. 138 | 139 | (** The (open) embedding of the natural numbers into 140 | its Alexandroff compactification. *) 141 | 142 | Require Import FormTopC.FormalSpace. 143 | 144 | Definition inj : Cont.map (discrete nat) (toPSL NatInf) := fun o n => 145 | exactly n o. 146 | 147 | (* 148 | Lemma inj_cont : Cont.t Logic.eq le (Discrete.Cov nat) (FormTop.GCov le C) inj. 149 | Proof. 150 | apply DiscreteFunc.pointwise_cont. 151 | intros. unfold Cov. apply IGCont.pt_cont. apply pt_exactly. 152 | Qed. 153 | *) 154 | 155 | (** A little function that checks if a property holds for 156 | some natural number. *) 157 | Section Checker. 158 | 159 | Variable (f : nat -> bool). 160 | 161 | Definition checkf : Subset O := fun o => match o with 162 | | MoreThan n => forall k, k <= n -> f k = false 163 | | Exactly n => (forall k, k < n -> f k = false) /\ f n = true 164 | end. 165 | 166 | 167 | End Checker. 168 | 169 | 170 | CoInductive Partial {A} : Type := 171 | | Later : Partial -> Partial 172 | | Now : A -> Partial. 173 | 174 | Arguments Partial : clear implicits. 175 | 176 | 177 | Definition pt_to_Partial (x : Subset O) (ptx : is_pt x) : Partial unit. 178 | Proof. 179 | destruct (IGCont.pt_here ptx). 180 | induction a. 181 | Focus 2. apply Now. apply tt. 182 | generalize dependent n. cofix. 183 | intros. 184 | pose proof (IGCont.pt_cov ptx 185 | (MoreThan n) (MoreThan n) (IxNext n) 186 | (PreO.le_refl (MoreThan n)) i) as X. 187 | simpl in X. destruct X. destruct i0. destruct d. 188 | le_downH d. destruct d0. destruct i0. 189 | - induction a. 190 | + apply Later. apply (pt_to_Partial _ x0). 191 | + apply (Now tt). 192 | - apply Now. apply tt. 193 | Defined. -------------------------------------------------------------------------------- /src/FormTopC/Pattern.v: -------------------------------------------------------------------------------- 1 | Require Import 2 | FormTopC.Cont 3 | FormTopC.FormTop 4 | FormTopC.FormalSpace 5 | Algebra.SetsC 6 | Algebra.OrderC 7 | Algebra.PreOrder 8 | FormTopC.Subspace. 9 | 10 | Set Universe Polymorphism. 11 | Local Open Scope Subset. 12 | Local Open Scope FT. 13 | 14 | Section Patterns. 15 | 16 | Context {S T : FormalSpace.t}. 17 | 18 | (** Construct a continuous map by pasting together local 19 | continuous maps in a sheaf-like manner. 20 | 21 | This will be useful, for instance, for definining 22 | multiplication of real numbers, where I have a family 23 | of functions which do bounded multiplication which is 24 | valid only on a subset of the whole space. 25 | 26 | For now, I am assuming that the map is given for every open 27 | set. That's valid at least for multiplication, and simplifies things. *) 28 | Section SheafMap. 29 | 30 | Variable (f : S -> Cont.map S T). 31 | 32 | Inductive f_pasted {t : T} {s : S} : Type := 33 | Mkf_pasted : forall s', s <= s' -> f s' t s -> f_pasted. 34 | 35 | Arguments f_pasted : clear implicits. 36 | 37 | Hypothesis f_cont : forall a, Cont.t S T (f a). 38 | (* Not sure if the following is too strong. *) 39 | Hypothesis f_intersect : forall (a : S) (b c : T), 40 | f_pasted b a -> f_pasted c a -> 41 | { t : T & (f_pasted t a * (eq b ↓ eq c) t)%type }. 42 | 43 | Existing Instances FormalSpace.FT FormalSpace.PreO 44 | FormalSpace.Cov_Proper FormalSpace.Cov_Proper2 45 | FormalSpace.Cov_Proper3. 46 | 47 | Lemma Cov_intersect : forall a U, a <|[S] U -> 48 | a <|[S] ⇓ (eq a) ∩ ⇓ U. 49 | Proof. 50 | intros. 51 | apply FormTop.le_right. apply FormTop.refl. reflexivity. assumption. 52 | Qed. 53 | 54 | Theorem cont_f_pasted : Cont.t _ _ f_pasted. 55 | Proof. 56 | constructor; intros. 57 | - pose proof (Cont.here (f_cont a)). 58 | specialize (X a). apply Cov_intersect in X. 59 | eapply (FormTop.trans X); clear X; intros. 60 | destruct X. destruct d, d0. unfold In in i. subst. 61 | destruct i0. destruct i. 62 | pose proof (Cont.le_left (f_cont a1)). 63 | eapply FormTop.le_left. Focus 2. 64 | apply FormTop.refl. econstructor. 65 | Focus 2. 66 | econstructor. 2: eapply X. eassumption. eassumption. eassumption. 67 | constructor. reflexivity. 68 | - induction X0. pose proof (Cont.le_left (f_cont s')). 69 | apply (X0 _ _ _ X) in f0. 70 | econstructor. 2: eassumption. etransitivity; eassumption. 71 | - pose proof (f_intersect a b c X X0). 72 | destruct X1. destruct p. 73 | apply FormTop.refl. exists x; eassumption. 74 | - destruct X. 75 | pose proof (Cont.cov (f_cont s') V f0 X0). 76 | apply Cov_intersect in X. 77 | eapply (FormTop.trans X); clear X; intros. destruct X. 78 | destruct d, d0. unfold In in i. subst. destruct i0. 79 | apply FormTop.refl. exists a. assumption. 80 | econstructor. 2: eapply (Cont.le_left (f_cont s')). 81 | transitivity a1; eassumption. 2: eassumption. eassumption. 82 | Qed. 83 | 84 | End SheafMap. 85 | 86 | Section Pattern. 87 | 88 | Variable Ix : Type. 89 | Variable U : Ix -> Open S. 90 | Variable f : forall i : Ix, Cont.map (OpenSub (U i)) T. 91 | Variable f_cont : forall i : Ix, Cont.t _ _ (f i). 92 | 93 | Inductive union_f : Cont.map S T := 94 | mk_union_f : forall (i : Ix) s t, f i t s -> union_f t s. 95 | 96 | Variable covering : forall a : S, a <|[S] union (fun _ => True) union_f. 97 | 98 | (* This is all not exactly right. Need to make sure I saturate 99 | before taking intersections, saturate before taking 100 | inclusions of open maps... *) 101 | Variable glue_maps : forall i j : Ix, 102 | Cont.map (OpenSub (U i ∩ U j)) T. 103 | 104 | Hypothesis gluing : forall i j : Ix, 105 | PreO.max (le := RelIncl) (f i) (f j) (glue_maps i j). 106 | 107 | 108 | End Pattern. 109 | 110 | End Patterns. -------------------------------------------------------------------------------- /src/FormTopC/Product.v: -------------------------------------------------------------------------------- 1 | Require Import 2 | Prob.StdLib 3 | Coq.Lists.List 4 | Types.List 5 | Types.UIP 6 | FormTopC.FormTop 7 | Algebra.OrderC 8 | Algebra.PreOrder 9 | Algebra.SetsC 10 | FormTopC.Cont 11 | FormTopC.FormalSpace 12 | Algebra.FreeLattice. 13 | 14 | Set Universe Polymorphism. 15 | Set Asymmetric Patterns. 16 | 17 | Existing Instances 18 | FormTop.GCov_formtop 19 | FormalSpace.IGT_PreO 20 | FormalSpace.IGTFT. 21 | 22 | Local Open Scope FT. 23 | Local Open Scope FreeML. 24 | 25 | 26 | 27 | (** Product spaces for inductively generated formal topologies. 28 | See Section 4.3 of [1]. *) 29 | Module Product. 30 | 31 | Generalizable All Variables. 32 | Section Product. 33 | 34 | Universes A P I API API' Ix. 35 | Context {Ix : Type@{Ix}}. 36 | Context {Ix_UIP : EqdepFacts.UIP_ Ix}. 37 | Variable X : Ix -> IGt@{A P I API}. 38 | 39 | (** See 40 | https://www.cs.bham.ac.uk/~sjv/InfiniteTych.pdf 41 | *) 42 | Definition ProdPO@{} : PreOrder@{A P} := 43 | ML.FreeML (SomeOpen X). 44 | 45 | Inductive Ix'@{} : ProdPO -> Type@{I} := 46 | | Slice : forall {x : SomeOpen X}, PreISpace.Ix (X (SOIx x)) (SOOpen x) -> 47 | forall xs, Ix' (ML.inj x ∧ xs) 48 | | DimUnion : forall xs, Ix -> Ix' xs 49 | | ProdStable : forall {ix : Ix} (a a' : X ix) xs, 50 | Ix' (MkSomeOpen ix a :: MkSomeOpen ix a' :: xs). 51 | 52 | Arguments Ix' : clear implicits. 53 | 54 | Inductive ExtSubset@{} {s : ProdPO} {ix : Ix} {C : Subset@{A P} (X ix)} 55 | : Subset@{A P} ProdPO := 56 | | MkExtSubset : forall u, C u -> ExtSubset (ML.inj (MkSomeOpen ix u) ∧ s). 57 | 58 | Arguments ExtSubset s {ix} C. 59 | 60 | Definition C'@{} : forall (p : ProdPO), Ix' p -> Subset@{A P} ProdPO := 61 | fun p ix' => match ix' with 62 | | Slice x ax xs => ExtSubset xs (PreISpace.C _ _ ax) 63 | | DimUnion xs ix => @ExtSubset xs ix (fun _ => True) 64 | | ProdStable ix a a' xs => @ExtSubset xs ix (eq a ↓ eq a') 65 | end. 66 | 67 | Definition Prod@{} : PreISpace.t@{A P I} := 68 | {| PreISpace.S := ProdPO 69 | ; PreISpace.Ix := Ix' 70 | ; PreISpace.C := C' 71 | |}. 72 | 73 | Instance Sum_PO : PreO.t (le (SomeOpen X)). 74 | Proof. 75 | unshelve eapply PreOrder.Sum_PO. eassumption. 76 | Qed. 77 | 78 | Local Instance loc : 79 | (forall ix, FormTop.localized (X ix)) 80 | -> FormTop.localized Prod. 81 | Proof. 82 | intros locX. 83 | unfold FormTop.localized. 84 | intros a c H1 i. destruct i. 85 | specialize (locX (SOIx x)). 86 | simpl in H1. 87 | apply Each_member in H1. 88 | inv H1. 89 | induction X0. induction S_holds. 90 | simpl in *. 91 | specialize (locX aix bix l i). 92 | destruct locX. 93 | Abort. 94 | 95 | 96 | Definition Prodt : IGt := 97 | {| IGS := Prod 98 | ; IGPO := ML.PO 99 | |}. 100 | 101 | Definition proj (ix : Ix) : Cont.map Prodt (X ix) := 102 | fun (out : X ix) => ⇓ eq (ML.inj (MkSomeOpen ix out)). 103 | 104 | Lemma slice_cov_top (ix : Ix) (a : Prodt) 105 | : a <|[Prodt] union (fun _ : X ix => True) 106 | (fun out : X ix => 107 | eq (ML.inj (MkSomeOpen ix out))). 108 | Proof. 109 | eapply FormalSpace.trans. 110 | apply (@ig_ax_cov Prodt _ (DimUnion a ix)). 111 | simpl. intros s Cs. 112 | inv Cs. clear H. 113 | eapply FormTop.glle_left with (ML.inj (MkSomeOpen ix u)). 114 | apply ML.bmeet_le_l. 115 | apply FormTop.glrefl. 116 | eexists. unfold In. auto. 117 | reflexivity. 118 | Qed. 119 | 120 | (* Hmm, this looks like I need to add rule 2 121 | from page xv of 122 | https://www.cs.bham.ac.uk/~sjv/InfiniteTych.pdf. 123 | But since I don't require my axiom sets to be localized, 124 | perhaps that rule is actually just admissible? 125 | 126 | NO, in fact it should be enough to use rule 3, which should 127 | generalize to any covering a <| U, taking 128 | U = eq b ↓ eq c, so 129 | a <| eq b ↓ eq c 130 | *) 131 | Lemma prod_stable (ix : Ix) (a a' : X ix) (xs : Prod) : 132 | (MkSomeOpen ix a :: MkSomeOpen ix a' :: xs) 133 | <|[Prodt] ExtSubset xs (eq a ↓ eq a'). 134 | Proof. 135 | apply (@ig_ax_cov Prodt _ (@ProdStable ix a a' xs)). 136 | Qed. 137 | 138 | Lemma ext_le_cov (ix : Ix) {aix : X ix} 139 | {U : Open (X ix)} (Hc : aix <|[X ix] U) (xs : Prodt) 140 | : (ML.inj (MkSomeOpen ix aix) ∧ xs) <|[Prodt] ExtSubset xs U. 141 | Proof. 142 | induction Hc. 143 | - apply FormTop.refl. constructor. assumption. 144 | - eapply FormTop.le_left. 145 | eapply (ML.le_app_r (ML.inj (MkSomeOpen ix a)) (ML.inj (MkSomeOpen ix b))). 146 | apply ML.le_singleton. 147 | econstructor. eassumption. simpl app. 148 | assumption. 149 | - pose proof (FormTop.gle_infinity (A := Prodt) 150 | (ML.inj (MkSomeOpen ix a) ∧ xs) (ExtSubset xs U) _ (@Slice (MkSomeOpen ix b) i xs)) 151 | as H. 152 | eapply H; clear H. apply ML.le_cons. 153 | econstructor. eassumption. reflexivity. 154 | intros. destruct X1. 155 | le_downH d. 156 | destruct d0. induction i0. simpl in c. 157 | apply FormTop.glle_left with 158 | (ML.inj (MkSomeOpen ix a) ∧ ML.inj (MkSomeOpen ix u0) ∧ xs). 159 | apply ML.le_cons_r. 160 | rewrite d. apply ML.bmeet_le_l. apply l0. 161 | eapply (@FormTop.trans Prodt). typeclasses eauto. 162 | apply prod_stable. simpl. 163 | intros. induction X1. apply X0. 164 | destruct c0. le_downH d1. 165 | split. assumption. exists u0; assumption. 166 | Qed. 167 | 168 | Lemma t_proj (ix : Ix) : Cont.t Prodt (X ix) (proj ix). 169 | Proof. 170 | constructor; intros; unfold proj in *. 171 | - eapply FormTop.monotone. 2: apply slice_cov_top. 172 | apply union_monotone. 173 | intros out. apply downset_included. 174 | - le_down. le_downH X1. etransitivity; eassumption. 175 | - le_downH X0. le_downH X1. 176 | pose proof (prod_stable ix b c a) as X2. 177 | assert (a <=[Prod] (MkSomeOpen ix b :: MkSomeOpen ix c :: a)) as X3. 178 | apply ML.le_cons_r. eassumption. 179 | apply ML.le_cons_r. eassumption. reflexivity. 180 | apply (FormTop.le_left (A := Prodt) _ _ _ X3) in X2. 181 | clear X0 X1 X3. 182 | eapply FormTop.monotone. 2: eassumption. 183 | clear X2. 184 | intros x Px. induction Px. 185 | destruct c0. eexists. split; eassumption. 186 | le_down. apply ML.bmeet_le_l. 187 | - le_downH X0. 188 | pose proof (ext_le_cov ix X1 a) as X2. 189 | eapply FormTop.le_left. etransitivity. eapply ML.app_le. eapply X0. 190 | eapply ML.bmeet_comm. simpl app. 191 | eapply FormTop.monotone. 2: eassumption. 192 | clear X2. intros x []. eexists. eassumption. 193 | le_down. apply ML.bmeet_le_l. 194 | Qed. 195 | 196 | Variable A : FormalSpace.t. 197 | Variable f : forall ix, Cont.map A (X ix). 198 | Variable f_cont : forall ix, IGCont.t A (X ix) (f ix). 199 | 200 | Definition univ : Cont.map A Prodt := 201 | fun (out : Prodt) (a : A) => 202 | Each (fun x : SomeOpen X => let (ix, uix) := x in 203 | (f ix) uix a) out. 204 | 205 | Existing Instances FormalSpace.isFT. 206 | 207 | Lemma univ_le_left (a : A) (b : Prodt) (c : A) 208 | : a <=[A] c -> univ b c -> univ b a. 209 | Proof. 210 | unfold univ. intros H H'. unfold Each. intros x mem. 211 | destruct x as (ix & uix). 212 | specialize (H' _ mem). simpl in H'. 213 | eapply (IGCont.le_left (f_cont ix)); eassumption. 214 | Qed. 215 | 216 | Lemma univ_app {a b c} 217 | (Hb : univ b a) (Hc : univ c a) 218 | : univ (b ∧ c) a. 219 | Proof. 220 | apply Each_app; split; assumption. 221 | Qed. 222 | 223 | Lemma univ_le_right {a b c} 224 | : a <=[Prodt] b -> univ a c -> univ b c. 225 | Proof. 226 | intros. unshelve eapply (ML.Each_monotone _ _ _ _ X0 X1). 227 | simpl. intros. destruct X2. 228 | eapply (IGCont.le_right (f_cont ix)); eassumption. 229 | Qed. 230 | 231 | Lemma univ_cov (a : A) 232 | : forall l : Prodt, univ l a -> a <|[A] union (⇓ eq l) univ. 233 | Proof. 234 | intros xs H. eapply FormTop.refl. 235 | eexists. 2: eassumption. 236 | unfold In. le_down. reflexivity. 237 | Qed. 238 | 239 | Existing Instances FormalSpace.PO. 240 | 241 | Import ListNotations. 242 | 243 | Theorem univ_cont : IGCont.t A Prodt univ. 244 | Proof. 245 | econstructor; intros. 246 | - eapply FormTop.refl. exists []. unfold In. auto. 247 | apply Each_nil. 248 | - eapply FormTop.monotone. 249 | eapply union_idx_monotone. eapply Same_set_Included. 250 | eapply ML.down_app. 251 | pose proof (univ_app X0 X1) as H. clear X0 X1. 252 | generalize dependent (b ∧ c). clear b c. 253 | apply univ_cov. 254 | - eapply univ_le_left; eassumption. 255 | - eapply (ML.Each_monotone). 2: eassumption. 2: eassumption. 256 | clear b c X0 X1. 257 | intros x y l H. induction l as [ix aix bix]. 258 | eapply (IGCont.le_right (f_cont ix)); eassumption. 259 | - induction j. 260 | + pose proof (X0 _ here) as tx. simpl in tx. 261 | induction tx. induction S_holds. 262 | simpl in i. 263 | pose proof (IGCont.ax_right (f_cont ix) a aix bix i l). 264 | pose proof (X1 _ S_member) as X1'. simpl in X1'. 265 | specialize (X2 X1'). 266 | eapply FormTop.le_right_eq in X2. 267 | eapply FormTop.monotone. 2: eassumption. 268 | apply Included_impl. intros u Pu. 269 | destruct Pu. le_downH d. destruct d0. 270 | destruct i0. destruct i0. le_downH d0. 271 | destruct d1. 272 | eexists. split. le_down. 273 | Focus 2. econstructor. econstructor. 274 | eapply i0. simpl SOIx. 275 | instantiate (1 := ML.inj (MkSomeOpen ix a1) ∧ t). 276 | apply ML.le_cons. econstructor. eassumption. 277 | rewrite X0. apply ML.bmeet_le_r. 278 | apply ML.bmeet_le_r. 279 | apply univ_app. apply Each_singleton. 280 | eapply (IGCont.le_left (f_cont ix)). eassumption. eassumption. 281 | eapply univ_le_left. 2:eassumption. assumption. 282 | + pose proof (IGCont.here (f_cont i) a) as H'. 283 | apply FormTop.le_right_eq in H'. 284 | eapply FormTop.monotone. 2: apply H'. 285 | intros u Pu. destruct Pu. le_downH d. destruct d0. 286 | destruct i0. destruct i0. 287 | eexists. split. le_down. 288 | Focus 2. eexists. econstructor. 289 | auto. instantiate (1 := a1). 290 | instantiate (1 := ML.inj (MkSomeOpen i a1) ∧ t). 291 | apply ML.le_cons. reflexivity. eassumption. 292 | apply ML.bmeet_le_r. 293 | apply univ_app. 294 | * apply List.Each_singleton. 295 | eapply (IGCont.le_left (f_cont i)). 2: eassumption. 296 | assumption. 297 | * eapply univ_le_left. 2: eassumption. assumption. 298 | + simpl. 299 | pose proof (IGCont.local (f_cont ix) a a0 a'). 300 | pose proof (univ_le_right X0 X1) as X3. 301 | assert (univ xs a) as X4. 302 | eapply univ_le_right. 2: eapply X3. 303 | apply ML.FSubset_le. 304 | apply (FSubset_app_r [MkSomeOpen ix a0; MkSomeOpen ix a']). 305 | specialize (X2 (X3 _ here) (X3 _ (there here))). 306 | pose proof (univ_cov _ _ X1). 307 | FormTop.ejoin. 308 | eapply FormTop.trans. eassumption. clear X6. 309 | intros. apply FormTop.refl. 310 | destruct X2. destruct d, d0. 311 | destruct i, i0. unfold In in i0. le_downH i0. 312 | exists (ML.inj (MkSomeOpen ix a4) ∧ a5). split. le_down. 313 | rewrite ML.bmeet_le_r. assumption. 314 | eexists. econstructor. eassumption. 315 | apply ML.le_cons. reflexivity. rewrite i0. 316 | rewrite X0. 317 | apply ML.FSubset_le. 318 | apply (FSubset_app_r [MkSomeOpen ix a0; MkSomeOpen ix a']). 319 | apply univ_app. 320 | eapply univ_le_left. apply l. 321 | apply Each_singleton. simpl. assumption. 322 | eapply univ_le_left. apply l0. 323 | assumption. 324 | Qed. 325 | 326 | 327 | (** Prove the space has a positivity predicate. *) 328 | 329 | Context {X_Pos : forall ix : Ix, FormTop.gtPos (X ix)}. 330 | 331 | Definition PosProd : Subset Prod := 332 | Each (fun x => FormTop.gPos (SOOpen x)). 333 | 334 | Local Open Scope Subset. 335 | 336 | (* 337 | Lemma PosProd_factors (a : Prod) : 338 | eq a ∩ PosProd === fun p => forall ix : Ix, 339 | (eq (a ix) ∩ FormTop.gPos) (p ix). 340 | Proof. 341 | apply Same_set_iff. 342 | intros. split; intros H. 343 | - destruct H. subst. intros. split. reflexivity. 344 | apply p. 345 | - split. extensionality ix. destruct (H ix). assumption. 346 | intros ix. apply H. 347 | Qed. 348 | *) 349 | 350 | Existing Instance GCovL_formtop. 351 | 352 | Lemma Pos : FormTop.gtPos Prod. 353 | Proof. 354 | unshelve econstructor. 355 | - exact PosProd. 356 | - intros a b l. apply (ML.Each_monotone (X := SomeOpen X)). 357 | 2: assumption. 358 | clear a b l. 359 | intros x y l H. induction l. 360 | eapply FormTop.gmono_le; eassumption. 361 | - intros b i a X0 X1. destruct i. 362 | Admitted. 363 | (* 364 | pose proof (FormTop.gmono_ax (gtPos := IGpos (X ix)) (b ix) 365 | i (a ix) (X0 ix) (X1 ix)). 366 | - intros. 367 | apply (FormTop.trans (A := Prod) (U := eq a ∩ PosProd)). 368 | + eapply gmonotoneL. eapply Same_set_Included. 369 | apply PosProd_factors. 370 | eapply factors; apply FormTop.gpositive; 371 | intros; apply FormTop.grefl; split; trivial. 372 | + intros. destruct X1. subst. apply X0. assumption. 373 | Qed. 374 | *) 375 | 376 | End Product. 377 | End Product. -------------------------------------------------------------------------------- /src/FormTopC/Scott.v: -------------------------------------------------------------------------------- 1 | Require Import 2 | Algebra.FrameC 3 | FormTopC.Product 4 | FormTopC.Discrete 5 | FormTopC.Bundled. 6 | 7 | Module Scott. 8 | 9 | Section Scott. 10 | 11 | Variable A B : IGT. 12 | 13 | Definition le_Open (U V : Subset (S B)) := 14 | V ⊆ FormTop.Sat (Cov B) U. 15 | 16 | Lemma Sat_Cov : forall U V, 17 | U ⊆ FormTop.Sat (Cov B) V 18 | -> FormTop.Sat (Cov B) U ⊆ FormTop.Sat (Cov B) V. 19 | Proof. 20 | intros. unfold FormTop.Sat, Included, pointwise_rel, arrow in *. 21 | intros. FormTop.trans X0. apply X; assumption. 22 | Qed. 23 | 24 | Local Instance PreOrder_le_Open : PreO.t le_Open. 25 | Proof. 26 | unfold le_Open; constructor; 27 | unfold Reflexive, Transitive; intros. 28 | - apply (FormTop.Sat_mono _ _ _). 29 | - rewrite X0. apply Sat_Cov; assumption. 30 | Qed. 31 | 32 | Definition eq_Open := PO.eq_PreO le_Open. 33 | 34 | (** Define abstraction to Sierpinski space 35 | S * T ~~> Σ --> S ~~> Open T 36 | *) 37 | 38 | Existing Instances Sierpinski.ops Sierpinski.SML. 39 | 40 | Let prod_le := prod_op leS leT. 41 | Let prodC := Product.C _ _ IxS IxT CS CT. 42 | Let prodCov := FormTop.GCov prod_le prodC. 43 | Let sierpCov := FormTop.GCov MeetLat.le Sierpinski.C. 44 | 45 | Variable F : Contmap (S * T) (discrete bool). 46 | Hypothesis contF : Cont.t 47 | prod_le MeetLat.le prodCov sierpCov F. 48 | 49 | (** "false" is the smallest open set in the Sierpinski space, 50 | which confusingly is the open set surrounding the 51 | "top" or "true" point. *) 52 | 53 | 54 | Definition absF (subset : Subset T) (s : S) : Type := 55 | le_Open (fun t => F false (s, t)) subset. 56 | 57 | Let OpenCov := FormTop.GCov le_Open (InfoBase.C 58 | (leS := le_Open) 59 | (eqS := eq_Open)). 60 | 61 | Local Instance FTS : FormTop.t leS CovS. 62 | Proof. 63 | apply FormTop.GCov_formtop. 64 | Qed. 65 | 66 | Lemma le_Open_mono U V : 67 | V ⊆ U -> le_Open U V. 68 | Proof. 69 | intros H. unfold le_Open. 70 | rewrite H. apply (FormTop.Sat_mono leT CovT). 71 | Qed. 72 | 73 | Local Instance PO_le_eq : PO.t le_Open eq_Open 74 | := PO.fromPreO _. 75 | Existing Instance PO.fromPreO. 76 | 77 | (** This seems really suspicious. It's probably wrong. *) 78 | Theorem absF_cont : Cont.t leS le_Open CovS OpenCov absF. 79 | Proof. 80 | constructor; intros. 81 | - apply FormTop.grefl. constructor 1 with (fun _ => False). 82 | constructor. unfold absF. unfold le_Open. 83 | unfold Included, pointwise_rel, arrow; intros. 84 | contradiction. 85 | - unfold absF in *. rewrite <- X0. 86 | apply le_Open_mono. 87 | unfold Included, pointwise_rel, arrow; intros. 88 | eapply (Cont.le_left contF (a, a0) false (c, a0)). 89 | unfold prod_le, prod_op. simpl. split. eassumption. 90 | reflexivity. assumption. 91 | - unfold absF in *. 92 | apply FormTop.grefl. 93 | exists (b ∪ c). split; apply le_Open_mono. 94 | apply Union_Included_l. 95 | apply Union_Included_r. 96 | unfold Included, In in *. 97 | unfold le_Open in *. 98 | unfold Included, pointwise_rel, arrow; intros. 99 | destruct X1. apply X. assumption. apply X0. assumption. 100 | - induction X0; simpl in *. 101 | + apply FormTop.grefl. constructor 1 with a0; assumption. 102 | + apply IHX0. unfold absF. 103 | unfold absF in X. 104 | unfold le_Open in *. 105 | rewrite l. apply Sat_Cov. assumption. 106 | + destruct i; simpl in *. 107 | apply (X0 t). reflexivity. 108 | unfold absF, le_Open in *. 109 | rewrite l. apply Sat_Cov. assumption. 110 | Qed. 111 | 112 | End Scott. 113 | 114 | End Scott. 115 | 116 | (** Spaces of open sets (using Scott topology *) 117 | Definition Open (A : IGT) : IGT := 118 | let LE := @Scott.le_Open (S A) (le A) (Ix A) (C A) in 119 | let PreO : PreO.t (le A) := IGT_PreO A in 120 | let PO := 121 | @PO.PreO (Subset (S A)) LE _ (Scott.PO_le_eq (POT := PreO) 122 | (locT := localized A)) in 123 | {| S := Subset (S A) 124 | ; le := LE 125 | ; PO := PO 126 | ; Ix := InfoBase.Ix 127 | ; C := InfoBase.C (leS := LE) (eqS := PO.eq_PreO LE) 128 | ; localized := InfoBase.loc (PO := PO.fromPreO LE) 129 | ; pos := InfoBase.Pos (PO := PO.fromPreO LE) 130 | |}. 131 | 132 | Definition open_abstract_mp {Γ A : IGT} 133 | (f : Cont.map (S (Γ * A)) (S Σ)) 134 | : Cont.map (S Γ) (S (Open A)) 135 | := Scott.absF (leT := le A) (IxT := Ix A) (CT := C A) f. 136 | 137 | Existing Instances Bundled.PO Bundled.local. 138 | 139 | Definition open_abstract_mp_ok {Γ A : IGT} 140 | (f : Cont.map (S (Γ * A)) (S Σ)) 141 | : Cont.t (le (Γ * A)) (le Σ) (Cov (Γ * A)) (Cov Σ) f 142 | -> Cont.t (le Γ) (le (Open A)) (Cov Γ) (Cov (Open A)) 143 | (open_abstract_mp f). 144 | Proof. 145 | intros H. 146 | apply Scott.absF_cont. apply H. 147 | Qed. 148 | 149 | Definition open_abstract {Γ A : IGT} (f : Γ * A ~~> Σ) : Γ ~~> Open A 150 | := 151 | {| mp := open_abstract_mp (mp f) 152 | ; mp_ok := open_abstract_mp_ok (mp f) (mp_ok f) 153 | |}. -------------------------------------------------------------------------------- /src/FormTopC/Spaces/One.v: -------------------------------------------------------------------------------- 1 | Require Import 2 | CMorphisms 3 | CRelationClasses 4 | Algebra.OrderC 5 | Algebra.PreOrder 6 | Algebra.FrameC 7 | Algebra.SetsC 8 | Prob.StdLib 9 | FormTopC.FormTop 10 | FormTopC.Locale 11 | FormTopC.FormalSpace. 12 | Set Asymmetric Patterns. 13 | Set Universe Polymorphism. 14 | 15 | Local Open Scope FT. 16 | 17 | Definition OnePO : PreOrder := 18 | {| PO_car := unit 19 | ; le := fun _ _ => unit 20 | |}. 21 | 22 | Lemma OnePO_PO : PreO.t (le OnePO). 23 | Proof. 24 | firstorder. 25 | Qed. 26 | 27 | Definition OneI := fun _ : OnePO => Empty_set. 28 | 29 | Definition OneC (s : OnePO) (ix : OneI s) : Subset OnePO := 30 | Empty_set_rect _ ix. 31 | 32 | Definition OnePS : PreISpace.t := 33 | {| PreISpace.S := OnePO 34 | ; PreISpace.Ix := OneI 35 | ; PreISpace.C := OneC 36 | |}. 37 | 38 | Definition OnePos (_ : unit) : Type := unit. 39 | 40 | Instance OnePos_Pos : FormTop.gtPos OnePS. 41 | Proof. 42 | apply gall_Pos. intros. 43 | destruct i. 44 | Qed. 45 | 46 | Definition One : IGt := 47 | {| IGS := OnePS 48 | ; IGPO := OnePO_PO 49 | |}. 50 | 51 | Lemma split_One : 52 | forall a U, a <|[One] U -> U tt. 53 | Proof. 54 | intros a U H. induction H. 55 | - destruct a. assumption. 56 | - assumption. 57 | - destruct i. 58 | Qed. 59 | 60 | 61 | Local Open Scope Subset. 62 | 63 | Lemma One_Sat_le : 64 | forall U V, Sat One U ⊆ Sat One V -> U ⊆ V. 65 | Proof. 66 | intros U V H. apply Included_impl; intros. 67 | destruct x. eapply split_One. apply H. 68 | eapply FormTop.refl. eassumption. 69 | Qed. 70 | 71 | Lemma One_Sat_eq : 72 | forall U V, Sat One U === Sat One V -> U === V. 73 | Proof. 74 | intros U V H. apply Same_set_Included in H. 75 | destruct H. 76 | apply Included_Same_set; apply One_Sat_le; 77 | assumption. 78 | Qed. 79 | 80 | Definition One_cont : Frame.morph (FOps One) 81 | Frame.type_ops (fun U => U tt). 82 | Proof. 83 | unshelve eapply Frame.morph_easy. 84 | - eapply Frame. 85 | - eapply Frame.type. 86 | - unfold Proper, respectful. intros. 87 | apply One_Sat_eq in X. simpl. apply Same_set_iff. assumption. 88 | - simpl. unfold iffT; auto. 89 | - simpl. split; intros X. 90 | + destruct X. destruct d, d0. destruct l, l0, a, a0. 91 | auto. 92 | + destruct X. split; exists tt; (assumption || reflexivity). 93 | - simpl. intros. split; intros X. 94 | + destruct X. exists i. assumption. 95 | + destruct X. exists x. assumption. 96 | Qed. 97 | 98 | Definition One_type_cmap : 99 | Frame.cmap Frame.type_ops (FOps One) 100 | := 101 | {| Frame.cont := One_cont |}. 102 | 103 | Section PointMap. 104 | 105 | Context {A : FormalSpace.t}. 106 | 107 | 108 | End PointMap. -------------------------------------------------------------------------------- /src/FormTopC/Spaces/PosUR.v: -------------------------------------------------------------------------------- 1 | Require Import 2 | CoRN.model.structures.QposInf 3 | 4 | Prob.StdLib 5 | Numbers.QPosFacts 6 | FormTopC.FormTop 7 | FormTopC.Cont 8 | Algebra.SetsC 9 | Algebra.OrderC 10 | Algebra.PreOrder. 11 | 12 | Set Universe Polymorphism. 13 | 14 | Local Open Scope FT. 15 | 16 | (** I get a Coq error with using the typeclasses 17 | if I leave le as returning Prop *) 18 | Definition le (x y : QposInf) : Type := QposInf_le x y. 19 | 20 | Definition PosURPO : PreOrder := 21 | {| PO_car := QposInf 22 | ; PreOrder.le := le 23 | |}. 24 | 25 | Definition lt (x y : QposInf) : Type := 26 | ((x <=[PosURPO] y) * ((y <=[PosURPO] x) -> False))%type. 27 | 28 | Local Infix "<" := lt. 29 | 30 | Inductive Ix : QposInf -> Type := 31 | | IxFinite : forall x, Ix (Qpos2QposInf x). 32 | 33 | Definition C (q : QposInf) (ix : Ix q) : Subset QposInf 34 | := match ix with 35 | | IxFinite x => fun q' => lt q' x 36 | end. 37 | 38 | Instance PO : PreO.t le. 39 | Proof. 40 | constructor; unfold le; intros. 41 | - destruct x; simpl. apply Qle_refl. constructor. 42 | - destruct x, y, z; simpl in *; try (constructor || contradiction). 43 | eapply Qle_trans; eassumption. 44 | Qed. 45 | 46 | Existing Instance PreO.PreOrder_I. 47 | 48 | Lemma lt_le_trans (x y z : QposInf) : x < y -> y <=[PosURPO] z -> x < z. 49 | Proof. 50 | unfold lt in *. 51 | intros P Q. destruct P as (P1 & P2). split. 52 | etransitivity; eassumption. 53 | intros. apply P2. etransitivity; eassumption. 54 | Qed. 55 | 56 | Lemma lt_le_weak (x y : QposInf) : x < y -> x <=[PosURPO] y. 57 | Proof. 58 | intros H. destruct H. assumption. 59 | Qed. 60 | 61 | Definition PosUR : PreISpace.t := 62 | {| PreISpace.S := PosURPO 63 | ; PreISpace.C := C 64 | |}. 65 | 66 | Instance loc : FormTop.localized PosUR. 67 | Proof. 68 | unfold FormTop.localized. 69 | intros. destruct i; simpl in *. 70 | destruct a. 71 | - exists (IxFinite q). simpl. intros s Ps. 72 | split. le_down. eapply lt_le_weak. eassumption. 73 | exists s. unfold In. eapply lt_le_trans; eassumption. 74 | reflexivity. 75 | - contradiction. 76 | Qed. 77 | 78 | Definition fromQpos (x : Qpos) (y : QposInf) := x < y. 79 | 80 | Definition Pt := IGCont.pt PosUR. 81 | 82 | Local Open Scope Subset. 83 | 84 | Lemma Qpos_lt_equiv (x y : Qpos) : 85 | (x < y) <--> (x < y)%Q. 86 | Proof. 87 | split; intros. 88 | - destruct X. simpl in *. apply Qnot_le_lt. 89 | unfold not; intros contra. apply f. 90 | unfold le. simpl. apply contra. 91 | - split. apply Qlt_le_weak. assumption. 92 | intros. pose proof (Qlt_not_le _ _ H). 93 | apply H0. assumption. 94 | Qed. 95 | 96 | Definition Qpos_smaller' (x : Qpos) : { y : Qpos & y < x }. 97 | Proof. 98 | destruct (Qpos_smaller x) as [x' prf]. 99 | exists x'. apply Qpos_lt_equiv. apply prf. 100 | Qed. 101 | 102 | Definition QposInf_smaller (x : QposInf) : { y : Qpos & y < x }. 103 | Proof. 104 | destruct x. 105 | - apply Qpos_smaller'. 106 | - exists Qpos_one. unfold lt. simpl. auto. 107 | Qed. 108 | 109 | Lemma Qpos_plus_lt (x y : Qpos) : x < x + y. 110 | Proof. 111 | unfold lt. split. 112 | - unfold le. simpl. 113 | setoid_replace (x : Q) with (x + 0)%Q at 1. 114 | apply Qplus_le_compat. apply Qle_refl. apply Qlt_le_weak. 115 | apply Qpos_prf. ring. 116 | - unfold le. simpl. 117 | setoid_replace (x : Q) with (x + 0)%Q at 2 by ring. 118 | intros. apply Q.Qplus_le_r in H. 119 | eapply Qlt_not_le. 2:eassumption. apply Qpos_prf. 120 | Qed. 121 | 122 | Lemma QposInf_between (x y : QposInf) : x < y -> 123 | { z : QposInf & ((x < z) * (z < y))%type }. 124 | Proof. 125 | intros H. destruct x, y. 126 | Admitted. 127 | 128 | Definition Qpos_pt (x : Qpos) : Pt (fromQpos x). 129 | Proof. 130 | apply IGLCont.localized_pt_impl. 131 | constructor; intros. 132 | - simpl. exists (x + 1)%Qpos. unfold In, fromQpos. 133 | apply Qpos_plus_lt. 134 | - exists (QposInf_min b c). constructor. 135 | split; le_down. apply QposInf_min_lb_l. apply QposInf_min_lb_r. 136 | unfold fromQpos in *. 137 | unfold QposInf_min. destruct b. 138 | + destruct c. 139 | apply QposMinMax.Qpos_min_case; intros; assumption. 140 | assumption. 141 | + assumption. 142 | - unfold fromQpos in *. eapply lt_le_trans; eassumption. 143 | - destruct i. 144 | unfold fromQpos in *. unfold C. 145 | destruct (QposInf_between x x0 X). 146 | destruct p. exists x1. split; assumption. 147 | Qed. 148 | 149 | 150 | Definition URzero (x : QposInf) : Type := unit. 151 | 152 | Definition URzero_pt : Pt URzero. 153 | Proof. 154 | apply IGLCont.localized_pt_impl. 155 | constructor; intros. 156 | - simpl. exists 1%Qpos. constructor. 157 | - exists (QposInf_min b c). constructor. 158 | split; le_down. apply QposInf_min_lb_l. apply QposInf_min_lb_r. 159 | constructor. 160 | - constructor. 161 | - destruct i. 162 | destruct (QposInf_smaller x). 163 | simpl. exists x0. split. constructor. assumption. 164 | Qed. 165 | 166 | Inductive URinfty : QposInf -> Type := 167 | MkURinfty : URinfty QposInfinity. 168 | 169 | Definition URinfty_pt : Pt URinfty. 170 | Proof. 171 | apply IGLCont.localized_pt_impl. 172 | constructor; intros. 173 | - exists QposInfinity. constructor. 174 | - exists (QposInf_min b c). constructor. 175 | split; le_down. apply QposInf_min_lb_l. apply QposInf_min_lb_r. 176 | destruct X, X0. simpl. constructor. 177 | - destruct X. destruct b; simpl in *. contradiction. 178 | econstructor. 179 | - destruct i. exists QposInfinity. split. constructor. 180 | simpl. inversion X. 181 | Qed. 182 | 183 | Record pt := 184 | { LT :> Subset QposInf 185 | ; LT_pt : Pt LT 186 | }. 187 | 188 | Definition pt_le (x y : pt) := forall q, LT x q -> q <|[toPSL PosUR] LT y. 189 | 190 | Definition pt_eq (x y : pt) := (pt_le x y * pt_le y x)%type. 191 | Definition zero : pt := 192 | {| LT := URzero ; LT_pt := URzero_pt |}. -------------------------------------------------------------------------------- /src/FormTopC/Subspace.v: -------------------------------------------------------------------------------- 1 | Require Import 2 | Algebra.SetsC 3 | Algebra.OrderC 4 | Algebra.PreOrder 5 | FormTopC.FormTop 6 | FormTopC.Cont 7 | FormTopC.Locale 8 | FormTopC.FormalSpace 9 | CRelationClasses. 10 | 11 | Local Open Scope Subset. 12 | Local Open Scope FT. 13 | Set Universe Polymorphism. 14 | 15 | Existing Instances FormalSpace.FT FormalSpace.PreO 16 | FormalSpace.Cov_Proper FormalSpace.Cov_Proper2 17 | FormalSpace.Cov_Proper3. 18 | 19 | (** General properties of subspaces and their inclusions. *) 20 | 21 | Section GenSub. 22 | Context {A : FormalSpace.t}. 23 | 24 | Variable Cov' : A -> Open A -> Type. 25 | 26 | Definition Subspace : PreSpace.t := 27 | {| PreSpace.S := PreSpace.S A 28 | ; PreSpace.Cov := Cov' 29 | |}. 30 | 31 | Hypothesis tSubspace : FormTop.t Subspace. 32 | Hypothesis tPosSub : tPos Subspace. 33 | 34 | Definition SubspaceSub : FormalSpace.t := 35 | {| S := Subspace 36 | ; isFT := tSubspace |}. 37 | 38 | Definition incl : Cont.map Subspace A := 39 | fun a => Sat SubspaceSub (eq a). 40 | 41 | Hypothesis CovImpl : PreSpace.Cov A ⊑ PreSpace.Cov SubspaceSub. 42 | 43 | Lemma incl_refl : forall a, incl a a. 44 | Proof. 45 | intros. unfold incl, Sat. apply FormTop.refl. 46 | reflexivity. 47 | Qed. 48 | 49 | Lemma incl_cont : Cont.t Subspace A incl. 50 | Proof. 51 | econstructor; intros. 52 | - apply FormTop.refl. exists a. unfold In. auto. 53 | apply incl_refl. 54 | - unfold incl, Sat in *. rewrite X. assumption. 55 | - unfold incl, Sat in X, X0. 56 | FormTop.ejoin. FormTop.etrans. apply FormTop.refl. 57 | exists a. assumption. apply incl_refl. 58 | - unfold incl, Sat in X. FormTop.etrans. 59 | unfold In in X. subst. apply CovImpl in X0. 60 | FormTop.etrans. apply FormTop.refl. 61 | exists a. assumption. apply incl_refl. 62 | Qed. 63 | 64 | End GenSub. 65 | 66 | (** Closed subspaces *) 67 | Section Defn. 68 | Context {A : FormalSpace.t}. 69 | Variable (V : Open A). 70 | 71 | Definition CovC a U := a <|[A] V ∪ U. 72 | 73 | 74 | Definition Closed : PreSpace.t := 75 | {| PreSpace.S := PreSpace.S A 76 | ; PreSpace.Cov := CovC 77 | |}. 78 | 79 | Theorem t : FormTop.t Closed. 80 | Proof. 81 | constructor; unfold CovC; intros. 82 | - apply FormalSpace.refl. right. assumption. 83 | - FormalSpace.etrans. 84 | destruct X. 85 | + apply FormalSpace.refl. left. assumption. 86 | + apply X0. assumption. 87 | - apply FormalSpace.le_left with b; assumption. 88 | - FormalSpace.ejoin. simpl in *. unfold CovC. 89 | FormalSpace.etrans. 90 | destruct X1. destruct d, d0. 91 | destruct i. 92 | + rewrite l. apply FormalSpace.refl. left. assumption. 93 | + destruct i0. rewrite l0. apply FormalSpace.refl. 94 | left. assumption. 95 | rewrite <- Union_Included_r. 96 | apply FormTop.le_right. 97 | * rewrite l. apply FormalSpace.refl. assumption. 98 | * rewrite l0. apply FormalSpace.refl. assumption. 99 | Qed. 100 | 101 | Definition ClosedSub : FormalSpace.t := 102 | {| S := Closed 103 | ; isFT := t |}. 104 | 105 | Definition closed_incl : Cont.map ClosedSub A := 106 | incl CovC t. 107 | 108 | Lemma closed_incl_cont : Cont.t ClosedSub A closed_incl. 109 | Proof. 110 | apply incl_cont. intros. simpl. 111 | unfold RelIncl, Included, pointwise_rel, arrow, CovC. 112 | intros. 113 | FormTop.etrans. apply FormTop.refl. right. assumption. 114 | Qed. 115 | 116 | (** Open subspaces. *) 117 | 118 | Definition CovO a U := eq a ↓ V <<|[A] U. 119 | 120 | Definition OpenPS : PreSpace.t := 121 | {| PreSpace.S := PreSpace.S A 122 | ; PreSpace.Cov := CovO 123 | |}. 124 | 125 | Theorem tOpen : FormTop.t OpenPS. 126 | Proof. 127 | constructor; simpl; unfold CovO; intros. 128 | - destruct X0. destruct d, d0. unfold In in i. 129 | subst. rewrite l. apply FormalSpace.refl. assumption. 130 | - destruct X1. destruct d, d0. unfold In in i. subst. 131 | apply (FormalSpace.trans (U := (U ↓ eq a0) ↓ V)). 132 | Focus 2. intros a X2. destruct X2. 133 | destruct d, d0. destruct i. le_downH d0. destruct d. 134 | eapply X0. eassumption. 135 | split. exists a5. reflexivity. rewrite <- l3. assumption. 136 | exists a4; assumption. 137 | apply FormalSpace.le_right. apply FormalSpace.le_right. 138 | apply X. split. le_down. assumption. 139 | exists a2; assumption. apply FormalSpace.refl. reflexivity. 140 | rewrite l0. apply FormalSpace.refl. assumption. 141 | - destruct X1. destruct d, d0. unfold In in i. 142 | subst. eapply FormalSpace.trans. 143 | 2: eapply X0. eapply FormalSpace.le_right. 144 | rewrite l, X. apply FormalSpace.refl. reflexivity. 145 | rewrite l0. apply FormalSpace.refl. assumption. 146 | - destruct X1. destruct d, d0. 147 | unfold In in i. subst. 148 | apply FormalSpace.le_right. eapply FormalSpace.trans. 149 | 2: eapply X. apply FormalSpace.le_right. 150 | rewrite l. apply FormalSpace.refl. reflexivity. 151 | rewrite l0. apply FormalSpace.refl. assumption. 152 | eapply FormalSpace.trans. 2: eapply X0. 153 | apply FormalSpace.le_right. rewrite l. apply FormalSpace.refl. 154 | reflexivity. rewrite l0. apply FormalSpace.refl. 155 | assumption. 156 | Qed. 157 | 158 | Definition OpenSub : FormalSpace.t := 159 | {| S := OpenPS 160 | ; isFT := tOpen |}. 161 | 162 | Definition open_incl : Cont.map OpenSub A := 163 | incl CovO tOpen. 164 | 165 | Lemma open_incl_cont : Cont.t OpenSub A open_incl. 166 | Proof. 167 | apply incl_cont. intros. simpl. 168 | unfold RelIncl, Included, pointwise_rel, arrow, CovO. 169 | intros. destruct X0. destruct d. unfold In in *. 170 | subst. rewrite l. assumption. 171 | Qed. 172 | 173 | 174 | End Defn. -------------------------------------------------------------------------------- /src/FormTopC/Sum.v: -------------------------------------------------------------------------------- 1 | Require Import 2 | Prob.StdLib 3 | Types.UIP 4 | FormTopC.FormTop 5 | Algebra.OrderC 6 | Algebra.SetsC 7 | Algebra.PreOrder 8 | FormTopC.Cont 9 | FormTopC.FormalSpace. 10 | 11 | Set Universe Polymorphism. 12 | Set Asymmetric Patterns. 13 | 14 | Local Open Scope FT. 15 | 16 | Class HasBot {A : IGt} 17 | : Type := 18 | { bot : S A 19 | ; bot_le : forall {s : S A}, le A bot s 20 | ; bot_cov : forall (U : Subset (S A)), bot <|[A] U 21 | }. 22 | 23 | Arguments HasBot : clear implicits. 24 | 25 | Definition posIGT {A : IGt} `{APos : FormTop.gtPos A} 26 | (x : S A) := FormTop.gPos (gtPos := APos) x. 27 | 28 | Lemma bot_Pos (A : IGt) `{APos : FormTop.gtPos A} `(HasBot A) : 29 | posIGT bot -> False. 30 | Proof. 31 | intros contra. 32 | pose (FormTop.GCov_Pos (H := APos)). 33 | pose proof (FormTop.mono bot (fun _ => False)). 34 | cut (Inhabited ((fun _ : S A => False) ∩ FormTop.Pos)%Subset). 35 | intros. destruct X0. destruct i. auto. 36 | apply X. simpl. assumption. 37 | apply bot_cov. 38 | Qed. 39 | 40 | (** Sum (coproduct) spaces 41 | 42 | The space `A + B` has: 43 | 44 | Basic opens `inl a` for `a` a basic open in `A`, meaning that it 45 | is in the left side (`A`), as well as basic opens `inr b` for 46 | `b` a basic open in `B`. 47 | 48 | inl a <= inl a' if a <= a' 49 | inr b <= inr b' if b <= b' 50 | Otherwise, x <= y is false. 51 | 52 | inl a <| { inl u | u in U } (for each covering `a <| U` in A) 53 | inr b <| { inr v | v in V } (for each covering `b <| V` in B) 54 | 55 | Pos(inl a) iff Pos(a) 56 | Pos(inr b) iff Pos(b) 57 | 58 | *) 59 | 60 | Section Sum. 61 | 62 | Context {Ix : Type}. 63 | Context {Ix_UIP : EqdepFacts.UIP_ Ix}. 64 | Context {A : Ix -> IGt}. 65 | 66 | Definition S' := SomeOpen A. 67 | 68 | Definition SomeOpen := MkSomeOpen (X := A). 69 | 70 | Inductive Ix' : S' -> Type := 71 | | MkIx : forall {ix : Ix} {s : A ix}, PreISpace.Ix (A ix) s -> 72 | Ix' (SomeOpen ix s). 73 | 74 | Arguments Ix' : clear implicits. 75 | 76 | Inductive InDisjunct {ix : Ix} {U : Open (A ix)} : Subset S' := 77 | | MkInDisjunct : forall s : A ix, In U s -> In InDisjunct (SomeOpen ix s). 78 | 79 | Arguments InDisjunct {ix} U. 80 | 81 | Definition C' (p : S') (ix : Ix' p) : Subset S' := match ix with 82 | | MkIx ix s ax => InDisjunct (PreISpace.C (A ix) s ax) 83 | end. 84 | 85 | Definition le' : S' -> S' -> Type := SomeOpen_le (X := A). 86 | 87 | Definition SumPreOrder : PreOrder := 88 | {| PO_car := S' 89 | ; le := le' 90 | |}. 91 | 92 | Local Instance PO : PreO.t (le SumPreOrder). 93 | Proof. 94 | unshelve eapply Sum_PO; eassumption. 95 | Qed. 96 | 97 | 98 | Definition SumPS : PreISpace.t := 99 | {| PreISpace.S := SumPreOrder 100 | ; PreISpace.Ix := Ix' 101 | ; PreISpace.C := C' 102 | |}. 103 | 104 | Local Instance loc 105 | (locA : forall ix, localized (A ix)) : FormTop.localized SumPS. 106 | Proof. 107 | unfold FormTop.localized. 108 | intros a c H1 i. destruct i. 109 | UIP_inv H1. 110 | destruct (locA ix aix0 s X i) as (i' & Hi'). 111 | exists (MkIx i'). 112 | intros u X0. simpl in X0. UIP_inv X0. 113 | specialize (Hi' s0 X1). destruct Hi'. le_downH d. 114 | split. le_down. 115 | simpl. constructor. assumption. 116 | destruct d0. eexists. econstructor. eassumption. 117 | econstructor. eassumption. 118 | Qed. 119 | 120 | Local Open Scope Subset. 121 | 122 | Lemma cov1 : forall ix p U, p <|[A ix] (fun l : A ix => U (SomeOpen ix l)) 123 | -> SomeOpen ix p <|[toPSL SumPS] U. 124 | Proof. 125 | intros. remember (fun l : A ix => U (SomeOpen ix l)) as V. 126 | induction X; subst. 127 | - econstructor. eassumption. 128 | - eapply glle_left. econstructor; eassumption. 129 | apply IHX. reflexivity. 130 | - apply gle_infinity with (SomeOpen ix b) (MkIx i). 131 | constructor. assumption. 132 | intros u Pu. destruct u. 133 | destruct Pu. le_downH d. 134 | UIP_inv d. apply X. 2: reflexivity. 135 | split. le_down. assumption. 136 | destruct d0. destruct a0. 137 | simpl in l0. UIP_inv l0. UIP_inv i0. 138 | eexists; eassumption. 139 | Qed. 140 | 141 | Lemma cov1' : forall ix p U, SomeOpen ix p <|[toPSL SumPS] U 142 | -> p <|[A ix] (fun l : A ix => U (SomeOpen ix l)). 143 | Proof. 144 | intros. remember (SomeOpen ix p) as a. 145 | generalize dependent ix. 146 | induction X; intros; subst. 147 | - econstructor. eassumption. 148 | - UIP_inv l. eapply FormTop.glle_left. 149 | eassumption. apply IHX. 150 | reflexivity. 151 | - UIP_inv l. 152 | remember ({| SOIx := ix; SOOpen := bix |}) as u. 153 | induction i. 154 | UIP_inv Hequ. 155 | eapply FormTop.gle_infinity with bix i. 156 | assumption. intros. 157 | eapply X. 2:reflexivity. 158 | destruct X1 as (d & d0). 159 | split. le_down. constructor. le_downH d. 160 | assumption. 161 | destruct d0 as [u' Pu' lu']. 162 | exists (SomeOpen ix u'). 163 | unfold In. simpl. 164 | econstructor. assumption. 165 | econstructor. assumption. 166 | Qed. 167 | 168 | Definition Sum : IGt := 169 | {| IGS := SumPS 170 | ; IGPO := PO |}. 171 | 172 | Inductive Inj (ix : Ix) : Cont.map (A ix) Sum := 173 | | MkInj : forall a b, a <=[A ix] b -> Inj ix (SomeOpen ix b) a. 174 | 175 | Lemma Inj_cont (ix : Ix) : IGCont.t (A ix) Sum (Inj ix). 176 | Proof. 177 | unshelve econstructor; intros. 178 | - apply FormTop.refl. exists (SomeOpen ix a). unfold In. 179 | constructor. constructor. reflexivity. 180 | - induction X. inv X0. 181 | apply FormTop.refl. exists (SomeOpen ix a). 182 | split; le_down; constructor; assumption. constructor. reflexivity. 183 | - induction X0. econstructor. etransitivity; eassumption. 184 | - induction X. UIP_inv X0. econstructor. 185 | etransitivity; eassumption. 186 | - induction j. 187 | UIP_inv X0. UIP_inv X. 188 | apply FormTop.gle_infinity with s i. 189 | etransitivity; eassumption. 190 | intros. apply FormTop.glrefl. 191 | destruct X. le_downH d. destruct d0. 192 | exists (SomeOpen ix0 u). split. le_down. 193 | constructor. transitivity a; assumption. 194 | exists (SomeOpen ix0 a0). constructor. assumption. 195 | constructor. assumption. 196 | constructor. reflexivity. 197 | Qed. 198 | 199 | Context {APos : forall ix : Ix, FormTop.gtPos (A ix)}. 200 | 201 | Inductive PosSum : Subset S' := 202 | | MkPos : forall (ix : Ix) {s : A ix}, FormTop.gPos s -> PosSum (SomeOpen ix s). 203 | 204 | Local Instance Pos : FormTop.gtPos SumPS. 205 | Proof. 206 | unshelve econstructor. 207 | - exact PosSum. 208 | - intros. induction X. UIP_inv X0. 209 | constructor. eapply gmono_le; eassumption. 210 | - intros. destruct i. 211 | + UIP_inv X0. UIP_inv X. 212 | destruct (gmono_ax (A := A ix) s i s0 X0 X1). 213 | destruct i0. destruct d. le_downH d. 214 | exists (SomeOpen ix a). split. split. 215 | le_down. constructor. assumption. 216 | destruct d0. 217 | eexists. econstructor. eassumption. 218 | constructor. assumption. 219 | econstructor. assumption. 220 | - intros. destruct a. 221 | + apply cov1. apply gpositive. 222 | intros. apply cov1'. apply X. constructor. assumption. 223 | Qed. 224 | 225 | End Sum. -------------------------------------------------------------------------------- /src/FormTopC/Truncate.v: -------------------------------------------------------------------------------- 1 | (** Propositional truncation of spaces. *) 2 | 3 | Require Import 4 | Coq.Classes.CMorphisms 5 | 6 | Algebra.SetsC 7 | Algebra.OrderC 8 | Algebra.PreOrder 9 | FormTopC.FormTop 10 | FormTopC.FormalSpace 11 | FormTopC.Cont. 12 | 13 | Set Universe Polymorphism. 14 | Set Asymmetric Patterns. 15 | 16 | Local Open Scope FT. 17 | 18 | Section Truncate. 19 | 20 | Variable A : IGt. 21 | Context {A_Pos : FormTop.gtPos A}. 22 | 23 | Inductive le {s t : A} : Type := 24 | | Orig : s <=[A] t -> le 25 | | IPos : FormTop.gPos t -> le. 26 | 27 | Arguments le : clear implicits. 28 | 29 | Local Instance POSle : PreO.t le. 30 | Proof. 31 | econstructor. 32 | - intros. apply Orig. reflexivity. 33 | - intros. destruct X. destruct X0. 34 | apply Orig. etransitivity; eassumption. 35 | apply IPos. assumption. destruct X0. apply IPos. 36 | eapply (FormTop.gmono_le); eassumption. 37 | apply IPos. eassumption. 38 | Qed. 39 | 40 | Definition A'PO : PreOrder := 41 | {| PO_car := A 42 | ; PreOrder.le := le 43 | |}. 44 | 45 | Definition A' : PreISpace.t := 46 | {| PreISpace.S := A'PO 47 | ; PreISpace.C := PreISpace.C A 48 | |}. 49 | 50 | Lemma Cov_Refine : forall a U, 51 | a <|[A] U 52 | -> a <|[toPSL A'] U. 53 | Proof. 54 | intros. induction X. 55 | - apply FormTop.glrefl. assumption. 56 | - eapply FormTop.glle_left. constructor. eassumption. 57 | eassumption. 58 | - 59 | Abort. 60 | 61 | Local Instance Pos : FormTop.gtPos A'. 62 | Proof. 63 | unshelve econstructor. 64 | - exact (FormTop.gPos (A := A)). 65 | - intros. destruct X. eapply FormTop.gmono_le; eassumption. 66 | assumption. 67 | - intros. 68 | Abort. 69 | 70 | End Truncate. -------------------------------------------------------------------------------- /src/Haskell/Shim.hs: -------------------------------------------------------------------------------- 1 | import Test 2 | 3 | toInt :: Nat -> Int 4 | toInt O = 0 5 | toInt (S n) = 1 + toInt n 6 | 7 | fromInt :: Int -> Nat 8 | fromInt n | n < 0 = error "nat must be at least 0" 9 | fromInt 0 = O 10 | fromInt n = S (fromInt (n - 1)) 11 | 12 | instance Show Nat where 13 | show = show . toInt 14 | 15 | {- 16 | printPartial :: Partial a -> IO () 17 | printPartial (Now _) = putStrLn "Done!" 18 | printPartial (Later x) = putStrLn "Later..." >> printPartial x 19 | -} 20 | -------------------------------------------------------------------------------- /src/Language/ContPL.v: -------------------------------------------------------------------------------- 1 | Set Universe Polymorphism. 2 | Set Asymmetric Patterns. 3 | 4 | Require Import Coq.Lists.List. 5 | 6 | Import ListNotations. 7 | 8 | (** Heterogenous lists *) 9 | Fixpoint hlist {A} (xs : list A) (B : A -> Type) : Type := match xs with 10 | | nil => True 11 | | x :: xs' => (B x * hlist xs' B)%type 12 | end. 13 | 14 | (** Map a function over a heterogenous list *) 15 | Fixpoint hmap {A B C} (f : forall a, B a -> C a) {xs : list A} : hlist xs B -> hlist xs C 16 | := match xs with| nil => fun ys => ys 17 | | x :: xs' => fun ys => let (y, ys') := ys in (f _ y, hmap f ys') 18 | end. 19 | 20 | (** Create a variadic function using heterogenous lists *) 21 | Fixpoint hsplay {A} (xs : list A) (B : A -> Type) (result : Type) : Type := match xs with 22 | | nil => result 23 | | x :: xs' => B x -> hsplay xs' B result 24 | end. 25 | 26 | (** Map a function over the result of a "splayed" construction *) 27 | Fixpoint splaymap {A R1 R2} (f : R1 -> R2) {xs : list A} {B : A -> Type} 28 | : hsplay xs B R1 -> hsplay xs B R2 := match xs with 29 | | nil => f 30 | | y :: ys => fun g x => splaymap f (g x) 31 | end. 32 | 33 | (** Build a heterogenous list in a variadic fashion *) 34 | Fixpoint Bhlist {A} (xs : list A) (B : A -> Type) : hsplay xs B (hlist xs B) := 35 | match xs with 36 | | nil => I 37 | | y :: ys => fun x => splaymap (fun zs => (x, zs)) (Bhlist ys B) 38 | end. 39 | 40 | (** Apply a "splayed" function to its arguments given as a heterogenous list *) 41 | Fixpoint unsplay {A} (xs : list A) 42 | {B : A -> Type} {R : Type} 43 | : hsplay xs B R -> hlist xs B -> R 44 | := match xs as xs' return hsplay xs' B R -> hlist xs' B -> R with 45 | | nil => fun f _ => f 46 | | x :: xs' => fun f ys => let (y, ys') := ys in unsplay _ (f y) ys' 47 | end. 48 | 49 | Require Import 50 | Types.Setoid 51 | Algebra.Category 52 | Algebra.Category.Cartesian 53 | Algebra.Category.Monad. 54 | 55 | Local Open Scope morph. 56 | Local Open Scope obj. 57 | 58 | Section ContPL. 59 | 60 | Context {U : Category} {CU : Cartesian U}. 61 | 62 | Fixpoint nprod (xs : list U) : U := match xs with 63 | | nil => unit 64 | | x :: xs' => x * nprod xs' 65 | end. 66 | 67 | Definition Map (As : list U) (B : U) : Setoid := nprod As ~~> B. 68 | Local Infix "~>" := Map (at level 80) : obj_scope. 69 | 70 | (** Convert a list of maps from Γ to different objects 71 | into a single map from Γ to the product of the objects *) 72 | Fixpoint parprod {Γ : U} {As : list U} 73 | : (hlist As (fun A => Γ ~~> A)) -> Γ ~~> nprod As := 74 | match As as As' return (hlist As' (fun A => Γ ~~> A)) -> Γ ~~> nprod As' with 75 | | nil => fun _ => tt 76 | | _ => fun xs => let (y, ys) := xs in 77 | ⟨y, parprod ys⟩ 78 | end. 79 | 80 | Definition splay (Γ : U) (A : list U) (B : U) := hsplay A (fun t => Γ ~~> t) (Γ ~~> B). 81 | 82 | Definition prodsplay (Γ : U) (As : list U) 83 | : splay Γ As (nprod As) := splaymap parprod (Bhlist As (fun t => Γ ~~> t)). 84 | 85 | Definition Call {Γ : U} {A : list U} {B : U} (f : A ~> B) : splay Γ A B := 86 | splaymap (Category.compose f) (prodsplay Γ A). 87 | 88 | Fixpoint instantiateContext (As : list U) 89 | : hlist As (fun t => nprod As ~~> t) := 90 | match As as As' return hlist As' (fun t => nprod As' ~~> t) with 91 | | nil => I 92 | | A :: As' => (fst, hmap (fun _ f => f ∘ snd) 93 | (instantiateContext As')) 94 | end. 95 | 96 | (** Define a function using expressions *) 97 | Definition makeFun (args : list U) {ret : U} 98 | (f : forall Γ, splay Γ args ret) : args ~> ret 99 | := unsplay args (f (nprod args)) (instantiateContext args). 100 | 101 | Definition makeFun1 {arg ret : U} (f : forall Γ, Γ ~~> arg -> Γ ~~> ret) : arg ~~> ret 102 | := f arg Category.id. 103 | 104 | Context {M : U -> U} {MC : SMonad U M}. 105 | 106 | Definition bind {Γ} {A B} (m : Γ ~~> M A) (f : A ~~> M B) : Γ ~~> M B := 107 | join ∘ map f ∘ m. 108 | 109 | Definition Bind {Γ} {A B} (m : Γ ~~> M A) (f : (Γ * A) ~~> M B) : Γ ~~> M B := 110 | bind (strong ∘ ⟨id, m⟩) f. 111 | 112 | Definition Ret {Γ A} (x : Γ ~~> A) : Γ ~~> M A := ret ∘ x. 113 | 114 | Definition addContext {Γ ret : U} (f : Γ ~~> M ret) 115 | : (Γ ~~> M (Γ * ret)) 116 | := strong ∘ ⟨id, f⟩. 117 | 118 | Class Extend {Γ Δ : U} : Type := extend : Δ ~~> Γ . 119 | 120 | Arguments Extend : clear implicits. 121 | 122 | Global Instance Extend_Refl {Γ : U} : Extend Γ Γ := id. 123 | 124 | Global Instance Extend_Prod {Γ Δ A : U} `{f : Extend Γ Δ} 125 | : Extend Γ (Δ * A) := f ∘ fst. 126 | 127 | Global Instance Extend_Compose {A B C : U} 128 | {f : Extend A B} {g : Extend B C} : Extend A C := f ∘ g. 129 | 130 | Definition Lift {Γ Δ A} `{f : Extend Γ Δ} (x : Γ ~~> A) 131 | : Δ ~~> A := x ∘ f. 132 | 133 | Definition liftF {Γ Δ A B : U} 134 | {ext : Extend Γ Δ} (f : Γ * A ~~> B) : Δ * A ~~> B := 135 | f ∘ (ext ⊗ id). 136 | 137 | Definition makeFun1E {Γ arg ret : U} 138 | (f : forall Δ (ext : Extend Γ Δ), Δ ~~> arg -> Δ ~~> ret) 139 | : Γ * arg ~~> ret := f _ extend snd. 140 | 141 | End ContPL. 142 | 143 | Arguments Extend {_} _ _. 144 | 145 | Notation "'FUN' x .. y => t " := 146 | (fun _ => fun x => .. (fun y => t%morph) .. ) 147 | (x binder, y binder, at level 200, right associativity) 148 | : contExp_scope. 149 | 150 | Notation "! x" := (Lift x) (at level 20) : morph_scope. 151 | 152 | Infix "~>" := Map (at level 80) : obj_scope. 153 | 154 | Notation "x <- e ; f" := (Bind e (makeFun1E (fun _ _ x => f))) 155 | (at level 120, right associativity) : morph_scope. 156 | 157 | Notation "'LAM' x => f" := (makeFun1E (fun _ _ x => f)) 158 | (at level 120, right associativity) : morph_scope. 159 | 160 | Section Instances. 161 | 162 | (** Instances *) 163 | 164 | Context {U : Category} {CU : Cartesian U}. 165 | Local Open Scope setoid. 166 | 167 | Lemma lam_extensional {Γ A B} 168 | (f g : forall Δ (ext : Extend Γ Δ), Δ ~~> A -> Δ ~~> B) : 169 | (forall Δ (ext : Extend Γ Δ) a, f _ ext a == g _ ext a) 170 | -> makeFun1E f == makeFun1E g. 171 | Proof. 172 | intros. unfold makeFun1E. apply X. 173 | Qed. 174 | 175 | Require Import CMorphisms. 176 | 177 | Definition ap0 {Γ A : U} (f : unit ~~> A) 178 | : Γ ~~> A := f ∘ tt. 179 | 180 | Definition ap1 {Γ A B : U} (f : A ~~> B) (x : Γ ~~> A) 181 | : Γ ~~> B := f ∘ x. 182 | 183 | Definition ap2 {Γ A B C : U} 184 | (f : A * B ~~> C) (x : Γ ~~> A) (y : Γ ~~> B) : Γ ~~> C := 185 | f ∘ ⟨x, y⟩. 186 | 187 | Definition ap3 {Γ A B C D : U} 188 | (f : A * B * C ~~> D) (x : Γ ~~> A) (y : Γ ~~> B) (z : Γ ~~> C) : Γ ~~> D := 189 | f ∘ ⟨⟨x, y⟩, z⟩. 190 | 191 | Global Instance ap0_Proper : forall Γ A : U, 192 | Proper (seq (unit ~~> A) ==> seq (Γ ~~> A)) ap0. 193 | Proof. 194 | unfold Proper, respectful. 195 | intros. unfold ap0. rewrite X. reflexivity. 196 | Qed. 197 | 198 | Global Instance ap1_Proper : forall Γ A B : U, 199 | Proper (seq (A ~~> B) ==> seq (Γ ~~> A) ==> seq (Γ ~~> B)) ap1. 200 | Proof. 201 | unfold Proper, respectful. 202 | intros. unfold ap1. rewrite X, X0. reflexivity. 203 | Qed. 204 | 205 | Global Instance ap2_Proper : forall Γ A B C : U, 206 | Proper (seq (A * B ~~> C) ==> seq (Γ ~~> A) ==> 207 | seq (Γ ~~> B) ==> seq (Γ ~~> C)) ap2. 208 | Proof. 209 | unfold Proper, respectful. 210 | intros. unfold ap2. rewrite X, X0, X1. reflexivity. 211 | Qed. 212 | 213 | Context {M : U -> U} {MC : SMonad U M} {MCProps : SMonad_Props (smd := MC)}. 214 | 215 | Global Instance bind_Proper {Γ A B} : 216 | Proper (seq (_ ~~> M A) ==> seq (_ ~~> M B) ==> seq (Γ ~~> _)) bind. 217 | Proof. 218 | unfold Proper, respectful; intros. 219 | unfold bind. rewrite X, X0. reflexivity. 220 | Qed. 221 | 222 | Global Instance Bind_Proper {Γ A B} : 223 | Proper (seq (_ ~~> M A) ==> seq (_ ~~> M B) ==> seq (Γ ~~> _)) Bind. 224 | Proof. 225 | unfold Proper, respectful; intros. 226 | unfold Bind. rewrite X, X0. reflexivity. 227 | Qed. 228 | 229 | Global Instance Ret_Proper {Γ A} : 230 | Proper (seq (_ ~~> A) ==> seq (Γ ~~> _)) Ret. 231 | Proof. 232 | unfold Proper, respectful; intros. unfold Ret. 233 | rewrite X. reflexivity. 234 | Qed. 235 | 236 | Global Instance Lift_Proper : forall {Γ Δ A : U} {ext : Extend Γ Δ}, 237 | Proper (seq _ ==> seq _) (Lift (Γ := Γ) (Δ := Δ) (A := A)). 238 | Proof. 239 | intros. unfold Proper, respectful. intros. unfold Lift. 240 | apply compose_Proper. assumption. reflexivity. 241 | Qed. 242 | 243 | Lemma bind_extensional {Γ A B} (mu : Γ ~~> M A) 244 | (f g : forall Δ (ext : Extend Γ Δ), Δ ~~> A -> Δ ~~> M B) : 245 | (forall Δ (ext : Extend Γ Δ) a, f _ ext a == g _ ext a) -> 246 | Bind mu (makeFun1E f) == Bind mu (makeFun1E g). 247 | Proof. 248 | intros. unfold Bind. unfold bind. 249 | apply lam_extensional in X. 250 | rewrite X. reflexivity. 251 | Qed. 252 | 253 | End Instances. -------------------------------------------------------------------------------- /src/Numbers/QFacts.v: -------------------------------------------------------------------------------- 1 | Require Import QArith. 2 | 3 | Definition Qaverage (x z : Q) : (x < z)%Q 4 | -> (let avg := ((x + z) / (1 + 1)) in x < avg /\ avg < z)%Q. 5 | Proof. split. 6 | - apply Qlt_shift_div_l. apply Qlt_alt. reflexivity. 7 | setoid_replace (x * (1 + 1))%Q with (x + x)%Q by ring. 8 | setoid_replace (x + z)%Q with (z + x)%Q by ring. 9 | apply Qplus_lt_le_compat. assumption. apply Qle_refl. 10 | - apply Qlt_shift_div_r. apply Qlt_alt. reflexivity. 11 | setoid_replace (z * (1 + 1))%Q with (z + z)%Q by ring. 12 | apply Qplus_lt_le_compat. assumption. apply Qle_refl. 13 | Qed. 14 | 15 | Definition Qbetween {x z : Q} : (x < z)%Q 16 | -> { y | (x < y /\ y < z)%Q }. 17 | Proof. intros. eexists. apply Qaverage. assumption. 18 | Qed. 19 | 20 | Lemma Qmult_lt_compat_l : forall x y z : Q, 0 < z -> x < y -> z * x < z * y. 21 | Proof. 22 | intros. rewrite (Qmult_comm _ x), (Qmult_comm _ y). 23 | apply Qmult_lt_compat_r; assumption. 24 | Qed. 25 | 26 | Lemma Qmult_lt_compat_l_inv : forall x y z : Q, 27 | 0 < z -> z * x < z * y -> x < y. 28 | Proof. 29 | intros. rewrite <- (Qmult_1_l x), <- (Qmult_1_l y). 30 | rewrite <- !(Qmult_inv_r z). 31 | rewrite (Qmult_comm z). 32 | rewrite <- !Qmult_assoc. apply Qmult_lt_compat_l. 33 | apply Qinv_lt_0_compat. assumption. assumption. 34 | unfold not. intros contra. 35 | rewrite contra in H. 36 | eapply Qlt_irrefl. eassumption. 37 | Qed. 38 | 39 | Instance Qle_Reflexive : Reflexive Qle. 40 | Proof. 41 | unfold Reflexive. apply Qle_refl. 42 | Qed. 43 | 44 | Instance Qle_Transitive : Transitive Qle. 45 | Proof. 46 | unfold Transitive. apply Qle_trans. 47 | Qed. 48 | 49 | Instance Qlt_Transitive : Transitive Qlt. 50 | Proof. 51 | unfold Transitive. apply Qlt_trans. 52 | Qed. 53 | 54 | Require Import RelationClasses. 55 | 56 | Instance Qlt_le_Subrelation : subrelation Qlt Qle. 57 | Proof. 58 | unfold subrelation, predicate_implication, pointwise_lifting 59 | , Basics.impl. 60 | apply Qlt_le_weak. 61 | Qed. 62 | 63 | Instance Qplus_le_Proper : Proper (Qle ==> Qle ==> Qle) Qplus. 64 | Proof. 65 | unfold Proper, respectful. 66 | intros. apply Qplus_le_compat; assumption. 67 | Qed. 68 | 69 | Lemma Qopp_lt_compat: forall p q : Q, (p < q)%Q -> (- q < - p)%Q. 70 | Proof. 71 | intros. rewrite Qlt_minus_iff. rewrite Qopp_involutive. 72 | rewrite Qplus_comm. rewrite <- Qlt_minus_iff. 73 | assumption. 74 | Qed. 75 | 76 | Lemma Qeq_le : forall x y, x == y -> x <= y. 77 | Proof. 78 | intros. rewrite H. reflexivity. 79 | Qed. 80 | 81 | Lemma Qminus_lt {q x y : Q} : 82 | q < x + y <-> q - y < x. 83 | Proof. 84 | rewrite (Qlt_minus_iff q). 85 | rewrite (Qlt_minus_iff (q - y)). 86 | split; intros; 87 | (eapply Qlt_le_trans; [ eassumption | apply Qeq_le; ring ]). 88 | Qed. 89 | 90 | Lemma Qplus_open : forall q x y : Q, (q < x + y 91 | -> exists x' y', x' < x /\ y' < y /\ (q <= x' + y'))%Q. 92 | Proof. 93 | intros. 94 | (** WRONG WRONG WRONG *) 95 | assert (q - y < x) as d1. apply Qminus_lt. assumption. 96 | assert (q - x < y) as d2. apply Qminus_lt. 97 | rewrite Qplus_comm. assumption. 98 | destruct (Qbetween d1) as (mid1 & midl1 & midh1). 99 | pose proof (Qbetween d2) as (mid2 & midl2 & midh2). 100 | exists mid1. exists mid2. split. 101 | assumption. split. assumption. 102 | apply Qminus_lt in midl1. apply Qminus_lt in midl2. 103 | Admitted. -------------------------------------------------------------------------------- /src/Numbers/QPosFacts.v: -------------------------------------------------------------------------------- 1 | Require Import 2 | Numbers.QFacts 3 | CoRN.model.structures.QposInf. 4 | 5 | Set Universe Polymorphism. 6 | 7 | Definition Qpos_two : Qpos := Qpos_one + Qpos_one. 8 | 9 | Definition Qpos_one_half : Qpos := Qpos_one / Qpos_two. 10 | 11 | Lemma one_half_sum_one : Qpos_one_half + Qpos_one_half == 1. 12 | Proof. 13 | reflexivity. 14 | Qed. 15 | 16 | Lemma one_half_sum : forall e, 17 | (Qpos_one_half * e)%Qpos + (Qpos_one_half * e)%Qpos == e. 18 | Proof. 19 | intros. simpl. rewrite <- Qmult_plus_distr_l. 20 | rewrite one_half_sum_one. apply Qmult_1_l. 21 | Qed. 22 | 23 | Definition Qpos_smaller (x : Qpos) : { y : Qpos & y < x }. 24 | Proof. 25 | exists (Qpos_mult Qpos_one_half x). 26 | unfold lt. 27 | simpl. 28 | setoid_replace (x : Q) with (Qmult 1%Q (Qmult 1%Q (x : Q))) at 2 by ring. 29 | rewrite (Qmult_comm 1). 30 | rewrite <- Qmult_assoc. apply Qmult_lt_compat_r. 31 | ring_simplify. apply Qpos_prf. 32 | reflexivity. 33 | Qed. 34 | 35 | Definition Qpos_larger (x : Qpos) : { y : Qpos & x < y }. 36 | Proof. 37 | exists (x + x)%Qpos. 38 | setoid_replace (x : Q) with (0 + x)%Q at 1 by ring. 39 | simpl. apply Qplus_lt_l. apply Qpos_prf. 40 | Qed. 41 | 42 | Definition Qpos_between {x y : Qpos} : 43 | x < y -> { mid : Qpos & x < mid /\ mid < y }. 44 | Proof. 45 | intros H. 46 | destruct (Qbetween H) as (mid & midl & midh). 47 | assert (0 < mid) as H'. 48 | eapply Qlt_trans. apply Qpos_prf. apply midl. 49 | exists (exist _ mid H'). simpl. split; assumption. 50 | Qed. 51 | 52 | Lemma Qpos_one_half_lt : forall (x : Qpos), 53 | (Qpos_one_half * x)%Qpos < x. 54 | Proof. 55 | intros. rewrite <- (Qplus_0_r). 56 | rewrite <- (one_half_sum x). 57 | apply Qplus_lt_r. apply Qpos_prf. 58 | Qed. 59 | 60 | Lemma Qpos_plus_comm (x y : Qpos) 61 | : (x + y == y + x)%Qpos. 62 | Proof. 63 | ring. 64 | Qed. 65 | 66 | Lemma Qpos_plus_lt_l (q : Q) (e : Qpos) : 67 | q < e + q. 68 | Proof. 69 | setoid_replace q with (0 + q)%Q at 1 by ring. 70 | apply Qplus_lt_l. apply Qpos_prf. 71 | Qed. 72 | 73 | Lemma Qlt_all_Qle (x y : Q) : 74 | (forall (eps : Qpos), x < y + eps) -> (x <= y)%Q. 75 | Proof. 76 | intros H. 77 | destruct (Qlt_le_dec y x); try assumption. 78 | exfalso. 79 | destruct (Qpos_lt_plus q). 80 | specialize (H x0). 81 | rewrite q0 in H. 82 | apply Qplus_lt_l in H. 83 | eapply Qlt_irrefl. eassumption. 84 | Qed. 85 | 86 | Lemma Qadd_lt x y (eps : Qpos) : eps + x < y -> x < y. 87 | Proof. 88 | intros H. 89 | setoid_replace (x : Q) with (0 + x) at 1 by ring. 90 | eapply Qle_lt_trans. 2: eassumption. 91 | apply Qplus_le_l. apply Qlt_le_weak. 92 | apply Qpos_prf. 93 | Qed. 94 | 95 | Lemma Qpos_inv_scale_1 (y : Qpos) (e : Q) : y * (Qpos_inv y * e) == e. 96 | Proof. 97 | intros. simpl. rewrite Qmult_assoc. rewrite Qmult_inv_r. 98 | ring. unfold not. intros contra. 99 | eapply Qlt_not_eq. apply Qpos_prf. symmetry. eassumption. 100 | Qed. 101 | 102 | Lemma Qpos_inv_scale_2 (eps : Qpos) (x : Q) 103 | : Qpos_inv eps * (eps * x) == x. 104 | Proof. 105 | rewrite Qmult_assoc. rewrite (Qmult_comm _ eps). 106 | rewrite <- Qmult_assoc. apply Qpos_inv_scale_1. 107 | Qed. 108 | 109 | Lemma Qpos_inv_lt : forall x y q : Qpos, 110 | (x < Qpos_inv y * q 111 | -> y * x < q)%Qpos. 112 | Proof. 113 | intros. apply Qmult_lt_compat_l_inv with (Qpos_inv y). 114 | apply Qpos_prf. 115 | rewrite Qmult_assoc. rewrite (Qmult_comm _ y). 116 | rewrite <- Qmult_assoc. 117 | rewrite Qpos_inv_scale_1. assumption. 118 | Qed. 119 | 120 | Definition Qpos1 : Qpos. 121 | apply (@mkQpos 1). reflexivity. 122 | Defined. 123 | 124 | Definition Qpossmaller (q : QposInf) : Qpos := match q with 125 | | Qpos2QposInf q' => q' 126 | | QposInfinity => Qpos1 127 | end. 128 | 129 | Definition Qpossmaller_prf : forall (q : QposInf), 130 | QposInf_le (Qpossmaller q) q. 131 | Proof. 132 | intros. unfold QposInf_le, Qpossmaller. destruct q; auto. 133 | apply Qle_refl. 134 | Qed. -------------------------------------------------------------------------------- /src/StdLib.v: -------------------------------------------------------------------------------- 1 | Set Universe Polymorphism. 2 | 3 | (** Some useful tactics. *) 4 | 5 | Ltac inv H := inversion H; clear H; subst. 6 | 7 | (** The template-polymorphic 'prod' from the standard 8 | library just ain't good enough! *) 9 | Inductive prod {A B : Type} : Type := 10 | pair : A -> B -> prod. 11 | 12 | Arguments prod : clear implicits. 13 | 14 | Infix "*" := prod : type_scope. 15 | 16 | Definition fst {A B} (p : A * B) := let (x, _) := p in x. 17 | Definition snd {A B} (p : A * B) := let (_, y) := p in y. 18 | 19 | Notation "( x , y , .. , z )" := (pair .. (pair x y) .. z) 20 | : core_scope. 21 | 22 | Inductive sum {A B : Type} : Type := 23 | | inl : A -> sum 24 | | inr : B -> sum. 25 | 26 | Arguments sum : clear implicits. 27 | 28 | Infix "+" := sum : type_scope. 29 | 30 | Hint Resolve pair inl inr : core v62. 31 | 32 | 33 | 34 | (* 35 | (* Universe-polymorphic versions of things from 36 | CRelationClasses and CMorphisms. *) 37 | 38 | Definition iffT (A B : Type) := ((A -> B) * (B -> A))%type. 39 | 40 | Typeclasses Opaque iffT. 41 | 42 | Require Import CRelationClasses. 43 | 44 | Instance iffT_Reflexive : Reflexive iffT. 45 | Proof. firstorder. Qed. 46 | 47 | Instance iffT_Symmetric : Symmetric iffT. 48 | Proof. firstorder. Qed. 49 | 50 | Instance iffT_Transitive : Transitive iffT. 51 | Proof. firstorder. Qed. 52 | 53 | Instance iffT_arrow_subrelation : subrelation iffT arrow | 2. 54 | Proof. firstorder. Qed. 55 | 56 | Instance iffT_flip_arrow_subrelation : subrelation iffT (flip arrow) | 2. 57 | Proof. firstorder. Qed. 58 | *) -------------------------------------------------------------------------------- /src/Types/Equiv.v: -------------------------------------------------------------------------------- 1 | Require Import FunctionalExtensionality. 2 | 3 | Set Asymmetric Patterns. 4 | 5 | Module EqualNotations. 6 | 7 | Infix "#" := f_equal (at level 30, right associativity) : equal_scope. 8 | Infix "@" := eq_trans (at level 60) : equal_scope. 9 | Delimit Scope equal_scope with equal. 10 | 11 | End EqualNotations. 12 | 13 | Module Equiv. 14 | Import EqualNotations. 15 | Local Open Scope equal. 16 | 17 | (** Equivalences between types. *) 18 | Record T { A B : Type } : Type := 19 | { to : A -> B 20 | ; from : B -> A 21 | ; from_to : forall (a : A), from (to a) = a 22 | ; to_from : forall (b : B), to (from b) = b 23 | ; tau : forall (a : A), f_equal to (from_to a) = to_from (to a) 24 | }. 25 | 26 | Arguments T : clear implicits. 27 | 28 | (** Isomorphisms form an equivalence relation: they are reflexivity, 29 | symmetric, and transitive. *) 30 | Theorem Refl (A : Type) : T A A. 31 | Proof. 32 | refine ( 33 | {| to := fun x => x 34 | ; from := fun x => x 35 | ; from_to := fun _ => eq_refl 36 | ; to_from := fun _ => eq_refl |}); 37 | reflexivity. 38 | Defined. 39 | 40 | Definition f_equal_compose A B C (g : B -> C) (f : A -> B) x y (H : x = y) : 41 | g # f # H = (fun a => g (f a)) # H := 42 | match H with 43 | | eq_refl => eq_refl 44 | end. 45 | 46 | Definition transport {A} (P : A -> Type) {x y} (H : x = y) (f : P x) : P y 47 | := eq_rect x P f y H. 48 | 49 | Definition f_equal_extensional A B (f g : A -> B) 50 | (fg : forall a, f a = g a) x y (H : x = y) 51 | : g # H = 52 | transport (fun fy => g x = fy) (fg y) 53 | (transport (fun fx => fx = f y) (fg x) 54 | (f # H)). 55 | Proof. 56 | refine (match H with eq_refl => _ end). 57 | clear H. unfold transport, eq_rect. simpl. 58 | refine (match fg x with eq_refl => _ end). 59 | reflexivity. 60 | Qed. 61 | 62 | Definition f_equal_id A (x y : A) (H : x = y) : (fun z => z) # H = H 63 | := match H with eq_refl => eq_refl end. 64 | 65 | Definition eq_trans_id_l {A} {x y : A} (p : x = y) : eq_refl @ p = p. 66 | Proof. 67 | intros. refine (match p with eq_refl => _ end). simpl. reflexivity. 68 | Qed. 69 | 70 | Definition eq_trans_id_r {A} {x y : A} (p : x = y) : p @ eq_refl = p. 71 | Proof. 72 | intros. refine (match p with eq_refl => _ end). simpl. reflexivity. 73 | Qed. 74 | 75 | Definition eq_trans_assoc {A} {w x y z : A} (p : w = x) (q : x = y) (r : y = z) 76 | : p @ (q @ r) = (p @ q) @ r. 77 | Proof. 78 | refine (match r with eq_refl => _ end). simpl. 79 | reflexivity. 80 | Qed. 81 | 82 | (** Lemma 2.4.3 of HoTT book *) 83 | Definition f_equal_natural {A B} {f g : A -> B} (H : forall a, f a = g a) 84 | {x y} (p : x = y) : H x @ g # p = f # p @ H y. 85 | Proof. 86 | refine (match p with eq_refl => _ end). 87 | simpl. symmetry. apply f_equal_id. 88 | Qed. 89 | 90 | Definition eq_sym_r {A} {x y : A} (p : x = y) : 91 | p @ eq_sym p = eq_refl := 92 | match p with eq_refl => eq_refl end. 93 | 94 | Definition eq_sym_l {A} {x y : A} (p : x = y) : 95 | eq_sym p @ p = eq_refl := 96 | match p with eq_refl => eq_refl end. 97 | 98 | Definition whisker_right : forall {A} {x y z : A} {p1 p2 : x = y} (q : y = z) 99 | , p1 @ q = p2 @ q -> p1 = p2. 100 | Proof. 101 | intros. rewrite <- (eq_trans_id_r p1). 102 | rewrite <- (eq_sym_r q). rewrite eq_trans_assoc. 103 | rewrite H. rewrite <- eq_trans_assoc. rewrite eq_sym_r. 104 | rewrite eq_trans_id_r. reflexivity. 105 | Qed. 106 | 107 | Definition whisker_left : forall {A} {x y z : A} {q1 q2 : y = z} (p : x = y) 108 | , p @ q1 = p @ q2 -> q1 = q2. 109 | Proof. 110 | intros. rewrite <- (eq_trans_id_l q1). 111 | rewrite <- (eq_sym_l p). rewrite <- eq_trans_assoc. 112 | rewrite H. rewrite eq_trans_assoc. rewrite eq_sym_l. 113 | rewrite eq_trans_id_l. reflexivity. 114 | Qed. 115 | 116 | (** Corollary 2.4.4 of HoTT book *) 117 | Definition f_equal_homotopy_commutes {A} {f : A -> A} 118 | (H : forall a, f a = a) (x : A) : H (f x) = f # (H x). 119 | Proof. 120 | pose proof (f_equal_natural (g := fun x => x) H (H x)). 121 | rewrite f_equal_id in H0. 122 | apply (whisker_right (H x)). assumption. 123 | Qed. 124 | 125 | Definition f_equal_eq {A B} {x y : A} (f : A -> B) {p q : x = y} 126 | (eqprf : p = q) : f # p = f # q := 127 | match eqprf with eq_refl => eq_refl end. 128 | 129 | Definition f_equal_trans_distr {A B} {x y z : A} (f : A -> B) 130 | (p : x = y) (q : y = z) 131 | : f # (p @ q) = (f # p) @ (f # q). 132 | Proof. 133 | refine (match q with eq_refl => _ end). simpl. 134 | reflexivity. 135 | Qed. 136 | 137 | Definition lemma422 {A B : Type} (iso : T A B) 138 | : forall b : B, 139 | from iso # to_from iso b = from_to iso (from iso b). 140 | Proof. 141 | intros. 142 | pose proof (tau iso). 143 | pose proof (f_equal_natural (to_from iso) (to_from iso b)). 144 | apply (f_equal_eq (from iso)) in H0. 145 | rewrite !f_equal_trans_distr in H0. 146 | rewrite <- (tau iso (from iso b)) in H0. 147 | rewrite f_equal_compose in H0. 148 | rewrite <- (f_equal_homotopy_commutes (from_to iso)) in H0. 149 | pose proof (f_equal_natural (from_to iso) (from iso # to_from iso b)). 150 | rewrite !f_equal_id in H0, H1. 151 | rewrite H0 in H1. 152 | rewrite !f_equal_compose in H1. 153 | rewrite (f_equal_compose _ _ _ (from iso) (fun b => to iso (from iso b))) in H1. 154 | apply whisker_left in H1. 155 | assumption. 156 | Qed. 157 | 158 | (** Lemma 4.2.2 of HoTT *) 159 | Definition Sym {A B : Type} (iso : T A B) : T B A. 160 | Proof. refine( 161 | {| to := from iso 162 | ; from := to iso 163 | ; from_to := to_from iso 164 | ; to_from := from_to iso 165 | |}). 166 | apply lemma422. 167 | Qed. 168 | 169 | End Equiv. -------------------------------------------------------------------------------- /src/Types/List.v: -------------------------------------------------------------------------------- 1 | Require Import 2 | Coq.Lists.List 3 | CMorphisms. 4 | Import ListNotations. 5 | 6 | Set Universe Polymorphism. 7 | 8 | Inductive member {A} : A -> list A -> Type := 9 | | here : forall {x xs}, member x (x :: xs) 10 | | there : forall {x y ys}, member x ys -> member x (y :: ys). 11 | 12 | Lemma member_map {A B} (f : A -> B) {x : A} {xs : list A} 13 | (elem : member x xs) 14 | : member (f x) (List.map f xs). 15 | Proof. 16 | induction elem; simpl. constructor. constructor. assumption. 17 | Defined. 18 | 19 | Inductive EachI {A} {B : A -> Type} : list A -> Type := 20 | | EachI_nil : EachI nil 21 | | EachI_cons : forall {x : A} {xs : list A}, B x -> EachI xs -> EachI (x :: xs). 22 | 23 | Arguments EachI {A} B xs. 24 | 25 | Inductive SomeI {A} {B : A -> Type} : list A -> Type := 26 | | Some_here : forall {x xs}, B x -> SomeI (x :: xs) 27 | | Some_there : forall {x xs}, SomeI xs -> SomeI (x :: xs). 28 | 29 | Arguments SomeI {A} B xs. 30 | 31 | (** Remove one element from a list. *) 32 | Inductive Split {A} : list A -> A -> list A -> Type := 33 | | Split_here : forall {x xs}, Split (x :: xs) x xs 34 | | Split_there : forall {x xs y ys}, Split xs y ys -> Split (x :: xs) y (x :: ys). 35 | 36 | Ltac inv H := inversion H; clear H; subst. 37 | 38 | Definition swap_member {X : Type} {A B C : X} {Γ : list X} 39 | (x : member C (A :: B :: Γ)) 40 | : member C (B :: A :: Γ). 41 | Proof. 42 | inv x. apply there. apply here. 43 | inv X0. apply here. apply there. apply there. 44 | assumption. 45 | Defined. 46 | 47 | Definition Each {A} (B : A -> Type) (xs : list A) : Type := 48 | forall x, member x xs -> B x. 49 | 50 | Require Import Algebra.SetsC. 51 | Local Open Scope Subset. 52 | 53 | Lemma Each_member {A} {B : A -> Type} 54 | : Each B === EachI B. 55 | Proof. 56 | intros xs. 57 | split; intros H. 58 | - induction xs. 59 | + econstructor. 60 | + econstructor. apply H. econstructor. 61 | apply IHxs. unfold Each. 62 | intros. apply H. econstructor. assumption. 63 | - unfold Each; induction H; intros; inv X. 64 | + assumption. 65 | + apply IHEachI. assumption. 66 | Qed. 67 | 68 | Record LSome {A} {B : A -> Type} {xs : list A} : Type := 69 | MkLSome 70 | { S_elem : A 71 | ; S_member : member S_elem xs 72 | ; S_holds : B S_elem 73 | }. 74 | 75 | Arguments LSome {A} B xs. 76 | 77 | Lemma Some_member {A} {B : A -> Type} 78 | : LSome B === SomeI B. 79 | Proof. 80 | intros xs. 81 | split; intros H. 82 | - induction H. induction S_member0. 83 | + econstructor. assumption. 84 | + econstructor 2. auto. 85 | - induction H. 86 | + econstructor. econstructor. assumption. 87 | + induction IHSomeI. econstructor. 88 | econstructor 2. eassumption. assumption. 89 | Qed. 90 | 91 | Lemma member_rect1 : 92 | forall (A : Type) (P : forall (a : A) (b : A) (l : list A), member a (b :: l) -> Type), 93 | (forall (x : A) (xs : list A), P x x xs here) -> 94 | (forall (x y b : A) (ys : list A) (m : member x (b :: ys)), 95 | P x b ys m -> P x y (b :: ys) (there m)) -> 96 | forall (y : A) (b : A) (l : list A) (m : member y (b :: l)), P y b l m. 97 | Proof. 98 | intros A P X X0. 99 | pose (fun l : list A => match l as ll return forall (a : A), member a ll -> Type with 100 | | [] => fun a mem => False 101 | | x :: xs => fun a => P a x xs 102 | end) as P'. 103 | assert (forall l a mem, P' l a mem). 104 | intros. 105 | induction mem. 106 | - simpl. auto. 107 | - simpl. destruct ys. simpl in *. contradiction. 108 | apply X0. simpl in IHmem. assumption. 109 | - intros. apply (X1 (b :: l) y m). 110 | Defined. 111 | 112 | Require Import CMorphisms. 113 | 114 | Lemma member_app {A} {xs ys : list A} {x : A} : 115 | iffT (member x (xs ++ ys)) (member x xs + member x ys). 116 | Proof. 117 | split; intros. 118 | - induction xs. 119 | + right. apply X. 120 | + inv X. left. apply here. 121 | destruct (IHxs X0). left. apply there. assumption. 122 | right. assumption. 123 | - induction xs. 124 | + destruct X. inv m. assumption. 125 | + inv X. inv X0. apply here. 126 | simpl. apply there. apply IHxs. left. assumption. 127 | simpl. apply there. apply IHxs. right. assumption. 128 | Qed. 129 | 130 | Definition FSubset {A} (xs ys : list A) : Type := 131 | forall a : A, member a xs -> member a ys. 132 | 133 | Definition FSameset {A} (xs ys : list A) : Type := 134 | forall a : A, iffT (member a xs) (member a ys). 135 | 136 | Instance FSubset_PreOrder {A} : PreOrder (@FSubset A). 137 | Proof. 138 | firstorder. 139 | Qed. 140 | 141 | Instance FSameset_Equivalence {A} : Equivalence (@FSameset A). 142 | Proof. 143 | firstorder. 144 | Qed. 145 | 146 | Delimit Scope list_scope with list. 147 | Local Open Scope list. 148 | 149 | Infix "⊆" := FSubset (at level 60) : list_scope. 150 | Infix "===" := FSameset (at level 70) : list_scope. 151 | 152 | Lemma FSameset_FSubset {A} (xs ys : list A) : 153 | xs === ys -> ((xs ⊆ ys) * (ys ⊆ xs)). 154 | Proof. 155 | firstorder. 156 | Qed. 157 | 158 | Lemma FSubset_FSameset {A} (xs ys : list A) : 159 | xs ⊆ ys -> ys ⊆ xs -> xs === ys. 160 | Proof. 161 | firstorder. 162 | Qed. 163 | 164 | Lemma FSubset_cons {A} (x : A) (xs ys : list A) 165 | : xs ⊆ ys -> (x :: xs) ⊆ (x :: ys). 166 | Proof. 167 | unfold FSubset. intros. inv X0. 168 | - econstructor. 169 | - econstructor 2. auto. 170 | Qed. 171 | 172 | Lemma FSubset_nil {A} (xs : list A) 173 | : [] ⊆ xs. 174 | Proof. 175 | unfold FSubset. intros. inv X. 176 | Qed. 177 | 178 | Lemma LSome_app {A} {B : A -> Type} {xs ys : list A} 179 | : LSome B (xs ++ ys) <--> LSome B xs + LSome B ys. 180 | Proof. 181 | split; intros H. 182 | - induction H. apply member_app in S_member0. 183 | induction S_member0; [left | right]; econstructor; eassumption. 184 | - induction H. 185 | + induction a. econstructor. 186 | eapply member_app. left. eassumption. assumption. 187 | + induction b. econstructor. 188 | eapply member_app. right. eassumption. eassumption. 189 | Qed. 190 | 191 | Lemma member_singleton {A} (x y : A) 192 | : member x [y] <--> x = y. 193 | Proof. 194 | split; intros H. 195 | - inv H. reflexivity. inv X. 196 | - subst. econstructor. 197 | Qed. 198 | 199 | Lemma FSubset_app_l {T} (x y : list T) 200 | : (x ⊆ (x ++ y))%list. 201 | Proof. 202 | unfold FSubset. intros. apply member_app. 203 | left. assumption. 204 | Qed. 205 | 206 | Lemma FSubset_app_r {T} (x y : list T) 207 | : (y ⊆ (x ++ y))%list. 208 | Proof. 209 | unfold FSubset. intros. apply member_app. 210 | right. assumption. 211 | Qed. 212 | 213 | Lemma Each_app {T} {B : T -> Type} (xs ys : list T) 214 | : Each B xs * Each B ys <--> Each B (xs ++ ys). 215 | Proof. 216 | split; intros H. 217 | - destruct H. intros x mem. apply member_app in mem. 218 | destruct mem; auto. 219 | - split; intros x mem; apply H; apply member_app; auto. 220 | Qed. 221 | 222 | Lemma Each_singleton {T} {B : T -> Type} (x : T) 223 | : B x -> Each B [x]. 224 | Proof. 225 | intros H y mem. inv mem. assumption. inv X. 226 | Qed. 227 | 228 | Lemma Each_nil {T} {B : T -> Type} : Each B []. 229 | Proof. 230 | apply Each_member. constructor. 231 | Qed. 232 | 233 | Lemma Each_cons {T} {B : T -> Type} {x : T} 234 | {xs : list T} (Bx : B x) (Bxs : Each B xs) 235 | : Each B (x :: xs). 236 | Proof. 237 | intros y mem. inv mem; auto. 238 | Qed. -------------------------------------------------------------------------------- /src/Types/Setoid.v: -------------------------------------------------------------------------------- 1 | Set Universe Polymorphism. 2 | Set Asymmetric Patterns. 3 | 4 | Require Import 5 | CMorphisms 6 | Coq.Classes.RelationClasses 7 | Coq.Classes.CRelationClasses 8 | Prob.StdLib. 9 | Record Setoid := 10 | { sty :> Type 11 | ; seq : forall (A B : sty), Type 12 | ; seq_Equivalence : Equivalence seq 13 | }. 14 | 15 | Infix "==" := (seq _) (at level 70, no associativity) : Setoid_scope. 16 | Notation "a ==[ X ] b" := (seq X a b) (at level 70, format "a ==[ X ] b") : Setoid_scope. 17 | Delimit Scope Setoid_scope with setoid. 18 | Local Open Scope setoid. 19 | Delimit Scope SetoidC_scope with setoidc. 20 | Local Open Scope setoidc. 21 | 22 | Instance setoid_Equivalence (s : Setoid) : Equivalence (seq s). 23 | Proof. 24 | apply seq_Equivalence. 25 | Qed. 26 | 27 | Definition unit_Setoid@{i P} : Setoid@{i P}. 28 | Proof. 29 | refine ( 30 | {| sty := Datatypes.unit 31 | ; seq := fun _ _ => True 32 | |}). 33 | constructor; unfold Reflexive, Symmetric, Transitive; auto. 34 | Defined. 35 | 36 | Definition prod_Setoid@{i P} (A B : Setoid@{i P}) : Setoid@{i P}. 37 | Proof. 38 | refine ( 39 | {| sty := (sty A * sty B)%type 40 | ; seq := fun f f' => (seq A (fst f) (fst f') 41 | * seq B (snd f) (snd f'))%type 42 | |}). 43 | constructor; unfold Reflexive, Symmetric, Transitive; 44 | intros. 45 | - split; reflexivity. 46 | - destruct X; split; symmetry; assumption. 47 | - destruct X, X0; split; etransitivity; eassumption. 48 | Defined. 49 | 50 | Record function_car@{i P} (A B : Setoid@{i P}) := 51 | { sf :> A -> B 52 | ; sf_proper : forall a a', a == a' -> sf a == sf a' 53 | }. 54 | 55 | Instance function_Proper {A B} (f : function_car A B) : 56 | Proper (seq _ ==> seq _) f. 57 | Proof. 58 | unfold Proper, respectful. intros. 59 | apply sf_proper. assumption. 60 | Qed. 61 | 62 | Require Coq.Setoids.Setoid. 63 | Definition function@{A P} (A B : Setoid@{A P}) : Setoid@{A P}. 64 | Proof. 65 | unshelve eapply 66 | {| sty := function_car A B 67 | ; seq := fun f g => forall a a', a == a' -> f a == g a' 68 | |}. 69 | constructor; unfold Reflexive, Symmetric, Transitive; 70 | simpl; intros. 71 | - apply sf_proper. assumption. 72 | - symmetry. apply X. symmetry. assumption. 73 | - etransitivity. eapply X. eassumption. 74 | apply X0. reflexivity. 75 | Defined. 76 | 77 | Infix "~~>" := (function) (at level 75) : SetoidC_scope. 78 | 79 | Definition id {A : Setoid} : A ~~> A. 80 | Proof. 81 | unshelve econstructor. 82 | - auto. 83 | - simpl. auto. 84 | Defined. 85 | 86 | Definition compose {A B C : Setoid} (g : B ~~> C) 87 | (f : A ~~> B) : A ~~> C. 88 | Proof. 89 | unshelve econstructor. 90 | - intros. apply g. apply f. assumption. 91 | - simpl. intros. repeat apply sf_proper. assumption. 92 | Defined. 93 | 94 | Infix "∘" := (compose) (at level 40, left associativity) : SetoidC_scope. 95 | 96 | Record Iso@{i P} {A B : Setoid@{i P}} : Type := 97 | { to : A ~~> B 98 | ; from : B ~~> A 99 | ; to_from : forall a, to (from a) == a 100 | ; from_to : forall b, from (to b) == b 101 | }. 102 | 103 | Arguments Iso : clear implicits. 104 | 105 | Infix "≅" := Iso (at level 70, no associativity) : SetoidC_scope. 106 | 107 | Lemma Iso_Refl A : A ≅ A. 108 | Proof. 109 | refine ( 110 | {| to := id 111 | ; from := id 112 | |} 113 | ); intros; (reflexivity || assumption). 114 | Defined. 115 | 116 | Lemma Iso_Sym {A B : Setoid} (i : A ≅ B) : B ≅ A. 117 | Proof. 118 | refine ( 119 | {| to := from i 120 | ; from := to i 121 | |} 122 | ); intros. 123 | - apply from_to. 124 | - apply to_from. 125 | Defined. 126 | 127 | Require Coq.Setoids.Setoid. 128 | 129 | Lemma Iso_Trans@{i P} {A B C : Setoid@{i P}} (ab : A ≅ B) (bc : B ≅ C) 130 | : A ≅ C. 131 | Proof. 132 | refine ( 133 | {| to := to bc ∘ to ab 134 | ; from := from ab ∘ from bc 135 | |}); intros. 136 | - etransitivity. simpl. apply sf_proper. 137 | apply (to_from ab). apply (to_from bc). 138 | - etransitivity. simpl. apply sf_proper. 139 | apply (from_to bc). apply (from_to ab). 140 | Defined. 141 | 142 | Local Instance Iso_Equivalence : Equivalence Iso. 143 | Proof. 144 | constructor; unfold Reflexive, Transitive, Symmetric; intros. 145 | apply Iso_Refl. apply Iso_Sym. assumption. 146 | eapply Iso_Trans; eassumption. 147 | Defined. 148 | 149 | Module Leib. 150 | 151 | (* 152 | Inductive eq {A} {x : A} : A -> Type := 153 | | eq_refl : eq x. 154 | 155 | Arguments eq {A} x y. 156 | *) 157 | 158 | Definition Leibniz (A : Type) : Setoid. 159 | Proof. 160 | unshelve eapply ( 161 | {| sty := A 162 | ; seq := eq |}). 163 | Defined. 164 | 165 | Definition Leibniz_func {A B} (f : A -> B) 166 | : Leibniz A ~~> Leibniz B. 167 | Proof. 168 | unshelve econstructor. 169 | - simpl. assumption. 170 | - simpl. intros. f_equal. assumption. 171 | Defined. 172 | 173 | End Leib. -------------------------------------------------------------------------------- /src/Types/UIP.v: -------------------------------------------------------------------------------- 1 | Require Import 2 | Prob.StdLib 3 | Eqdep_dec. 4 | 5 | Set Universe Polymorphism. 6 | 7 | Lemma UIP_eq_dep_eq {A} : 8 | EqdepFacts.UIP_ A -> EqdepFacts.Eq_dep_eq A. 9 | Proof. 10 | intros H. apply EqdepFacts.eq_rect_eq__eq_dep_eq. 11 | apply EqdepFacts.Streicher_K__eq_rect_eq. 12 | apply EqdepFacts.UIP_refl__Streicher_K. 13 | apply EqdepFacts.UIP__UIP_refl. assumption. 14 | Qed. 15 | 16 | Lemma UIP_inj_dep_pair {A} : 17 | EqdepFacts.UIP_ A -> EqdepFacts.Inj_dep_pair A. 18 | Proof. 19 | intros H. apply EqdepFacts.eq_dep_eq__inj_pair2. 20 | apply UIP_eq_dep_eq. assumption. 21 | Qed. 22 | 23 | Ltac UIP_clean := match goal with 24 | | [ H : existT _ _ ?x = existT _ _ ?x |- _ ] => clear H 25 | | [ H : existT _ _ ?x = existT _ _ ?y |- _ ] => 26 | apply UIP_inj_dep_pair in H; [| solve[auto] ]; subst 27 | end. 28 | 29 | Ltac UIP_inv H := inv H; repeat UIP_clean. -------------------------------------------------------------------------------- /src/clement/SmallPowers.v: -------------------------------------------------------------------------------- 1 | Require Import Coq.QArith.Qcanon Coq.QArith.QArith_base Coq.QArith.Qring. 2 | Open Scope Q_scope. 3 | Require Import Coq.micromega.Psatz. 4 | 5 | Lemma Qlt_inverse_iff : 6 | forall a b, 7 | 0 < a -> 8 | 0 < b -> 9 | (/ a < / b <-> b < a). 10 | Proof. 11 | intros. 12 | rewrite <- (Qmult_lt_l _ _ a) by assumption. 13 | rewrite <- (Qmult_lt_r _ _ b) by assumption. 14 | rewrite Qmult_inv_r, Qmult_1_l by (destruct a as ([ | ? | ?] & ?); discriminate). 15 | rewrite <- Qmult_assoc, (Qmult_comm _ b). 16 | rewrite Qmult_inv_r, Qmult_1_r by (destruct b as ([ | ? | ?] & ?); discriminate). 17 | reflexivity. 18 | Qed. 19 | 20 | Require Import Qpower. 21 | 22 | Lemma power_more_than_linear_util: 23 | forall (q a : Q) (n : nat), 24 | 0 < q -> 25 | 0 < a -> 26 | a <= a * (1 + q) ^ Z.of_nat n. 27 | Proof. 28 | intros; induction n. 29 | - simpl; rewrite Qmult_1_r; apply Qle_refl. 30 | - rewrite Nat2Z.inj_succ, <- Z.add_1_l, Qpower_plus by lra; simpl. 31 | eapply Qle_trans; eauto. 32 | rewrite Qmult_assoc. 33 | apply Qmult_le_compat_r. 34 | + rewrite <- Qmult_1_r, Qmult_le_l at 1; lra. 35 | + apply Qpower_pos; lra. 36 | Qed. 37 | 38 | Lemma power_more_than_linear (q: Q): 39 | 0 < q -> 40 | forall n : nat, 41 | 1 + q * (inject_Z (Z.of_nat n)) <= (1 + q) ^ (Z.of_nat n). 42 | Proof. 43 | intros. 44 | induction n. 45 | - unfold inject_Z. 46 | ring_simplify; simpl; compute; intro; discriminate. 47 | - rewrite Nat2Z.inj_succ, <- Z.add_1_l, inject_Z_plus, Qmult_plus_distr_r, Qpower_plus, Qmult_1_r by lra. 48 | simpl. 49 | rewrite Qmult_plus_distr_l, Qmult_1_l. 50 | rewrite Qplus_assoc, (Qplus_comm 1 _) , <- Qplus_assoc, Qplus_comm at 1. 51 | apply Qplus_le_compat. 52 | + assumption. 53 | + apply power_more_than_linear_util; eauto. 54 | Qed. 55 | 56 | Lemma power_large_util'' : 57 | forall b a, (b > 0 -> exists n, a < S n * b)%nat. 58 | Proof. 59 | intros; exists a; induction a; simpl in *; omega. 60 | Qed. 61 | 62 | Lemma power_large_util' (q epsilon: Q): 63 | 0 < q -> 64 | 0 < epsilon -> 65 | exists n : nat, epsilon < q * (inject_Z (Z.of_nat n)). 66 | Proof. 67 | intros. 68 | destruct q as ([ | qn | qn ] & qd), epsilon as ([ | epsilonn | epsilonn ] & epsilond); simpl in *; try discriminate. 69 | edestruct (power_large_util'' (Pos.to_nat (qn * epsilond))) as [ n h ]. 70 | - apply Pos2Nat.is_pos. 71 | - eexists (S n). 72 | rewrite <- (Qmult_lt_l _ _ (/ (' qn # qd))), Qmult_assoc, (Qmult_comm _ (' qn # qd)), Qmult_inv_r, Qmult_1_l. 73 | unfold Qlt, Qinv in *; simpl in *; unfold Z.lt. 74 | rewrite <- Pos2Z.inj_compare, Pos2Nat.inj_compare, <- nat_compare_lt, !Pos2Nat.inj_mul, SuccNat2Pos.id_succ, <- !Pos2Nat.inj_mul. 75 | eassumption. 76 | lra. reflexivity. 77 | Qed. 78 | 79 | Lemma power_large_util (q epsilon: Q): 80 | 0 < q -> 81 | 0 < epsilon -> 82 | exists n : nat, epsilon < 1 + q * (inject_Z (Z.of_nat n)). 83 | Proof. 84 | intros. 85 | edestruct (power_large_util' q epsilon) as [n h]; try eassumption. 86 | exists n; eapply Qlt_le_trans with (q * inject_Z (Z.of_nat n)); try lra. 87 | Qed. 88 | 89 | Lemma power_large (q epsilon: Q): 90 | (1 < q -> 91 | 0 < epsilon -> 92 | exists n : nat, epsilon < q ^ (Z.of_nat n))%Q. 93 | Proof. 94 | intros. 95 | destruct (power_large_util (q - 1) epsilon) as [n h]; try lra. 96 | exists n. 97 | eapply Qlt_le_trans; eauto. 98 | remember (q - 1) as q'; 99 | setoid_replace q with (1 + (q - 1)) using relation Qeq; subst. 100 | apply power_more_than_linear; lra. 101 | ring. 102 | Qed. 103 | 104 | Lemma Qpower_pos_lt: 105 | forall (q : Q) (n : nat), 0 < q -> 0 < q ^ Z.of_nat n. 106 | Proof. 107 | intros; induction n. 108 | - simpl; lra. 109 | - rewrite Nat2Z.inj_succ, <- Z.add_1_l, Qpower_plus by lra. 110 | erewrite <- Qmult_lt_l, Qmult_0_r in IHn; eassumption. 111 | Qed. 112 | 113 | Lemma Qpower_inv: 114 | forall (q : Q) (n : nat), 115 | 0 < q -> 116 | (/ q) ^ Z.of_nat n == / q ^ Z.of_nat n. 117 | Proof. 118 | intros; induction n. 119 | - reflexivity. 120 | - rewrite Nat2Z.inj_succ, <- Z.add_1_l. 121 | setoid_rewrite (Qpower_plus (/ q)). 122 | setoid_rewrite IHn. 123 | change ((/ q) ^ 1) with (/ q). 124 | rewrite <- Qinv_mult_distr. 125 | setoid_rewrite (Qpower_plus q); try lra. 126 | reflexivity. 127 | apply Qinv_lt_0_compat in H; lra. 128 | Qed. 129 | 130 | Lemma power_small_Q (q epsilon: Q): 131 | 0 < q -> 132 | q < 1 -> 133 | 0 < epsilon -> 134 | exists n : nat, q ^ (Z.of_nat n) < epsilon. 135 | Proof. 136 | intros qNonZero qSmall epsilonNonZero. 137 | destruct (power_large (/ q) (/ epsilon)) as [n h]. 138 | - replace 1 with (/ 1) by reflexivity. 139 | rewrite Qlt_inverse_iff; lra. 140 | - eauto using Qinv_lt_0_compat. 141 | - exists n. 142 | setoid_replace ((/ q) ^ Z.of_nat n) with (/ q ^ (Z.of_nat n)) using relation Qeq in h. 143 | rewrite <- Qlt_inverse_iff; try lra. 144 | apply Qpower_pos_lt; lra. 145 | apply Qpower_inv; lra. 146 | Qed. 147 | 148 | Open Scope Qc_scope. 149 | 150 | Lemma Qcpower_Qpower: 151 | forall (q : Qc), 152 | 0 < q -> 153 | forall (n : nat), (q ^ n)%Qc == q ^ Z.of_nat n. 154 | Proof. 155 | intros. 156 | induction n. 157 | - reflexivity. 158 | - rewrite Nat2Z.inj_succ, <- Z.add_1_l, Qpower_plus. 159 | simpl Qcpower. 160 | unfold Qcmult. 161 | change (this (Q2Qc (q * (q ^ n)%Qc))) with (Qreduction.Qred (q * (q ^ n)%Qc)). 162 | setoid_rewrite Qreduction.Qred_correct. 163 | setoid_rewrite IHn. 164 | reflexivity. 165 | rewrite Qeq_alt. 166 | unfold Qclt in H; simpl in H; rewrite Qgt_alt in H. 167 | intro; congruence. 168 | Qed. 169 | 170 | Lemma power_small' (q epsilon: Qc): 171 | 0 < q -> 172 | q < 1 -> 173 | 0 < epsilon -> 174 | exists n : nat, q ^ n < epsilon. 175 | Proof. 176 | intros. 177 | destruct (power_small_Q q epsilon) as [n h]; try eassumption. 178 | eexists n. unfold Qclt. 179 | setoid_rewrite Qcpower_Qpower; eassumption. 180 | Qed. 181 | 182 | Lemma power_small (q epsilon: Qc): 183 | 0 <= q -> 184 | q < 1 -> 185 | 0 < epsilon -> 186 | exists n : nat, q ^ n < epsilon. 187 | Proof. 188 | intros h **. 189 | destruct (Qle_lt_or_eq _ _ h) as [ h' | h' ]. 190 | - apply power_small'; eassumption. 191 | - exists 1%nat. unfold Qclt. 192 | replace (q ^ 1) with q by (simpl; rewrite Qcmult_1_r; reflexivity). 193 | setoid_rewrite <- h'; assumption. 194 | Qed. --------------------------------------------------------------------------------