├── .gitignore ├── .project ├── LICENSE ├── Notes ├── SStodo9_2016.jpg ├── dependency_graph.jpg ├── known_bugs.txt ├── lessons.md ├── macros.tex ├── notes.tex ├── preamble-articles.tex ├── smash.tex └── sss.tex ├── README.md ├── algebra ├── arrow_group.hlean ├── cogroup.hlean ├── direct_sum.hlean ├── exact_couple.hlean ├── exact_couple_old.hlean ├── exactness.hlean ├── free_abelian_group.hlean ├── free_group.hlean ├── graded.hlean ├── left_module.hlean ├── module_chain_complex.hlean ├── product_group.hlean ├── quotient_group.hlean ├── ring.hlean ├── seq_colim.hlean ├── ses.hlean ├── short_five.hlean ├── spectral_sequence.hlean ├── splice.hlean ├── subgroup.hlean ├── submodule.hlean └── tensor.hlean ├── archive ├── smash_assoc.hlean └── smash_old.hlean ├── choice.hlean ├── cohomology ├── basic.hlean ├── cofiber_sequence.hlean ├── gysin.hlean ├── projective_space.hlean └── serre.hlean ├── coind_colim.hlean ├── colimit ├── README.md ├── local_ext.hlean ├── omega_compact.hlean ├── omega_compact_sum.hlean ├── pointed.hlean ├── pushout.hlean ├── seq_colim.hlean └── sequence.hlean ├── component.hlean ├── heq.hlean ├── higher_groups.hlean ├── homology ├── basic.hlean ├── sphere.hlean └── torus.hlean ├── homotopy ├── EM.hlean ├── EMRing.hlean ├── degree.hlean ├── dsmash.hlean ├── fwedge.hlean ├── join_theorem.hlean ├── pushout.hlean ├── realprojective.hlean ├── smash.hlean ├── smash_adjoint.hlean ├── spherical_fibrations.hlean ├── susp.hlean ├── susp_product.hlean ├── susp_pset.hlean ├── three_by_three.hlean └── wedge.hlean ├── logic.hlean ├── move_to_lib.hlean ├── pointed.hlean ├── pointed_binary.hlean ├── pointed_cubes.hlean ├── pointed_pi.hlean ├── property.hlean ├── pyoneda.hlean ├── spectrum ├── basic.hlean ├── smash.hlean ├── spectrification.hlean └── trunc.hlean └── univalent_subcategory.hlean /.gitignore: -------------------------------------------------------------------------------- 1 | *~ 2 | .lean_trace 3 | *.produced.out 4 | *.md.lua 5 | *.md.lean 6 | *.olean 7 | *.clean 8 | *.ilean 9 | *.d 10 | a.out 11 | build 12 | GPATH 13 | GRTAGS 14 | GSYMS 15 | GTAGS 16 | TAGS 17 | Makefile 18 | *.cmake 19 | CMakeFiles/ 20 | .projectile 21 | .coveralls.yml 22 | .lean_options 23 | doc/html 24 | make.deps 25 | src/emacs/dependencies 26 | compile_commands.json 27 | .ninja_deps 28 | .ninja_log 29 | build.ninja 30 | 31 | ## Core latex/pdflatex auxiliary files: 32 | *.aux 33 | *.lof 34 | *.log 35 | *.lot 36 | *.fls 37 | *.out 38 | *.toc 39 | *.fmt 40 | *.fot 41 | *.cb 42 | *.cb2 43 | 44 | ## Intermediate documents: 45 | *.dvi 46 | *-converted-to.* 47 | # these rules might exclude image files for figures etc. 48 | # *.ps 49 | # *.eps 50 | *.pdf 51 | 52 | ## Generated if empty string is given at "Please type another file name for output:" 53 | .pdf 54 | 55 | ## Bibliography auxiliary files (bibtex/biblatex/biber): 56 | *.bbl 57 | *.bcf 58 | *.blg 59 | *-blx.aux 60 | *-blx.bib 61 | *.run.xml 62 | 63 | ## Build tool auxiliary files: 64 | *.fdb_latexmk 65 | *.synctex 66 | *.synctex(busy) 67 | *.synctex.gz 68 | *.synctex.gz(busy) 69 | *.pdfsync 70 | 71 | ## Auxiliary and intermediate files from other packages: 72 | # algorithms 73 | *.alg 74 | *.loa 75 | 76 | # achemso 77 | acs-*.bib 78 | 79 | # amsthm 80 | *.thm 81 | 82 | # beamer 83 | *.nav 84 | *.pre 85 | *.snm 86 | *.vrb 87 | 88 | # changes 89 | *.soc 90 | 91 | # cprotect 92 | *.cpt 93 | 94 | # elsarticle (documentclass of Elsevier journals) 95 | *.spl 96 | 97 | # endnotes 98 | *.ent 99 | 100 | # fixme 101 | *.lox 102 | 103 | # feynmf/feynmp 104 | *.mf 105 | *.mp 106 | *.t[1-9] 107 | *.t[1-9][0-9] 108 | *.tfm 109 | 110 | #(r)(e)ledmac/(r)(e)ledpar 111 | *.end 112 | *.?end 113 | *.[1-9] 114 | *.[1-9][0-9] 115 | *.[1-9][0-9][0-9] 116 | *.[1-9]R 117 | *.[1-9][0-9]R 118 | *.[1-9][0-9][0-9]R 119 | *.eledsec[1-9] 120 | *.eledsec[1-9]R 121 | *.eledsec[1-9][0-9] 122 | *.eledsec[1-9][0-9]R 123 | *.eledsec[1-9][0-9][0-9] 124 | *.eledsec[1-9][0-9][0-9]R 125 | 126 | # glossaries 127 | *.acn 128 | *.acr 129 | *.glg 130 | *.glo 131 | *.gls 132 | *.glsdefs 133 | 134 | # gnuplottex 135 | *-gnuplottex-* 136 | 137 | # gregoriotex 138 | *.gaux 139 | *.gtex 140 | 141 | # hyperref 142 | *.brf 143 | 144 | # knitr 145 | *-concordance.tex 146 | # TODO Comment the next line if you want to keep your tikz graphics files 147 | *.tikz 148 | *-tikzDictionary 149 | 150 | # listings 151 | *.lol 152 | 153 | # makeidx 154 | *.idx 155 | *.ilg 156 | *.ind 157 | *.ist 158 | 159 | # minitoc 160 | *.maf 161 | *.mlf 162 | *.mlt 163 | *.mtc[0-9]* 164 | *.slf[0-9]* 165 | *.slt[0-9]* 166 | *.stc[0-9]* 167 | 168 | # minted 169 | _minted* 170 | *.pyg 171 | 172 | # morewrites 173 | *.mw 174 | 175 | # nomencl 176 | *.nlo 177 | 178 | # pax 179 | *.pax 180 | 181 | # sagetex 182 | *.sagetex.sage 183 | *.sagetex.py 184 | *.sagetex.scmd 185 | 186 | # scrwfile 187 | *.wrt 188 | 189 | # sympy 190 | *.sout 191 | *.sympy 192 | sympy-plots-for-*.tex/ 193 | 194 | # pdfcomment 195 | *.upa 196 | *.upb 197 | 198 | # pythontex 199 | *.pytxcode 200 | pythontex-files-*/ 201 | 202 | # thmtools 203 | *.loe 204 | 205 | # TikZ & PGF 206 | *.dpth 207 | *.md5 208 | *.auxlock 209 | 210 | # todonotes 211 | *.tdo 212 | 213 | # easy-todo 214 | *.lod 215 | 216 | # xindy 217 | *.xdy 218 | 219 | # xypic precompiled matrices 220 | *.xyc 221 | 222 | # endfloat 223 | *.ttt 224 | *.fff 225 | 226 | # Latexian 227 | TSWLatexianTemp* 228 | 229 | ## Editors: 230 | # WinEdt 231 | *.bak 232 | *.sav 233 | 234 | # Texpad 235 | .texpadtmp 236 | 237 | # Kile 238 | *.backup 239 | 240 | # KBibTeX 241 | *~[0-9]* 242 | 243 | # auto folder when using emacs and auctex 244 | /auto/* 245 | 246 | # expex forward references with \gathertags 247 | *-tags.tex 248 | -------------------------------------------------------------------------------- /.project: -------------------------------------------------------------------------------- 1 | # Lean project file 2 | 3 | # Include all .hlean files under this directory 4 | + *.hlean 5 | 6 | # Exclude flycheck generated temp files 7 | - flycheck*.hlean 8 | 9 | # Exclude emacs temp files 10 | - .#*.hlean -------------------------------------------------------------------------------- /Notes/SStodo9_2016.jpg: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/cmu-phil/Spectral/3b078f5f1de251637decf04bd3fc8aa01930a6b3/Notes/SStodo9_2016.jpg -------------------------------------------------------------------------------- /Notes/dependency_graph.jpg: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/cmu-phil/Spectral/3b078f5f1de251637decf04bd3fc8aa01930a6b3/Notes/dependency_graph.jpg -------------------------------------------------------------------------------- /Notes/known_bugs.txt: -------------------------------------------------------------------------------- 1 | A list of bugs and/or unintuitive behavior in Lean 2: 2 | 3 | - When using the "have" or "assert" tactic, no coercion is applied to the type. So you have to write for example 4 | `have g : Group.carrier G, from _,` 5 | instead of 6 | `have g : G, from _,` 7 | 8 | - coercions are still displayed by the pretty printer 9 | 10 | - When using the calc mode for homotopies, you have to give the proofs using a tactic (e.g. `by exact foo` instead of `foo`) 11 | 12 | - A file named "module.hlean" cannot be imported using `import .module` because `module` is a keyword (but it can be imported using `import ..foo.module`) 13 | 14 | Issues which are not bugs, but still good to know 15 | 16 | - once you start tactic mode, you cannot specify universe levels anymore 17 | 18 | - esimp is slow, and runs out of memory easily. It is good behavior to split up definitions. So instead of 19 | ``` 20 | equiv.MK (* big function *) 21 | (* big inverse *) 22 | (* long proof *) 23 | (* long proof *) 24 | ``` 25 | first write the functions f and g and then write 26 | ``` 27 | equiv.MK f 28 | g 29 | abstract (* long proof *) end 30 | abstract (* long proof *) end 31 | ``` 32 | this has the additional advantage that if f and/or g are defined using induction, they will only reduce if they are applied to arguments for which they actually reduce (assuming they have the correct [unfold n] flag. 33 | 34 | - unfold [foo] also does various (sometimes unwanted) reductions (as if you called esimp) 35 | 36 | - The Emacs flycheck mode has a hard time with nonrelative paths to files in the same directory. This means that for importing files from the Lean 2 HoTT library use absolute paths (e.g. `import algebra.group`) and for importing files in the Spectral repository use relative paths (e.g. for a file in the `homotopy` folder use `import ..algebra.subgroup`) 37 | 38 | - The induction tactic doesn't fail if it fails to solve the type class constraint. This means that it will accept the tactics until the end of the tactic proof, when it raises the error that the term has unsolved metavariables 39 | 40 | - Sometimes the lean-server doesn't give information anymore (and then it causes tab complete to hang). In this case, execute `M-x lean-server-restart-all-processes`. You can stop tab-complete from hanging by pressing `C-g` multiple times, once for each time you pressed TAB. 41 | -------------------------------------------------------------------------------- /Notes/lessons.md: -------------------------------------------------------------------------------- 1 | In this file I (Floris) will collect some lessons learned from building and working with a HoTT library. 2 | Some of these things still need to be changes, some of them are already changed, and some of them are not worth the effort to change. 3 | 4 | - Spheres should be indexed by ℕ, it is not worth the effort to start counting at -1 (pointed spheres are much more useful anyway). 5 | - I think the type `trunc_index` / `ℕ₋₂` is superfluous and `ℤ` should be used instead (defined so that `is_trunc n A`and `trunc n A is` constant for `n ≤ -2`). This saves defining operations and proving properties on an additional type, and it is useful when defining truncations / truncatedness for spectra, which are naturally indexed by `ℤ`. 6 | - Don't have both susp and psusp. psusp should be the default (otherwise there is a distinction between iterate susp and iterate psusp) 7 | - Pointed maps should be special cases of dependent pointed maps. Pointed homotopies (between dependent pointed maps) should be special cases of dependent pointed maps, and pointed homotopies should be related themselves by pointed homotopies. 8 | - Type classes don't work well together with bundled structures and coercions in Lean (the instance is_contr_unit will not unify with (is_contr punit). 9 | - Overloading doesn't work well in Lean (mostly by degrading error messages) 10 | - avoid rec_on, don't formulate induction principles using "on", the order of arguments is worse 11 | - squares of maps, pointed maps and similar objects should be defined with operations on them. Squares of maps should be a structure, because we don't want that `hsquare t b l r` is definitionally equal to `hsquare (r ∘ t) b l id`. 12 | - It is useful to do categorical properties more uniformly. Define a 1-coherent ∞-category, which is a precategory (or category?) where the homs are not assumed to be sets. Examples include 13 | + `Type` (with `→`), 14 | + `A → B` (with `~`), 15 | + `Type*` (with `→*`), 16 | + `A →* B` (with `~*`), 17 | + `A` (with `=`), 18 | + spectrum (with `→ₛ`) 19 | + ... 20 | You cannot formulate everything in this, but it would be useful to compose natural transformations (instead of composing functions and manually show naturality). 21 | Disadvantage: doesn't work for everything, at some point you have to resort to higher categorical reasoning. Also, it might be challenging to formulate things like functoriality of pi's and sigma's. 22 | - Type class inference for equivalences doesn't really work in Lean, since it recognizes that `f ∘ id` is definitionally `f`, hence it can always apply `is_equiv_compose` and get trapped in a loop. 23 | - Coercions should all be defined *immediately* after defining a structure, *before* declaring any 24 | instances. This is because the coercion graph is updated after each declared coercion. 25 | - When you have a functor in two arguments (`→`, `×`, `Π`, `Σ`, pointed versions of these, `=`, `∧`, 26 | `∨`, and so on), the functoriality should be stated in both arguments at once, and the special 27 | cases where only one argument changes should be a special case of that one. This makes it easier 28 | to prove properties about the functorial action, because you only have to do work once (although 29 | that work is sometimes twice as much, but sometimes much less). We haven't always done this, 30 | because it's sometimes easier to define a special case first (even though later you probably still 31 | have to define the general case). Note that for `=` this gives square filling as primitive, 32 | instead of concatenation (which can be seen as functoriality in the second argument), and Dan 33 | Licata argued for that as primitive instead of concatenation. On the other hand, the definition 34 | of the more general functor might be more complicated, in which case definitional reduction won't be as nice -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # Spectral Sequences in Homotopy Type Theory 2 | 3 | Formalization project of the CMU HoTT group to formalize the Serre spectral sequence in Lean 2. 4 | 5 | *Update July 16, 2017*: The construction of the Serre spectral sequence has been completed. The result is `serre_convergence` in `cohomology.serre`. 6 | The main algebra part is in `algebra.exact_couple`. 7 | 8 | This repository also contains: 9 | * a formalization of colimits which is in progress by Floris van Doorn, Egbert Rijke and Kristina Sojakova. 10 | * a formalization and notes (in progress) about the smash product by Floris van Doorn and Stefano Piceghello. 11 | * a formalization of *The real projective spaces in homotopy type theory*, Ulrik Buchholtz and Egbert Rijke, LICS 2017. 12 | * a formalization of *Higher Groups in Homotopy Type Theory*, Ulrik Buchholtz, Floris van Doorn, Egbert Rijke, LICS 2018. 13 | * the contents of the MRC 2017 group on formalizing homology in Lean. 14 | 15 | #### Participants 16 | Jeremy Avigad, Steve Awodey, Ulrik Buchholtz, Floris van Doorn, Clive Newstead, Egbert Rijke, Mike Shulman. 17 | 18 | ## Resources 19 | - [Mike's blog posts on ncatlab](https://ncatlab.org/homotopytypetheory/show/spectral+sequences). 20 | - The [Licata-Finster article](http://dlicata.web.wesleyan.edu/pubs/lf14em/lf14em.pdf) about Eilenberg-Mac Lane spaces. 21 | - We learned about the Serre spectral sequence from [Hatcher's chapter about spectral sequences](https://www.math.cornell.edu/~hatcher/SSAT/SSATpage.html). 22 | - Lang's algebra (revised 3rd edition) contains a chapter on general homology theory, with a section on spectral sequences. Thus, we can use this book at least as an outline for the algebraic part of the project. 23 | - Mac Lane's Homology contains a lot of homological algebra and a chapter on spectral sequences, including exact couples. 24 | 25 | ## Contents for Lean spectral sequences project 26 | 27 | ### Outline 28 | 29 | These projects are done 30 | 31 | - Given a sequence of spectra and maps, indexed over `ℤ`, we get an exact couple, indexed over `ℤ × ℤ`. 32 | - We can derive an exact couple. 33 | - If the exact couple is bounded, we repeat this process to get a convergent spectral sequence. 34 | - We construct the Atiyah-Hirzebruch and Serre spectral sequences for cohomology. 35 | 36 | ### Future directions 37 | - Hurewicz Theorem and Hurewicz theorem modulo a Serre class. There is a proof in Hatcher. Also, [this](http://www.math.uni-frankfurt.de/~johannso/SkriptAll/SkriptTopAlg/SkriptTopCW/homotop12.pdf) might be useful. 38 | - Homological Serre spectral sequence. 39 | - Interaction between steenrod squares and cup product with spectral sequences 40 | - ... 41 | 42 | ### Algebra 43 | 44 | #### To do 45 | - Constructions: tensor, hom, projective, Tor (at least on groups) 46 | - Finite groups, Finitely generated groups, torsion groups 47 | - Serre classes 48 | - [vector spaces](http://ncatlab.org/nlab/show/vector+space), 49 | 50 | #### In Progress 51 | 52 | 53 | #### Done 54 | - groups, rings, fields, [R-modules](http://ncatlab.org/nlab/show/module), graded R-modules. 55 | - Constructions on groups and abelian groups:: subgroup, quotient, product, free groups. 56 | - Constructions on ablian groups: direct sum, sequential colimi. 57 | - exact sequences, short and long. 58 | - [chain complexes](http://ncatlab.org/nlab/show/chain+complex) and [homology](http://ncatlab.org/nlab/show/homology). 59 | - [exact couples](http://ncatlab.org/nlab/show/exact+couple) graded over an arbitrary indexing set. 60 | - spectral sequence of an exact couple. 61 | - [convergence of spectral sequences](http://ncatlab.org/nlab/show/spectral+sequence#ConvergenceOfSpectralSequences). 62 | 63 | ### Topology 64 | 65 | #### To do 66 | - cofiber sequences 67 | + Hom'ing out gives a fiber sequence: if `A → B → coker f` cofiber 68 | sequences, then `X^A → X^B → X^(coker f)` is a fiber sequence. 69 | - fiber and cofiber sequences of spectra, stability 70 | + limits are levelwise 71 | + colimits need to be spectrified 72 | - long exact sequence from cofiber sequences of spectra 73 | + indexed on ℤ, need to splice together LES's 74 | - Parametrized and unreduced homology 75 | - Cup product on cohomology groups 76 | - Show that the spectral sequence respect the cup product structure of cohomology 77 | - Steenrod squares 78 | - ... 79 | 80 | #### To do (short-term easy projects) 81 | 82 | - Compute cohomology groups of `K(ℤ, n)` 83 | - Compute cohomology groups of `ΩSⁿ` 84 | - Show that all fibration sequences between spheres are of the form `Sⁿ → S²ⁿ⁺¹ → Sⁿ⁺¹`. 85 | - Compute fiber of `K(φ, n)` for group hom `φ` in general and if it's injective/surjective 86 | - [Steve] Prove `Σ (X × Y) ≃* Σ X ∨ Σ Y ∨ Σ (X ∧ Y)`, where `Σ` is suspension. See `homotopy.susp_product` 87 | 88 | #### In Progress 89 | - [prespectra](http://ncatlab.org/nlab/show/spectrum+object) and [spectra](http://ncatlab.org/nlab/show/spectrum), indexed over an arbitrary type with a successor 90 | + think about equivariant spectra indexed by representations of `G` 91 | - [spectrification](http://ncatlab.org/nlab/show/higher+inductive+type#spectrification) 92 | + adjoint to forgetful 93 | + as sequential colimit, prove induction principle 94 | + connective spectrum: `is_conn n.-2 Eₙ` 95 | - Postnikov towers of spectra. 96 | + basic definition already there 97 | + fibers of Postnikov sequence unstably and stably 98 | - [parametrized spectra](http://ncatlab.org/nlab/show/parametrized+spectrum), parametrized smash and hom between types and spectra. 99 | - Check Eilenberg-Steenrod axioms for reduced homology. 100 | 101 | 102 | #### Done 103 | - Most things in the HoTT Book up to Section 8.9 (see [this file](https://github.com/leanprover/lean2/blob/master/hott/book.md)) 104 | - pointed types, maps, homotopies and equivalences 105 | - [Eilenberg-MacLane spaces](http://ncatlab.org/nlab/show/Eilenberg-Mac+Lane+space) and EM-spectrum 106 | - fiber sequence 107 | + already have the LES 108 | + need shift isomorphism 109 | + Hom'ing into a fiber sequence gives another fiber sequence. 110 | - long exact sequence of homotopy groups of spectra, indexed on ℤ 111 | - exact couple of a tower of spectra 112 | + need to splice together LES's 113 | 114 | ## Usage and Contributing 115 | - To compile this repository you can run `linja` (or `path/to/lean2/bin/linja`) in the main directory. 116 | + You will need a working version of Lean 2. Installation instructions for Lean 2 can be found [here](https://github.com/leanprover/lean2). 117 | + We will try to make sure that this repository compiles with the newest version of Lean 2. 118 | - The preferred editor for Lean 2 is Emacs. Notes on the Emacs mode can be found [here](https://github.com/leanprover/lean2/blob/master/src/emacs/README.md) (for example if some unicode characters don't show up, or increase the spacing between lines by a lot). 119 | - We try to separate the repository into the folders `algebra`, `homotopy`, `homology`, `cohomology`, `spectrum` and `colimit`. Homotopy theotic properties of types which do not explicitly mention homotopy, homology or cohomology groups (such as `A ∧ B ≃* B ∧ A`) are part of `homotopy`. 120 | - If you contribute, please use rebase instead of merge (e.g. `git pull -r`). 121 | -------------------------------------------------------------------------------- /algebra/cogroup.hlean: -------------------------------------------------------------------------------- 1 | import algebra.group_theory ..pointed ..homotopy.smash 2 | 3 | open eq pointed algebra group eq equiv is_trunc is_conn prod prod.ops 4 | smash susp unit pushout trunc prod 5 | 6 | section 7 | variables {A B C : Type*} 8 | 9 | definition prod.pair_pmap (f : C →* A) (g : C →* B) 10 | : C →* A ×* B := 11 | pmap.mk (λ c, (f c, g c)) (pair_eq (respect_pt f) (respect_pt g)) 12 | 13 | -- ×* is the product in Type* 14 | definition pmap_prod_equiv : (C →* A ×* B) ≃ (C →* A) × (C →* B) := 15 | begin 16 | apply equiv.MK (λ f, (ppr1 ∘* f, ppr2 ∘* f)) 17 | (λ w, prod.elim w prod.pair_pmap), 18 | { intro p, induction p with f g, apply pair_eq, 19 | { apply eq_of_phomotopy, fapply phomotopy.mk, 20 | { intro x, reflexivity }, 21 | { symmetry, apply trans (prod_eq_pr1 (respect_pt f) (respect_pt g)), 22 | apply inverse, apply idp_con } }, 23 | { apply eq_of_phomotopy, fapply phomotopy.mk, 24 | { intro x, reflexivity }, 25 | { symmetry, apply trans (prod_eq_pr2 (respect_pt f) (respect_pt g)), 26 | apply inverse, apply idp_con } } }, 27 | { intro f, apply eq_of_phomotopy, fapply phomotopy.mk, 28 | { intro x, apply prod.eta }, 29 | { symmetry, exact prod.pair_eq_eta (respect_pt f) } } 30 | end 31 | 32 | -- since ~* is the identity type of pointed maps, 33 | -- the following follows by univalence, but we give a direct proof 34 | -- if we really have to, we could prove the uncurried version 35 | -- is an equivalence, but it's a pain without eta for products 36 | definition pair_phomotopy {f g : C →* A ×* B} 37 | (h : ppr1 ∘* f ~* ppr1 ∘* g) (k : ppr2 ∘* f ~* ppr2 ∘* g) 38 | : f ~* g := 39 | phomotopy.mk (λ x, prod_eq (h x) (k x)) 40 | begin 41 | apply prod.prod_eq_assemble, 42 | { esimp, rewrite [prod.eq_pr1_concat,prod_eq_pr1], 43 | exact to_homotopy_pt h }, 44 | { esimp, rewrite [prod.eq_pr2_concat,prod_eq_pr2], 45 | exact to_homotopy_pt k } 46 | end 47 | 48 | end 49 | 50 | -- should be in wedge 51 | definition or_of_wedge {A B : Type*} (w : wedge A B) 52 | : trunc.or (Σ a, w = inl a) (Σ b, w = inr b) := 53 | begin 54 | induction w with a b, 55 | { exact trunc.tr (sum.inl (sigma.mk a idp)) }, 56 | { exact trunc.tr (sum.inr (sigma.mk b idp)) }, 57 | { apply is_prop.elimo } 58 | end 59 | 60 | namespace group -- is this the correct namespace? 61 | 62 | -- TODO: modify h_space to match 63 | 64 | -- TODO: move these to appropriate places 65 | definition pdiag (A : Type*) : A →* (A ×* A) := 66 | pmap.mk (λ a, (a, a)) idp 67 | 68 | section prod 69 | variables (A B : Type*) 70 | 71 | definition wpr1 (A B : Type*) : (A ∨ B) →* A := 72 | pmap.mk (wedge.elim (pid A) (pconst B A) idp) idp 73 | 74 | definition wpr2 (A B : Type*) : (A ∨ B) →* B := 75 | pmap.mk (wedge.elim (pconst A B) (pid B) idp) idp 76 | 77 | definition ppr1_pprod_of_wedge (A B : Type*) 78 | : ppr1 ∘* pprod_of_wedge A B ~* wpr1 A B := 79 | begin 80 | fconstructor, 81 | { intro w, induction w with a b, 82 | { reflexivity }, 83 | { reflexivity }, 84 | { apply eq_pathover, apply hdeg_square, 85 | apply trans (ap_compose ppr1 (pprod_of_wedge A B) (pushout.glue star)), 86 | krewrite pushout.elim_glue, krewrite pushout.elim_glue } }, 87 | { reflexivity } 88 | end 89 | 90 | definition ppr2_pprod_of_wedge (A B : Type*) 91 | : ppr2 ∘* pprod_of_wedge A B ~* wpr2 A B := 92 | begin 93 | fconstructor, 94 | { intro w, induction w with a b, 95 | { reflexivity }, 96 | { reflexivity }, 97 | { apply eq_pathover, apply hdeg_square, 98 | apply trans (ap_compose ppr2 (pprod_of_wedge A B) (pushout.glue star)), 99 | krewrite pushout.elim_glue, krewrite pushout.elim_glue } }, 100 | { reflexivity } 101 | end 102 | 103 | end prod 104 | structure co_h_space [class] (A : Type*) := 105 | (comul : A →* (A ∨ A)) 106 | (colaw : pprod_of_wedge A A ∘* comul ~* pdiag A) 107 | 108 | open co_h_space 109 | 110 | definition co_h_space_of_counit_laws {A : Type*} 111 | (c : A →* (A ∨ A)) 112 | (l : wpr1 A A ∘* c ~* pid A) (r : wpr2 A A ∘* c ~* pid A) 113 | : co_h_space A := 114 | co_h_space.mk c (pair_phomotopy 115 | (calc 116 | ppr1 ∘* pprod_of_wedge A A ∘* c 117 | ~* (ppr1 ∘* pprod_of_wedge A A) ∘* c 118 | : (passoc ppr1 (pprod_of_wedge A A) c)⁻¹* 119 | ... ~* wpr1 A A ∘* c 120 | : pwhisker_right c (ppr1_pprod_of_wedge A A) 121 | ... ~* pid A : l) 122 | (calc 123 | ppr2 ∘* pprod_of_wedge A A ∘* c 124 | ~* (ppr2 ∘* pprod_of_wedge A A) ∘* c 125 | : (passoc ppr2 (pprod_of_wedge A A) c)⁻¹* 126 | ... ~* wpr2 A A ∘* c 127 | : pwhisker_right c (ppr2_pprod_of_wedge A A) 128 | ... ~* pid A : r)) 129 | 130 | section 131 | variables (A : Type*) [H : co_h_space A] 132 | include H 133 | 134 | definition counit_left : wpr1 A A ∘* comul A ~* pid A := 135 | calc 136 | wpr1 A A ∘* comul A 137 | ~* (ppr1 ∘* (pprod_of_wedge A A)) ∘* comul A 138 | : (pwhisker_right (comul A) (ppr1_pprod_of_wedge A A))⁻¹* 139 | ... ~* ppr1 ∘* ((pprod_of_wedge A A) ∘* comul A) 140 | : passoc ppr1 (pprod_of_wedge A A) (comul A) 141 | ... ~* pid A 142 | : pwhisker_left ppr1 (colaw A) 143 | 144 | definition counit_right : wpr2 A A ∘* comul A ~* pid A := 145 | calc 146 | wpr2 A A ∘* comul A 147 | ~* (ppr2 ∘* (pprod_of_wedge A A)) ∘* comul A 148 | : (pwhisker_right (comul A) (ppr2_pprod_of_wedge A A))⁻¹* 149 | ... ~* ppr2 ∘* ((pprod_of_wedge A A) ∘* comul A) 150 | : passoc ppr2 (pprod_of_wedge A A) (comul A) 151 | ... ~* pid A 152 | : pwhisker_left ppr2 (colaw A) 153 | 154 | definition is_conn_co_h_space : is_conn 0 A := 155 | begin 156 | apply is_contr.mk (trunc.tr pt), intro ta, 157 | induction ta with a, 158 | have t : trunc -1 ((Σ b, comul A a = inl b) ⊎ (Σ c, comul A a = inr c)), 159 | from (or_of_wedge (comul A a)), 160 | induction t with s, induction s with bp cp, 161 | { induction bp with b p, apply ap trunc.tr, 162 | exact (ap (wpr2 A A) p)⁻¹ ⬝ (counit_right A a) }, 163 | { induction cp with c p, apply ap trunc.tr, 164 | exact (ap (wpr1 A A) p)⁻¹ ⬝ (counit_left A a) } 165 | end 166 | 167 | end 168 | 169 | section 170 | variable (A : Type*) 171 | 172 | definition pinch : ⅀ A →* wedge (⅀ A) (⅀ A) := 173 | begin 174 | fapply pmap.mk, 175 | { intro sa, induction sa with a, 176 | { exact inl north }, { exact inr south }, 177 | { exact ap inl (glue a ⬝ (glue pt)⁻¹) ⬝ glue star ⬝ ap inr (glue a) } }, 178 | { reflexivity } 179 | end 180 | 181 | definition co_h_space_susp : co_h_space (⅀ A) := 182 | co_h_space_of_counit_laws (pinch A) 183 | begin 184 | fapply phomotopy.mk, 185 | { intro sa, induction sa with a, 186 | { reflexivity }, 187 | { exact glue pt }, 188 | { apply eq_pathover, 189 | krewrite [ap_id,-ap_compose' (wpr1 (⅀ A) (⅀ A)) (pinch A)], 190 | krewrite elim_merid, rewrite ap_con, 191 | krewrite [pushout.elim_inr,ap_constant], 192 | rewrite ap_con, krewrite [pushout.elim_inl,pushout.elim_glue,ap_id], 193 | apply square_of_eq, apply trans !idp_con, apply inverse, 194 | apply trans (con.assoc (merid a) (glue pt)⁻¹ (glue pt)), 195 | exact whisker_left (merid a) (con.left_inv (glue pt)) } }, 196 | { reflexivity } 197 | end 198 | begin 199 | fapply phomotopy.mk, 200 | { intro sa, induction sa with a, 201 | { reflexivity }, 202 | { reflexivity }, 203 | { apply eq_pathover, 204 | krewrite [ap_id,-ap_compose' (wpr2 (⅀ A) (⅀ A)) (pinch A)], 205 | krewrite elim_merid, rewrite ap_con, 206 | krewrite [pushout.elim_inr,ap_id], 207 | rewrite ap_con, krewrite [pushout.elim_inl,pushout.elim_glue,ap_constant], 208 | apply square_of_eq, apply trans !idp_con, apply inverse, 209 | exact idp_con (merid a) } }, 210 | { reflexivity } 211 | end 212 | 213 | end 214 | /- 215 | terminology: magma, comagma? co_h_space/co_h_space? 216 | pre_inf_group? pre_inf_cogroup? ghs (for group-like H-space?) 217 | cgcohs (cogroup-like co-H-space?) cogroup_like_co_h_space? 218 | -/ 219 | 220 | end group 221 | -------------------------------------------------------------------------------- /algebra/direct_sum.hlean: -------------------------------------------------------------------------------- 1 | /- 2 | Copyright (c) 2015 Floris van Doorn, Egbert Rijke, Favonia. All rights reserved. 3 | Released under Apache 2.0 license as described in the file LICENSE. 4 | Authors: Floris van Doorn, Egbert Rijke, Favonia 5 | 6 | Constructions with groups 7 | -/ 8 | 9 | import .quotient_group .free_abelian_group .product_group 10 | 11 | open eq is_equiv algebra is_trunc set_quotient relation sigma prod sum list trunc function equiv sigma.ops lift 12 | 13 | namespace group 14 | 15 | section 16 | 17 | parameters {I : Type} [is_set I] (Y : I → AbGroup) 18 | variables {A' : AbGroup} {Y' : I → AbGroup} 19 | 20 | open option pointed 21 | 22 | definition dirsum_carrier : AbGroup := free_ab_group (Σi, Y i)₊ 23 | 24 | local abbreviation ι [constructor] := (@free_ab_group_inclusion (Σi, Y i)₊ _ ∘ some) 25 | inductive dirsum_rel : dirsum_carrier → Type := 26 | | rmk : Πi y₁ y₂, dirsum_rel (ι ⟨i, y₁⟩ * ι ⟨i, y₂⟩ * (ι ⟨i, y₁ * y₂⟩)⁻¹) 27 | 28 | definition dirsum : AbGroup := quotient_ab_group_gen dirsum_carrier (λg, ∥dirsum_rel g∥) 29 | 30 | -- definition dirsum_carrier_incl [constructor] (i : I) : Y i →g dirsum_carrier := 31 | 32 | definition dirsum_incl [constructor] (i : I) : Y i →g dirsum := 33 | homomorphism.mk (λy, class_of (ι ⟨i, y⟩)) 34 | begin intro g h, symmetry, apply gqg_eq_of_rel, apply tr, apply dirsum_rel.rmk end 35 | 36 | parameter {Y} 37 | definition dirsum.rec {P : dirsum → Type} [H : Πg, is_prop (P g)] 38 | (h₁ : Πi (y : Y i), P (dirsum_incl i y)) (h₂ : P 1) (h₃ : Πg h, P g → P h → P (g * h)) : 39 | Πg, P g := 40 | begin 41 | refine @set_quotient.rec_prop _ _ _ H _, 42 | refine @set_quotient.rec_prop _ _ _ (λx, !H) _, 43 | esimp, intro l, induction l with s l ih, 44 | { exact h₂ }, 45 | { induction s with z z, 46 | { induction z with v, 47 | { refine transport P _ ih, apply ap class_of, symmetry, 48 | exact eq_of_rel (tr (free_ab_group.fcg_rel.resp_append !free_ab_group.fcg_rel.cancelpt1 (free_ab_group.fcg_rel.rrefl l))) }, 49 | { induction v with i y, exact h₃ _ _ (h₁ i y) ih } }, 50 | { induction z with v, 51 | { refine transport P _ ih, apply ap class_of, symmetry, 52 | exact eq_of_rel (tr (free_ab_group.fcg_rel.resp_append !free_ab_group.fcg_rel.cancelpt2 (free_ab_group.fcg_rel.rrefl l))) }, 53 | { induction v with i y, 54 | refine h₃ (gqg_map _ _ (class_of [inr (some ⟨i, y⟩)])) _ _ ih, 55 | refine transport P _ (h₁ i y⁻¹), 56 | refine _ ⬝ !one_mul, 57 | refine _ ⬝ ap (λx, mul x _) (to_respect_zero (dirsum_incl i)), 58 | apply gqg_eq_of_rel', 59 | apply tr, esimp, 60 | refine transport dirsum_rel _ (dirsum_rel.rmk i y⁻¹ y), 61 | rewrite [mul.left_inv, mul.assoc]} } } 62 | end 63 | 64 | definition dirsum_homotopy {φ ψ : dirsum →g A'} 65 | (h : Πi (y : Y i), φ (dirsum_incl i y) = ψ (dirsum_incl i y)) : φ ~ ψ := 66 | begin 67 | refine dirsum.rec _ _ _, 68 | exact h, 69 | refine !to_respect_zero ⬝ !to_respect_zero⁻¹, 70 | intro g₁ g₂ h₁ h₂, rewrite [* to_respect_mul, h₁, h₂] 71 | end 72 | 73 | definition dirsum_elim_resp_quotient (f : Πi, Y i →g A') (g : dirsum_carrier) 74 | (r : ∥dirsum_rel g∥) : free_ab_group_elim ((pmap_equiv_left (Σi, Y i) A')⁻¹ (λv, f v.1 v.2)) g = 1 := 75 | begin 76 | induction r with r, induction r, 77 | rewrite [to_respect_mul, to_respect_inv, to_respect_mul, ▸*, ↑foldl, *one_mul], 78 | rewrite [↑pmap_equiv_left], esimp, 79 | rewrite [-to_respect_mul], apply mul.right_inv 80 | end 81 | 82 | definition dirsum_elim [constructor] (f : Πi, Y i →g A') : dirsum →g A' := 83 | gqg_elim _ (free_ab_group_elim ((pmap_equiv_left (Σi, Y i) A')⁻¹ (λv, f v.1 v.2))) (dirsum_elim_resp_quotient f) 84 | 85 | definition dirsum_elim_compute (f : Πi, Y i →g A') (i : I) (y : Y i) : 86 | dirsum_elim f (dirsum_incl i y) = f i y := 87 | begin 88 | apply one_mul 89 | end 90 | 91 | definition dirsum_elim_unique (f : Πi, Y i →g A') (k : dirsum →g A') 92 | (H : Πi, k ∘g dirsum_incl i ~ f i) : k ~ dirsum_elim f := 93 | begin 94 | apply gqg_elim_unique, 95 | apply free_ab_group_elim_unique, 96 | intro x, induction x with z, 97 | { esimp, refine _ ⬝ to_respect_zero k, apply ap k, apply ap class_of, 98 | exact eq_of_rel (tr !free_ab_group.fcg_rel.cancelpt1) }, 99 | { induction z with i y, exact H i y } 100 | end 101 | 102 | end 103 | 104 | definition binary_dirsum (G H : AbGroup) : dirsum (bool.rec G H) ≃g G ×ag H := 105 | let branch := bool.rec G H in 106 | let to_hom := (dirsum_elim (bool.rec (product_inl G H) (product_inr G H)) 107 | : dirsum (bool.rec G H) →g G ×ag H) in 108 | let from_hom := (Group_sum_elim (dirsum (bool.rec G H)) 109 | (dirsum_incl branch bool.ff) (dirsum_incl branch bool.tt) 110 | : G ×g H →g dirsum branch) in 111 | begin 112 | fapply isomorphism.mk, 113 | { exact dirsum_elim (bool.rec (product_inl G H) (product_inr G H)) }, 114 | fapply adjointify, 115 | { exact from_hom }, 116 | { intro gh, induction gh with g h, 117 | exact prod_eq (mul_one (1 * g) ⬝ one_mul g) (ap (λ o, o * h) (mul_one 1) ⬝ one_mul h) }, 118 | { refine dirsum.rec _ _ _, 119 | { intro b x, 120 | refine ap from_hom (dirsum_elim_compute (bool.rec (product_inl G H) (product_inr G H)) b x) ⬝ _, 121 | induction b, 122 | { exact ap (λ y, dirsum_incl branch bool.ff x * y) (to_respect_one (dirsum_incl branch bool.tt)) ⬝ mul_one _ }, 123 | { exact ap (λ y, y * dirsum_incl branch bool.tt x) (to_respect_one (dirsum_incl branch bool.ff)) ⬝ one_mul _ } 124 | }, 125 | { refine ap from_hom (to_respect_one to_hom) ⬝ to_respect_one from_hom }, 126 | { intro g h gβ hβ, 127 | refine ap from_hom (to_respect_mul to_hom _ _) ⬝ to_respect_mul from_hom _ _ ⬝ _, 128 | exact ap011 mul gβ hβ 129 | } 130 | } 131 | end 132 | 133 | variables {I J : Type} [is_set I] [is_set J] {Y Y' Y'' : I → AbGroup} 134 | 135 | definition dirsum_functor [constructor] (f : Πi, Y i →g Y' i) : dirsum Y →g dirsum Y' := 136 | dirsum_elim (λi, dirsum_incl Y' i ∘g f i) 137 | 138 | theorem dirsum_functor_compose (f' : Πi, Y' i →g Y'' i) (f : Πi, Y i →g Y' i) : 139 | dirsum_functor f' ∘g dirsum_functor f ~ dirsum_functor (λi, f' i ∘g f i) := 140 | begin 141 | apply dirsum_homotopy, 142 | intro i y, reflexivity, 143 | end 144 | 145 | variable (Y) 146 | definition dirsum_functor_gid : dirsum_functor (λi, gid (Y i)) ~ gid (dirsum Y) := 147 | begin 148 | apply dirsum_homotopy, 149 | intro i y, reflexivity, 150 | end 151 | variable {Y} 152 | 153 | definition dirsum_functor_mul (f f' : Πi, Y i →g Y' i) : 154 | homomorphism_mul (dirsum_functor f) (dirsum_functor f') ~ 155 | dirsum_functor (λi, homomorphism_mul (f i) (f' i)) := 156 | begin 157 | apply dirsum_homotopy, 158 | intro i y, exact sorry 159 | end 160 | 161 | definition dirsum_functor_homotopy (f f' : Πi, Y i →g Y' i) (p : f ~2 f') : 162 | dirsum_functor f ~ dirsum_functor f' := 163 | begin 164 | apply dirsum_homotopy, 165 | intro i y, exact sorry 166 | end 167 | 168 | definition dirsum_functor_left [constructor] (f : J → I) : dirsum (Y ∘ f) →g dirsum Y := 169 | dirsum_elim (λj, dirsum_incl Y (f j)) 170 | 171 | definition dirsum_isomorphism [constructor] (f : Πi, Y i ≃g Y' i) : dirsum Y ≃g dirsum Y' := 172 | let to_hom := dirsum_functor (λ i, f i) in 173 | let from_hom := dirsum_functor (λ i, (f i)⁻¹ᵍ) in 174 | begin 175 | fapply isomorphism.mk, 176 | exact dirsum_functor (λ i, f i), 177 | fapply is_equiv.adjointify, 178 | exact dirsum_functor (λ i, (f i)⁻¹ᵍ), 179 | { intro ds, 180 | refine (homomorphism_compose_eq (dirsum_functor (λ i, f i)) (dirsum_functor (λ i, (f i)⁻¹ᵍ)) _)⁻¹ ⬝ _, 181 | refine dirsum_functor_compose (λ i, f i) (λ i, (f i)⁻¹ᵍ) ds ⬝ _, 182 | refine dirsum_functor_homotopy _ (λ i, !gid) (λ i, to_right_inv (equiv_of_isomorphism (f i))) ds ⬝ _, 183 | exact !dirsum_functor_gid 184 | }, 185 | { intro ds, 186 | refine (homomorphism_compose_eq (dirsum_functor (λ i, (f i)⁻¹ᵍ)) (dirsum_functor (λ i, f i)) _)⁻¹ ⬝ _, 187 | refine dirsum_functor_compose (λ i, (f i)⁻¹ᵍ) (λ i, f i) ds ⬝ _, 188 | refine dirsum_functor_homotopy _ (λ i, !gid) (λ i x, 189 | proof 190 | to_left_inv (equiv_of_isomorphism (f i)) x 191 | qed 192 | ) ds ⬝ _, 193 | exact !dirsum_functor_gid 194 | } 195 | end 196 | 197 | end group 198 | 199 | namespace group 200 | 201 | definition dirsum_down_left.{u v w} {I : Type.{u}} [is_set I] (Y : I → AbGroup.{w}) 202 | : dirsum (Y ∘ down.{u v}) ≃g dirsum Y := 203 | proof 204 | let to_hom := @dirsum_functor_left _ _ _ _ Y down.{u v} in 205 | let from_hom := dirsum_elim (λi, dirsum_incl (Y ∘ down.{u v}) (up.{u v} i)) in 206 | begin 207 | fapply isomorphism.mk, 208 | { exact to_hom }, 209 | fapply adjointify, 210 | { exact from_hom }, 211 | { intro ds, 212 | refine (homomorphism_compose_eq to_hom from_hom ds)⁻¹ ⬝ _, 213 | refine @dirsum_homotopy I _ Y (dirsum Y) (to_hom ∘g from_hom) !gid _ ds, 214 | intro i y, 215 | refine homomorphism_compose_eq to_hom from_hom _ ⬝ _, 216 | refine ap to_hom (dirsum_elim_compute (λi, dirsum_incl (Y ∘ down.{u v}) (up.{u v} i)) i y) ⬝ _, 217 | refine dirsum_elim_compute _ (up.{u v} i) y ⬝ _, 218 | reflexivity 219 | }, 220 | { intro ds, 221 | refine (homomorphism_compose_eq from_hom to_hom ds)⁻¹ ⬝ _, 222 | refine @dirsum_homotopy _ _ (Y ∘ down.{u v}) (dirsum (Y ∘ down.{u v})) (from_hom ∘g to_hom) !gid _ ds, 223 | intro i y, induction i with i, 224 | refine homomorphism_compose_eq from_hom to_hom _ ⬝ _, 225 | refine ap from_hom (dirsum_elim_compute (λi, dirsum_incl Y (down.{u v} i)) (up.{u v} i) y) ⬝ _, 226 | refine dirsum_elim_compute _ i y ⬝ _, 227 | reflexivity 228 | } 229 | end 230 | qed 231 | 232 | end group 233 | -------------------------------------------------------------------------------- /algebra/free_abelian_group.hlean: -------------------------------------------------------------------------------- 1 | /- 2 | Copyright (c) 2015 Floris van Doorn. All rights reserved. 3 | Released under Apache 2.0 license as described in the file LICENSE. 4 | Authors: Floris van Doorn, Egbert Rijke 5 | 6 | Constructions with groups 7 | -/ 8 | 9 | import algebra.group_theory hit.set_quotient types.list types.sum .free_group 10 | 11 | open eq algebra is_trunc set_quotient relation sigma sigma.ops prod sum list trunc function equiv trunc_index 12 | group pointed 13 | 14 | namespace group 15 | 16 | variables {G G' : Group} {g g' h h' k : G} {A B : AbGroup} 17 | 18 | variables (X : Type*) {Y : Type*} [is_set X] [is_set Y] {l l' : list (X ⊎ X)} 19 | 20 | /- Free Abelian Group on a pointed set -/ 21 | namespace free_ab_group 22 | 23 | inductive fcg_rel : list (X ⊎ X) → list (X ⊎ X) → Type := 24 | | rrefl : Πl, fcg_rel l l 25 | | cancel1 : Πx, fcg_rel [inl x, inr x] [] 26 | | cancel2 : Πx, fcg_rel [inr x, inl x] [] 27 | | cancelpt1 : fcg_rel [inl pt] [] 28 | | cancelpt2 : fcg_rel [inr pt] [] 29 | | rflip : Πx y, fcg_rel [x, y] [y, x] 30 | | resp_append : Π{l₁ l₂ l₃ l₄}, fcg_rel l₁ l₂ → fcg_rel l₃ l₄ → 31 | fcg_rel (l₁ ++ l₃) (l₂ ++ l₄) 32 | | rtrans : Π{l₁ l₂ l₃}, fcg_rel l₁ l₂ → fcg_rel l₂ l₃ → 33 | fcg_rel l₁ l₃ 34 | 35 | open fcg_rel 36 | local abbreviation R [reducible] := fcg_rel 37 | attribute fcg_rel.rrefl [refl] 38 | attribute fcg_rel.rtrans [trans] 39 | 40 | definition fcg_carrier [reducible] : Type := set_quotient (λx y, ∥R X x y∥) 41 | local abbreviation FG := fcg_carrier 42 | 43 | definition is_reflexive_R : is_reflexive (λx y, ∥R X x y∥) := 44 | begin constructor, intro s, apply tr, unfold R end 45 | local attribute is_reflexive_R [instance] 46 | 47 | variable {X} 48 | theorem rel_respect_flip (r : R X l l') : R X (map sum.flip l) (map sum.flip l') := 49 | begin 50 | induction r with l x x x y l₁ l₂ l₃ l₄ r₁ r₂ IH₁ IH₂ l₁ l₂ l₃ r₁ r₂ IH₁ IH₂, 51 | { reflexivity}, 52 | { repeat esimp [map], exact cancel2 x}, 53 | { repeat esimp [map], exact cancel1 x}, 54 | { exact cancelpt2 X }, 55 | { exact cancelpt1 X }, 56 | { repeat esimp [map], apply fcg_rel.rflip}, 57 | { rewrite [+map_append], exact resp_append IH₁ IH₂}, 58 | { exact rtrans IH₁ IH₂} 59 | end 60 | 61 | theorem rel_respect_reverse (r : R X l l') : R X (reverse l) (reverse l') := 62 | begin 63 | induction r with l x x x y l₁ l₂ l₃ l₄ r₁ r₂ IH₁ IH₂ l₁ l₂ l₃ r₁ r₂ IH₁ IH₂, 64 | { reflexivity}, 65 | { repeat esimp [map], exact cancel2 x}, 66 | { repeat esimp [map], exact cancel1 x}, 67 | { exact cancelpt1 X }, 68 | { exact cancelpt2 X }, 69 | { repeat esimp [map], apply fcg_rel.rflip}, 70 | { rewrite [+reverse_append], exact resp_append IH₂ IH₁}, 71 | { exact rtrans IH₁ IH₂} 72 | end 73 | 74 | theorem rel_cons_concat (l s) : R X (s :: l) (concat s l) := 75 | begin 76 | induction l with t l IH, 77 | { reflexivity}, 78 | { rewrite [concat_cons], transitivity (t :: s :: l), 79 | { exact resp_append !rflip !rrefl}, 80 | { exact resp_append (rrefl [t]) IH}} 81 | end 82 | 83 | definition fcg_one [constructor] : FG X := class_of [] 84 | definition fcg_inv [unfold 3] : FG X → FG X := 85 | quotient_unary_map (reverse ∘ map sum.flip) 86 | (λl l', trunc_functor -1 (rel_respect_reverse ∘ rel_respect_flip)) 87 | definition fcg_mul [unfold 3 4] : FG X → FG X → FG X := 88 | quotient_binary_map append (λl l', trunc.elim (λr m m', trunc.elim (λs, tr (resp_append r s)))) 89 | 90 | section 91 | local notation 1 := fcg_one 92 | local postfix ⁻¹ := fcg_inv 93 | local infix * := fcg_mul 94 | 95 | theorem fcg_mul_assoc (g₁ g₂ g₃ : FG X) : g₁ * g₂ * g₃ = g₁ * (g₂ * g₃) := 96 | begin 97 | refine set_quotient.rec_prop _ g₁, 98 | refine set_quotient.rec_prop _ g₂, 99 | refine set_quotient.rec_prop _ g₃, 100 | clear g₁ g₂ g₃, intro g₁ g₂ g₃, 101 | exact ap class_of !append.assoc 102 | end 103 | 104 | theorem fcg_one_mul (g : FG X) : 1 * g = g := 105 | begin 106 | refine set_quotient.rec_prop _ g, clear g, intro g, 107 | exact ap class_of !append_nil_left 108 | end 109 | 110 | theorem fcg_mul_one (g : FG X) : g * 1 = g := 111 | begin 112 | refine set_quotient.rec_prop _ g, clear g, intro g, 113 | exact ap class_of !append_nil_right 114 | end 115 | 116 | theorem fcg_mul_left_inv (g : FG X) : g⁻¹ * g = 1 := 117 | begin 118 | refine set_quotient.rec_prop _ g, clear g, intro g, 119 | apply eq_of_rel, apply tr, 120 | induction g with s l IH, 121 | { reflexivity}, 122 | { rewrite [▸*, map_cons, reverse_cons, concat_append], 123 | refine rtrans _ IH, 124 | apply resp_append, reflexivity, 125 | change R X ([flip s, s] ++ l) ([] ++ l), 126 | apply resp_append, 127 | induction s, apply cancel2, apply cancel1, 128 | reflexivity} 129 | end 130 | 131 | theorem fcg_mul_comm (g h : FG X) : g * h = h * g := 132 | begin 133 | refine set_quotient.rec_prop _ g, clear g, intro g, 134 | refine set_quotient.rec_prop _ h, clear h, intro h, 135 | apply eq_of_rel, apply tr, 136 | revert h, induction g with s l IH: intro h, 137 | { rewrite [append_nil_left, append_nil_right]}, 138 | { rewrite [append_cons,-concat_append], 139 | transitivity concat s (l ++ h), apply rel_cons_concat, 140 | rewrite [-append_concat], apply IH} 141 | end 142 | end 143 | end free_ab_group open free_ab_group 144 | 145 | variables (X) 146 | definition group_free_ab_group [constructor] : ab_group (fcg_carrier X) := 147 | ab_group.mk _ fcg_mul fcg_mul_assoc fcg_one fcg_one_mul fcg_mul_one 148 | fcg_inv fcg_mul_left_inv fcg_mul_comm 149 | 150 | definition free_ab_group [constructor] : AbGroup := 151 | AbGroup.mk _ (group_free_ab_group X) 152 | 153 | /- The universal property of the free commutative group -/ 154 | variables {X A} 155 | definition free_ab_group_inclusion [constructor] : X →* free_ab_group X := 156 | ppi.mk (λ x, class_of [inl x]) (eq_of_rel (tr (fcg_rel.cancelpt1 X))) 157 | 158 | theorem fgh_helper_respect_fcg_rel (f : X →* A) (r : fcg_rel X l l') 159 | : Π(g : A), foldl (fgh_helper f) g l = foldl (fgh_helper f) g l' := 160 | begin 161 | induction r with l x x x y l₁ l₂ l₃ l₄ r₁ r₂ IH₁ IH₂ l₁ l₂ l₃ r₁ r₂ IH₁ IH₂: intro g, 162 | { reflexivity}, 163 | { unfold [foldl], apply mul_inv_cancel_right}, 164 | { unfold [foldl], apply inv_mul_cancel_right}, 165 | { unfold [foldl], rewrite (respect_pt f), apply mul_one }, 166 | { unfold [foldl], rewrite [respect_pt f, one_inv], apply mul_one }, 167 | { unfold [foldl, fgh_helper], apply mul.right_comm}, 168 | { rewrite [+foldl_append, IH₁, IH₂]}, 169 | { exact !IH₁ ⬝ !IH₂} 170 | end 171 | 172 | definition free_ab_group_elim [constructor] (f : X →* A) : free_ab_group X →g A := 173 | begin 174 | fapply homomorphism.mk, 175 | { intro g, refine set_quotient.elim _ _ g, 176 | { intro l, exact foldl (fgh_helper f) 1 l}, 177 | { intro l l' r, esimp at *, refine trunc.rec _ r, clear r, intro r, 178 | exact fgh_helper_respect_fcg_rel f r 1}}, 179 | { refine set_quotient.rec_prop _, intro l, refine set_quotient.rec_prop _, intro l', 180 | esimp, refine !foldl_append ⬝ _, esimp, apply fgh_helper_mul} 181 | end 182 | 183 | definition fn_of_free_ab_group_elim [unfold_full] (φ : free_ab_group X →g A) : X →* A := 184 | ppi.mk (φ ∘ free_ab_group_inclusion) 185 | begin 186 | refine (_ ⬝ @respect_one _ _ _ _ φ (homomorphism.p φ)), 187 | apply ap φ, apply eq_of_rel, apply tr, 188 | exact (fcg_rel.cancelpt1 X) 189 | end 190 | 191 | definition free_ab_group_elim_unique [constructor] (f : X →* A) (k : free_ab_group X →g A) 192 | (H : k ∘ free_ab_group_inclusion ~ f) : k ~ free_ab_group_elim f := 193 | begin 194 | refine set_quotient.rec_prop _, intro l, esimp, 195 | induction l with s l IH, 196 | { esimp [foldl], exact to_respect_one k}, 197 | { rewrite [foldl_cons, fgh_helper_mul], 198 | refine to_respect_mul k (class_of [s]) (class_of l) ⬝ _, 199 | rewrite [IH], apply ap (λx, x * _), induction s: rewrite [▸*, one_mul, -H a], 200 | apply to_respect_inv } 201 | end 202 | 203 | variables (X A) 204 | definition free_ab_group_elim_equiv_fn [constructor] : (free_ab_group X →g A) ≃ (X →* A) := 205 | begin 206 | fapply equiv.MK, 207 | { exact fn_of_free_ab_group_elim}, 208 | { exact free_ab_group_elim}, 209 | { intro f, apply eq_of_phomotopy, fapply phomotopy.mk, 210 | { intro x, esimp, unfold [foldl], apply one_mul }, 211 | { apply is_prop.elim } }, 212 | { intro k, symmetry, apply homomorphism_eq, apply free_ab_group_elim_unique, 213 | reflexivity } 214 | end 215 | 216 | definition free_ab_group_functor (f : X →* Y) : free_ab_group X →g free_ab_group Y := 217 | free_ab_group_elim (free_ab_group_inclusion ∘* f) 218 | 219 | -- set_option pp.all true 220 | -- definition free_ab_group.rec {P : free_ab_group X → Type} [H : Πg, is_prop (P g)] 221 | -- (h₁ : Πx, P (free_ab_group_inclusion x)) 222 | -- (h₂ : P 0) 223 | -- (h₃ : Πg h, P g → P h → P (g * h)) 224 | -- (h₄ : Πg, P g → P g⁻¹) : 225 | -- Πg, P g := 226 | -- begin 227 | -- refine @set_quotient.rec_prop _ _ _ H _, 228 | -- refine @set_quotient.rec_prop _ _ _ (λx, !H) _, 229 | -- esimp, intro l, induction l with s l ih, 230 | -- exact h₂, 231 | -- induction s with v v, 232 | -- induction v with i y, 233 | -- exact h₃ _ _ (h₁ i y) ih, 234 | -- induction v with i y, 235 | -- refine h₃ (gqg_map _ _ (class_of [inr ⟨i, y⟩])) _ _ ih, 236 | -- refine transport P _ (h₁ i y⁻¹), 237 | -- refine _ ⬝ !mul_one, 238 | -- refine _ ⬝ ap (mul _) (to_respect_one (dirsum_incl i)), 239 | -- apply gqg_eq_of_rel', 240 | -- apply tr, esimp, 241 | -- refine transport dirsum_rel _ (dirsum_rel.rmk i y⁻¹ y), 242 | -- rewrite [mul.left_inv, mul.assoc], 243 | -- apply ap (mul _), 244 | -- refine _ ⬝ (mul_inv (class_of [inr ⟨i, y⟩]) (ι ⟨i, 1⟩))⁻¹ᵖ, 245 | -- refine ap011 mul _ _, 246 | -- end 247 | 248 | end group 249 | -------------------------------------------------------------------------------- /algebra/module_chain_complex.hlean: -------------------------------------------------------------------------------- 1 | /- 2 | Author: Jeremy Avigad 3 | -/ 4 | import homotopy.chain_complex .left_module .exactness ..move_to_lib 5 | open eq pointed sigma fiber equiv is_equiv sigma.ops is_trunc nat trunc 6 | open algebra function 7 | open chain_complex 8 | open succ_str 9 | open left_module 10 | 11 | structure module_chain_complex (R : Ring) (N : succ_str) : Type := 12 | (mod : N → LeftModule R) 13 | (hom : Π (n : N), mod (S n) →lm mod n) 14 | (is_chain_complex : 15 | Π (n : N) (x : mod (S (S n))), hom n (hom (S n) x) = 0) 16 | 17 | namespace left_module 18 | variables {R : Ring} {N : succ_str} 19 | 20 | definition mcc_mod [unfold 3] [coercion] (C : module_chain_complex R N) (n : N) : 21 | LeftModule R := 22 | module_chain_complex.mod C n 23 | 24 | definition mcc_carr [unfold 3] [coercion] (C : module_chain_complex R N) (n : N) : 25 | Type := 26 | C n 27 | 28 | definition mcc_pcarr [unfold 3] [coercion] (C : module_chain_complex R N) (n : N) : 29 | Set* := 30 | mcc_mod C n 31 | 32 | definition mcc_hom (C : module_chain_complex R N) {n : N} : C (S n) →lm C n := 33 | module_chain_complex.hom C n 34 | 35 | definition mcc_is_chain_complex (C : module_chain_complex R N) (n : N) (x : C (S (S n))) : 36 | mcc_hom C (mcc_hom C x) = 0 := 37 | module_chain_complex.is_chain_complex C n x 38 | 39 | protected definition to_chain_complex [coercion] (C : module_chain_complex R N) : 40 | chain_complex N := 41 | chain_complex.mk 42 | (λ n, mcc_pcarr C n) 43 | (λ n, pmap_of_homomorphism (@mcc_hom R N C n)) 44 | (mcc_is_chain_complex C) 45 | 46 | -- maybe we don't even need this? 47 | definition is_exact_at_m (C : module_chain_complex R N) (n : N) : Type := 48 | is_exact_at C n 49 | 50 | definition is_exact_m (C : module_chain_complex R N) : Type := 51 | ∀n, is_exact_at_m C n 52 | 53 | end left_module 54 | 55 | namespace left_module 56 | variable {R : Ring} 57 | variables {A₀ B₀ C₀ : LeftModule R} 58 | variables (f₀ : A₀ →lm B₀) (g₀ : B₀ →lm C₀) 59 | 60 | definition is_short_exact := @algebra.is_short_exact _ _ C₀ f₀ g₀ 61 | end left_module 62 | -------------------------------------------------------------------------------- /algebra/product_group.hlean: -------------------------------------------------------------------------------- 1 | /- 2 | Copyright (c) 2015 Floris van Doorn. All rights reserved. 3 | Released under Apache 2.0 license as described in the file LICENSE. 4 | Authors: Floris van Doorn, Egbert Rijke, Favonia 5 | 6 | Constructions with groups 7 | -/ 8 | 9 | import algebra.group_theory hit.set_quotient types.list types.sum .subgroup .quotient_group 10 | 11 | open eq algebra is_trunc set_quotient relation sigma prod prod.ops sum list trunc function 12 | equiv is_equiv 13 | namespace group 14 | 15 | variables {G G' : Group} {g g' h h' k : G} 16 | {A B : AbGroup} 17 | 18 | /- Binary products (direct product) of Groups -/ 19 | definition product_one [constructor] : G × G' := (one, one) 20 | definition product_inv [unfold 3] : G × G' → G × G' := 21 | λv, (v.1⁻¹, v.2⁻¹) 22 | definition product_mul [unfold 3 4] : G × G' → G × G' → G × G' := 23 | λv w, (v.1 * w.1, v.2 * w.2) 24 | 25 | section 26 | local notation 1 := product_one 27 | local postfix ⁻¹ := product_inv 28 | local infix * := product_mul 29 | 30 | theorem product_mul_assoc (g₁ g₂ g₃ : G × G') : g₁ * g₂ * g₃ = g₁ * (g₂ * g₃) := 31 | prod_eq !mul.assoc !mul.assoc 32 | 33 | theorem product_one_mul (g : G × G') : 1 * g = g := 34 | prod_eq !one_mul !one_mul 35 | 36 | theorem product_mul_one (g : G × G') : g * 1 = g := 37 | prod_eq !mul_one !mul_one 38 | 39 | theorem product_mul_left_inv (g : G × G') : g⁻¹ * g = 1 := 40 | prod_eq !mul.left_inv !mul.left_inv 41 | 42 | theorem product_mul_comm {G G' : AbGroup} (g h : G × G') : g * h = h * g := 43 | prod_eq !mul.comm !mul.comm 44 | 45 | end 46 | 47 | variables (G G') 48 | definition group_prod [constructor] : group (G × G') := 49 | group.mk _ product_mul product_mul_assoc product_one product_one_mul product_mul_one 50 | product_inv product_mul_left_inv 51 | 52 | definition product [constructor] : Group := 53 | Group.mk _ (group_prod G G') 54 | 55 | definition ab_group_prod [constructor] (G G' : AbGroup) : ab_group (G × G') := 56 | ⦃ab_group, group_prod G G', mul_comm := product_mul_comm⦄ 57 | 58 | definition ab_product [constructor] (G G' : AbGroup) : AbGroup := 59 | AbGroup.mk _ (ab_group_prod G G') 60 | 61 | definition add_product [constructor] (G G' : AddGroup) : AddGroup := 62 | group.product G G' 63 | 64 | definition add_ab_product [constructor] (G G' : AddAbGroup) : AddAbGroup := 65 | group.ab_product G G' 66 | 67 | infix ` ×g `:60 := group.product 68 | infix ` ×ag `:60 := group.ab_product 69 | infix ` ×a `:60 := group.add_product 70 | infix ` ×aa `:60 := group.add_ab_product 71 | 72 | 73 | definition product_inl [constructor] (G H : Group) : G →g G ×g H := 74 | homomorphism.mk (λx, (x, one)) (λx y, prod_eq !refl !one_mul⁻¹) 75 | 76 | definition product_inr [constructor] (G H : Group) : H →g G ×g H := 77 | homomorphism.mk (λx, (one, x)) (λx y, prod_eq !one_mul⁻¹ !refl) 78 | 79 | definition Group_sum_elim [constructor] {G H : Group} (I : AbGroup) (φ : G →g I) (ψ : H →g I) : G ×g H →g I := 80 | homomorphism.mk (λx, φ x.1 * ψ x.2) abstract (λx y, calc 81 | φ (x.1 * y.1) * ψ (x.2 * y.2) = (φ x.1 * φ y.1) * (ψ x.2 * ψ y.2) 82 | : by exact ap011 mul (to_respect_mul φ x.1 y.1) (to_respect_mul ψ x.2 y.2) 83 | ... = (φ x.1 * ψ x.2) * (φ y.1 * ψ y.2) 84 | : by exact mul.comm4 (φ x.1) (φ y.1) (ψ x.2) (ψ y.2)) end 85 | 86 | definition product_functor [constructor] {G G' H H' : Group} (φ : G →g H) (ψ : G' →g H') : 87 | G ×g G' →g H ×g H' := 88 | homomorphism.mk (λx, (φ x.1, ψ x.2)) (λx y, prod_eq !to_respect_mul !to_respect_mul) 89 | 90 | infix ` ×→g `:60 := group.product_functor 91 | 92 | definition product_isomorphism [constructor] {G G' H H' : Group} (φ : G ≃g H) (ψ : G' ≃g H') : 93 | G ×g G' ≃g H ×g H' := 94 | isomorphism.mk (φ ×→g ψ) !is_equiv_prod_functor 95 | 96 | infix ` ×≃g `:60 := group.product_isomorphism 97 | 98 | definition product_group_mul_eq {G H : Group} (g h : G ×g H) : g * h = product_mul g h := 99 | idp 100 | 101 | definition product_pr1 [constructor] (G H : Group) : G ×g H →g G := 102 | homomorphism.mk (λx, x.1) (λx y, idp) 103 | 104 | definition product_pr2 [constructor] (G H : Group) : G ×g H →g H := 105 | homomorphism.mk (λx, x.2) (λx y, idp) 106 | 107 | definition product_trivial_right [constructor] (G H : Group) (HH : is_contr H) : G ×g H ≃g G := 108 | begin 109 | apply isomorphism.mk (product_pr1 G H), 110 | apply adjointify _ (product_inl G H), 111 | { intro g, reflexivity }, 112 | { intro gh, exact prod_eq idp !is_prop.elim } 113 | end 114 | 115 | definition product_trivial_left [constructor] (G H : Group) (HH : is_contr G) : G ×g H ≃g H := 116 | begin 117 | apply isomorphism.mk (product_pr2 G H), 118 | apply adjointify _ (product_inr G H), 119 | { intro g, reflexivity }, 120 | { intro gh, exact prod_eq !is_prop.elim idp } 121 | end 122 | 123 | end group 124 | -------------------------------------------------------------------------------- /algebra/ring.hlean: -------------------------------------------------------------------------------- 1 | -- Authors: Floris van Doorn 2 | 3 | import algebra.ring .direct_sum ..heq ..move_to_lib 4 | 5 | open algebra group eq is_trunc sigma 6 | 7 | namespace algebra 8 | definition AddAbGroup_of_Ring [constructor] (R : Ring) : AddAbGroup := 9 | AddAbGroup.mk R (add_ab_group_of_ring R) 10 | 11 | definition AddGroup_of_Ring [constructor] (R : Ring) : AddGroup := 12 | AddGroup.mk R (add_group_of_add_ab_group R) 13 | 14 | definition ring_AddAbGroup_of_Ring [instance] (R : Ring) : ring (AddAbGroup_of_Ring R) := 15 | Ring.struct R 16 | 17 | /- we give the following instance very high priority, otherwise type class inference would sometimes find the additive structure of R as the group structure. -/ 18 | definition monoid_AddAbGroup_of_Ring [instance] [priority 3000] [constructor] (R : Ring) : 19 | monoid (Group_of_AbGroup (AddAbGroup_of_Ring R)) := 20 | @monoid_of_ring _ (Ring.struct R) 21 | 22 | definition ring_right_action [constructor] {R : Ring} (r : R) : 23 | AddAbGroup_of_Ring R →a AddAbGroup_of_Ring R := 24 | homomorphism.mk (λs, s * r) (λs s', !right_distrib) 25 | 26 | definition ring_of_ab_group [constructor] (G : Type) [ab_group G] (m : G → G → G) (o : G) 27 | (lm : Πg, m o g = g) (rm : Πg, m g o = g) (am : Πg₁ g₂ g₃, m (m g₁ g₂) g₃ = m g₁ (m g₂ g₃)) 28 | (ld : Πg₁ g₂ g₃, m g₁ (g₂ * g₃) = m g₁ g₂ * m g₁ g₃) 29 | (rd : Πg₁ g₂ g₃, m (g₁ * g₂) g₃ = m g₁ g₃ * m g₂ g₃) : ring G := 30 | ring.mk _ mul mul.assoc 1 one_mul mul_one inv mul.left_inv mul.comm m am o lm rm ld rd 31 | 32 | definition Ring_of_AbGroup [constructor] (G : AbGroup) (m : G → G → G) (o : G) 33 | (lm : Πg, m o g = g) (rm : Πg, m g o = g) (am : Πg₁ g₂ g₃, m (m g₁ g₂) g₃ = m g₁ (m g₂ g₃)) 34 | (ld : Πg₁ g₂ g₃, m g₁ (g₂ * g₃) = m g₁ g₂ * m g₁ g₃) 35 | (rd : Πg₁ g₂ g₃, m (g₁ * g₂) g₃ = m g₁ g₃ * m g₂ g₃) : Ring := 36 | Ring.mk G (ring_of_ab_group G m o lm rm am ld rd) 37 | 38 | /- graded ring -/ 39 | 40 | structure graded_ring (M : Monoid) := 41 | (R : M → AddAbGroup) 42 | (mul : Π⦃m m'⦄, R m → R m' → R (m * m')) 43 | (one : R 1) 44 | (mul_one : Π⦃m⦄ (r : R m), mul r one ==[R] r) 45 | (one_mul : Π⦃m⦄ (r : R m), mul one r ==[R] r) 46 | (mul_assoc : Π⦃m₁ m₂ m₃⦄ (r₁ : R m₁) (r₂ : R m₂) (r₃ : R m₃), 47 | mul (mul r₁ r₂) r₃ ==[R] mul r₁ (mul r₂ r₃)) 48 | (mul_left_distrib : Π⦃m₁ m₂⦄ (r₁ : R m₁) (r₂ r₂' : R m₂), 49 | mul r₁ (r₂ + r₂') = mul r₁ r₂ + mul r₁ r₂') 50 | (mul_right_distrib : Π⦃m₁ m₂⦄ (r₁ r₁' : R m₁) (r₂ : R m₂), 51 | mul (r₁ + r₁') r₂ = mul r₁ r₂ + mul r₁' r₂) 52 | 53 | 54 | attribute graded_ring.R [coercion] 55 | infixl ` ** `:71 := graded_ring.mul 56 | 57 | -- definition ring_direct_sum {M : Monoid} (R : graded_ring M) : Ring := 58 | -- Ring_of_AbGroup (dirsum R) _ (dirsum_incl R 1 (graded_ring.one R)) _ _ _ _ _ 59 | 60 | 61 | 62 | end algebra 63 | -------------------------------------------------------------------------------- /algebra/seq_colim.hlean: -------------------------------------------------------------------------------- 1 | --Authors: Robert Rose, Liz Vidaurre 2 | 3 | import .direct_sum ..move_to_lib 4 | 5 | open eq algebra is_trunc set_quotient relation sigma prod sum list trunc function equiv sigma.ops nat 6 | 7 | namespace group 8 | 9 | section 10 | 11 | parameters (A : ℕ → AbGroup) (f : Πi , A i →g A (i + 1)) 12 | variables {A' : AbGroup} 13 | 14 | definition seq_colim_carrier : AbGroup := dirsum A 15 | inductive seq_colim_rel : seq_colim_carrier → Type := 16 | | rmk : Πi a, seq_colim_rel ((dirsum_incl A i a) * (dirsum_incl A (i + 1) (f i a))⁻¹) 17 | 18 | definition seq_colim : AbGroup := quotient_ab_group_gen seq_colim_carrier (λa, ∥seq_colim_rel a∥) 19 | 20 | parameters {A f} 21 | definition seq_colim_incl [constructor] (i : ℕ) : A i →g seq_colim := 22 | gqg_map _ _ ∘g dirsum_incl A i 23 | 24 | definition seq_colim_quotient (h : Πi, A i →g A') (k : Πi a, h i a = h (succ i) (f i a)) 25 | (v : seq_colim_carrier) (r : ∥seq_colim_rel v∥) : dirsum_elim h v = 1 := 26 | begin 27 | induction r with r, induction r, 28 | refine !to_respect_mul ⬝ _, 29 | refine ap (λγ, group_fun (dirsum_elim h) (group_fun (dirsum_incl A i) a) * group_fun (dirsum_elim h) γ) 30 | (!to_respect_inv)⁻¹ ⬝ _, 31 | refine ap (λγ, γ * group_fun (dirsum_elim h) (group_fun (dirsum_incl A (succ i)) (f i a)⁻¹)) 32 | !dirsum_elim_compute ⬝ _, 33 | refine ap (λγ, (h i a) * γ) !dirsum_elim_compute ⬝ _, 34 | refine ap (λγ, γ * group_fun (h (succ i)) (f i a)⁻¹) !k ⬝ _, 35 | refine ap (λγ, group_fun (h (succ i)) (f i a) * γ) (!to_respect_inv) ⬝ _, 36 | exact !mul.right_inv 37 | end 38 | 39 | definition seq_colim_elim [constructor] (h : Πi, A i →g A') 40 | (k : Πi a, h i a = h (succ i) (f i a)) : seq_colim →g A' := 41 | gqg_elim _ (dirsum_elim h) (seq_colim_quotient h k) 42 | 43 | definition seq_colim_compute (h : Πi, A i →g A') 44 | (k : Πi a, h i a = h (succ i) (f i a)) (i : ℕ) (a : A i) : 45 | (seq_colim_elim h k) (seq_colim_incl i a) = h i a := 46 | begin 47 | refine gqg_elim_compute (λa, ∥seq_colim_rel a∥) (dirsum_elim h) (seq_colim_quotient h k) (dirsum_incl A i a) ⬝ _, 48 | exact !dirsum_elim_compute 49 | end 50 | 51 | definition seq_colim_glue {i : @trunctype.mk 0 ℕ _} {a : A i} : seq_colim_incl i a = seq_colim_incl (succ i) (f i a) := 52 | begin 53 | refine gqg_eq_of_rel _ _, 54 | exact tr (seq_colim_rel.rmk _ _) 55 | end 56 | 57 | section 58 | local abbreviation h (m : seq_colim →g A') : Πi, A i →g A' := λi, m ∘g (seq_colim_incl i) 59 | local abbreviation k (m : seq_colim →g A') : Πi a, h m i a = h m (succ i) (f i a) := 60 | λ i a, ap m (@seq_colim_glue i a) 61 | 62 | definition seq_colim_unique (m : seq_colim →g A') : 63 | Πv, seq_colim_elim (h m) (k m) v = m v := 64 | begin 65 | intro v, refine (gqg_elim_unique _ (dirsum_elim (h m)) _ m _ _)⁻¹ ⬝ _, 66 | apply dirsum_elim_unique, rotate 1, reflexivity, 67 | intro i a, reflexivity 68 | end 69 | 70 | end 71 | 72 | end 73 | 74 | definition seq_colim_functor [constructor] {A A' : ℕ → AbGroup} 75 | {f : Πi , A i →g A (i + 1)} {f' : Πi , A' i →g A' (i + 1)} 76 | (h : Πi, A i →g A' i) (p : Πi, hsquare (f i) (f' i) (h i) (h (i+1))) : 77 | seq_colim A f →g seq_colim A' f' := 78 | seq_colim_elim (λi, seq_colim_incl i ∘g h i) 79 | begin 80 | intro i a, 81 | refine _ ⬝ ap (seq_colim_incl (succ i)) (p i a)⁻¹, 82 | apply seq_colim_glue 83 | end 84 | 85 | -- definition seq_colim_functor_compose [constructor] {A A' A'' : ℕ → AbGroup} 86 | -- {f : Πi , A i →g A (i + 1)} {f' : Πi , A' i →g A' (i + 1)} {f'' : Πi , A'' i →g A'' (i + 1)} 87 | -- (h : Πi, A i →g A' i) (p : Πi (a : A i), h (i+1) (f i a) = f' i (h i a)) 88 | -- (h : Πi, A i →g A' i) (p : Πi (a : A i), h (i+1) (f i a) = f' i (h i a)) : 89 | -- seq_colim A f →g seq_colim A' f' := 90 | -- sorry 91 | 92 | end group 93 | -------------------------------------------------------------------------------- /algebra/short_five.hlean: -------------------------------------------------------------------------------- 1 | /- 2 | Author: Jeremy Avigad 3 | -/ 4 | import .module_chain_complex 5 | open eq pointed sigma fiber equiv is_equiv sigma.ops is_trunc nat trunc 6 | open algebra function succ_str 7 | open left_module 8 | 9 | section short_five 10 | variable {R : Ring} 11 | variables {A₀ B₀ C₀ A₁ B₁ C₁ : LeftModule R} 12 | variables {f₀ : A₀ →lm B₀} {g₀ : B₀ →lm C₀} 13 | variables {f₁ : A₁ →lm B₁} {g₁ : B₁ →lm C₁} 14 | variables {h : A₀ →lm A₁} {k : B₀ →lm B₁} {l : C₀ →lm C₁} 15 | 16 | premise (short_exact₀ : is_short_exact f₀ g₀) 17 | premise (short_exact₁ : is_short_exact f₁ g₁) 18 | premise (hsquare₁ : hsquare f₀ f₁ h k) 19 | premise (hsquare₂ : hsquare g₀ g₁ k l) 20 | 21 | include short_exact₀ short_exact₁ hsquare₁ hsquare₂ 22 | 23 | open algebra.is_short_exact 24 | 25 | lemma short_five_mono [embh : is_embedding h] [embl : is_embedding l] : 26 | is_embedding k := 27 | have is_embedding f₁, from is_emb short_exact₁, 28 | is_embedding_of_is_add_hom k 29 | (take b, suppose k b = 0, 30 | have l (g₀ b) = 0, by rewrite [hsquare₂, ▸*, this, respect_zero], 31 | have g₀ b = 0, from eq_zero_of_eq_zero_of_is_embedding this, 32 | image.elim (ker_in_im short_exact₀ _ this) 33 | (take a, 34 | suppose f₀ a = b, 35 | have f₁ (h a) = 0, by rewrite [-hsquare₁, ▸*, this]; assumption, 36 | have h a = 0, from eq_zero_of_eq_zero_of_is_embedding this, 37 | have a = 0, from eq_zero_of_eq_zero_of_is_embedding this, 38 | show b = 0, by rewrite [-`f₀ a = b`, this, respect_zero])) 39 | 40 | lemma short_five_epi (surjh : is_surjective h) (surjl : is_surjective l) : 41 | is_surjective k := 42 | have surjg₀ : is_surjective g₀, from is_surj short_exact₀, 43 | take b₁ : B₁, 44 | image.elim (surjl (g₁ b₁)) ( 45 | take c₀ : C₀, 46 | assume lc₀ : l c₀ = g₁ b₁, 47 | image.elim (surjg₀ c₀) ( 48 | take b₀ : B₀, 49 | assume g₀b₀ : g₀ b₀ = c₀, 50 | have g₁ (k b₀ - b₁) = 0, by rewrite [respect_sub, -hsquare₂, ▸*, g₀b₀, lc₀, sub_self], 51 | image.elim (ker_in_im short_exact₁ _ this) ( 52 | take a₁ : A₁, 53 | assume f₁a₁ : f₁ a₁ = k b₀ - b₁, 54 | image.elim (surjh a₁) ( 55 | take a₀ : A₀, 56 | assume ha₀ : h a₀ = a₁, 57 | have k (f₀ a₀) = k b₀ - b₁, by rewrite [hsquare₁, ▸*, ha₀, f₁a₁], 58 | have k (b₀ - f₀ a₀) = b₁, by rewrite [respect_sub, this, sub_sub_self], 59 | image.mk _ this)))) 60 | end short_five 61 | 62 | section short_exact 63 | open module_chain_complex 64 | variables {R : Ring} {N : succ_str} 65 | 66 | record is_short_exact_at (C : module_chain_complex R N) (n : N) := 67 | (is_contr_0 : is_contr (C n)) 68 | (is_exact_at_1 : is_exact_at_m C n) 69 | (is_exact_at_2 : is_exact_at_m C (S n)) 70 | (is_exact_at_3 : is_exact_at_m C (S (S n))) 71 | (is_contr_4 : is_contr (C (S (S (S (S n)))))) 72 | 73 | 74 | /- TODO: show that this gives rise to a short exact sequence in the sense above -/ 75 | end short_exact 76 | 77 | section short_five_redux 78 | open module_chain_complex 79 | variables {R : Ring} {N : succ_str} 80 | 81 | /- TODO: restate short five in these terms -/ 82 | end short_five_redux 83 | 84 | 85 | /- TODO: state and prove strong_four, adapting the template below. 86 | 87 | section strong_four 88 | variables {R : Type} [ring R] 89 | variables {A B C D A' B' C' D' : Type} 90 | variables [left_module R A] [left_module R B] [left_module R C] [left_module R D] 91 | variables [left_module R A'] [left_module R B'] [left_module R C'] [left_module R D'] 92 | 93 | variables (ρ : A → B) [is_module_hom R ρ] 94 | variables (σ : B → C) [is_module_hom R σ] 95 | variables (τ : C → D) [is_module_hom R τ] 96 | variable (chainρσ : ∀ a, σ (ρ a) = 0) 97 | variable (exactρσ : ∀ {b}, σ b = 0 → ∃ a, ρ a = b) 98 | variable (chainστ : ∀ b, τ (σ b) = 0) 99 | variable (exactστ : ∀ {c}, τ c = 0 → ∃ b, σ b = c) 100 | 101 | variables (ρ' : A' → B') [is_module_hom R ρ'] 102 | variables (σ' : B' → C') [is_module_hom R σ'] 103 | variables (τ' : C' → D') [is_module_hom R τ'] 104 | variable (chainρ'σ' : ∀ a', σ' (ρ' a') = 0) 105 | variable (exactρ'σ' : ∀ {b'}, σ' b' = 0 → ∃ a', ρ' a' = b') 106 | variable (chainσ'τ' : ∀ b', τ' (σ' b') = 0) 107 | variable (exactσ'τ' : ∀ {c'}, τ' c' = 0 → ∃ b', σ' b' = c') 108 | 109 | variables (α : A → A') [is_module_hom R α] 110 | variables (β : B → B') [is_module_hom R β] 111 | variables (γ : C → C') [is_module_hom R γ] 112 | variables (δ : D → D') [is_module_hom R δ] 113 | 114 | variables (sq₁ : comm_square ρ ρ' α β) 115 | variables (sq₂ : comm_square σ σ' β γ) 116 | variables (sq₃ : comm_square τ τ' γ δ) 117 | 118 | include sq₃ σ' sq₂ exactρ'σ' sq₁ chainρσ 119 | 120 | theorem strong_four_a (epiα : is_surjective α) (monoδ : is_embedding δ) (c : C) (γc0 : γ c = 0) : 121 | Σ b, (β b = 0 × σ b = c) := 122 | have δ (τ c) = 0, by rewrite [sq₃, γc0, hom_zero], 123 | have τ c = 0, from eq_zero_of_eq_zero_of_is_embedding this, 124 | obtain b (σbc : σ b = c), from exactστ this, 125 | have σ' (β b) = 0, by rewrite [-sq₂, σbc, γc0], 126 | obtain a' (ρ'a'βb : ρ' a' = β b), from exactρ'σ' this, 127 | obtain a (αaa' : α a = a'), from epiα a', 128 | exists.intro (b - ρ a) 129 | (pair 130 | (show β (b - ρ a) = 0, by rewrite [hom_sub, -ρ'a'βb, sq₁, αaa', sub_self]) 131 | (show σ (b - ρ a) = c, from calc 132 | σ (b - ρ a) = σ b - σ (ρ a) : hom_sub _ 133 | ... = σ b : by rewrite [chainρσ, sub_zero] 134 | ... = c : σbc)) 135 | 136 | end strong_four 137 | -/ 138 | -------------------------------------------------------------------------------- /algebra/spectral_sequence.hlean: -------------------------------------------------------------------------------- 1 | /- Spectral sequences 2 | - basic properties of spectral sequences 3 | - currently, we only construct an spectral sequence from an exact couple 4 | -/ 5 | 6 | -- Author: Floris van Doorn 7 | 8 | import .exact_couple 9 | 10 | open algebra is_trunc left_module is_equiv equiv eq function nat sigma set_quotient group 11 | left_module group int prod prod.ops 12 | open exact_couple (Z2) 13 | 14 | structure convergent_spectral_sequence.{u v w} {R : Ring} (E' : ℤ → ℤ → LeftModule.{u v} R) 15 | (Dinf : ℤ → LeftModule.{u w} R) : Type.{max u (v+1) (w+1)} := 16 | (E : ℕ → graded_module.{u 0 v} R Z2) 17 | (d : Π(r : ℕ), E r →gm E r) 18 | (deg_d : ℕ → Z2) 19 | (deg_d_eq0 : Π(r : ℕ), deg (d r) 0 = deg_d r) 20 | (α : Π(r : ℕ) (x : Z2), E (r+1) x ≃lm graded_homology (d r) (d r) x) 21 | (e : Π(x : Z2), E 0 x ≃lm E' x.1 x.2) 22 | (s₀ : Z2 → ℕ) 23 | (f : Π{r : ℕ} {x : Z2} (h : s₀ x ≤ r), E (s₀ x) x ≃lm E r x) 24 | (lb : ℤ → ℤ) 25 | (HDinf : Π(n : ℤ), is_built_from (Dinf n) 26 | (λ(k : ℕ), (λx, E (s₀ x) x) (n - (k + lb n), k + lb n))) 27 | /- todo: the current definition doesn't say that E (s₀ x) x is contractible for x.1 + x.2 = n and x.2 < lb n -/ 28 | 29 | definition convergent_spectral_sequence_g [reducible] (E' : ℤ → ℤ → AbGroup) 30 | (Dinf : ℤ → AbGroup) : Type := 31 | convergent_spectral_sequence (λn s, LeftModule_int_of_AbGroup (E' n s)) 32 | (λn, LeftModule_int_of_AbGroup (Dinf n)) 33 | 34 | section exact_couple 35 | open exact_couple exact_couple.exact_couple exact_couple.convergent_exact_couple 36 | exact_couple.convergence_theorem exact_couple.derived_couple 37 | 38 | definition convergent_spectral_sequence_of_exact_couple {R : Ring} {E' : ℤ → ℤ → LeftModule R} 39 | {Dinf : ℤ → LeftModule R} (c : convergent_exact_couple E' Dinf) 40 | (st_eq : Πn, (st c n).1 + (st c n).2 = n) (deg_i_eq : deg (i (X c)) 0 = (- 1, 1)) : 41 | convergent_spectral_sequence E' Dinf := 42 | convergent_spectral_sequence.mk (λr, E (page (X c) r)) (λr, d (page (X c) r)) 43 | (deg_d c) (deg_d_eq0 c) 44 | (λr ns, by reflexivity) (e c) (B3 (HH c)) (λr ns Hr, Einfstable (HH c) Hr idp) 45 | (λn, (st c n).2) 46 | begin 47 | intro n, 48 | refine is_built_from_isomorphism (f c n) _ (is_built_from_infpage (HH c) (st c n) (HB c n)), 49 | intro p, apply isomorphism_of_eq, apply ap (λx, E (page (X c) (B3 (HH c) x)) x), 50 | induction p with p IH, 51 | { exact !prod.eta⁻¹ ⬝ prod_eq (eq_sub_of_add_eq (ap (add _) !zero_add ⬝ st_eq n)) 52 | (zero_add (st c n).2)⁻¹ }, 53 | { assert H1 : Π(a : ℤ), n - (p + a) - 1 = n - (succ p + a), 54 | exact λa, !sub_add_eq_sub_sub⁻¹ ⬝ ap (sub n) (add_comm_middle p a 1 ⬝ proof idp qed), 55 | assert H2 : Π(a : ℤ), p + a + 1 = succ p + a, 56 | exact λa, add_comm_middle p a 1, 57 | refine ap (deg (i (X c))) IH ⬝ !deg_eq ⬝ ap (add _) deg_i_eq ⬝ prod_eq !H1 !H2 } 58 | end 59 | end exact_couple 60 | 61 | namespace spectral_sequence 62 | open convergent_spectral_sequence 63 | 64 | variables {R : Ring} {E' : ℤ → ℤ → LeftModule R} {Dinf : ℤ → LeftModule R} 65 | (c : convergent_spectral_sequence E' Dinf) 66 | 67 | -- (E : ℕ → graded_module.{u 0 v} R Z2) 68 | -- (d : Π(r : ℕ), E r →gm E r) 69 | -- (deg_d : ℕ → Z2) 70 | -- (deg_d_eq0 : Π(r : ℕ), deg (d r) 0 = deg_d r) 71 | -- (α : Π(r : ℕ) (x : Z2), E (r+1) x ≃lm graded_homology (d r) (d r) x) 72 | -- (e : Π(x : Z2), E 0 x ≃lm E' x.1 x.2) 73 | -- (s₀ : Z2 → ℕ) 74 | -- (f : Π{r : ℕ} {x : Z2} (h : s₀ x ≤ r), E (s₀ x) x ≃lm E r x) 75 | -- (lb : ℤ → ℤ) 76 | -- (HDinf : Π(n : ℤ), is_built_from (Dinf n) 77 | -- (λ(k : ℕ), (λx, E (s₀ x) x) (n - (k + lb n), k + lb n))) 78 | 79 | definition Einf (x : Z2) : LeftModule R := E c (s₀ c x) x 80 | 81 | definition is_contr_E_succ (r : ℕ) (x : Z2) (h : is_contr (E c r x)) : is_contr (E c (r+1) x) := 82 | is_contr_equiv_closed_rev (equiv_of_isomorphism (α c r x)) (is_contr_homology _ _ _) 83 | 84 | definition deg_d_eq (r : ℕ) (x : Z2) : deg (d c r) x = x + deg_d c r := 85 | !deg_eq ⬝ ap (add _) !deg_d_eq0 86 | 87 | definition deg_d_inv_eq (r : ℕ) (x : Z2) : (deg (d c r))⁻¹ᵉ x = x - deg_d c r := 88 | inv_eq_of_eq (!deg_d_eq ⬝ !neg_add_cancel_right)⁻¹ 89 | 90 | definition is_contr_E_of_le {r₁ r₂ : ℕ} (H : r₁ ≤ r₂) (x : Z2) (h : is_contr (E c r₁ x)) : 91 | is_contr (E c r₂ x) := 92 | begin 93 | induction H with r₂ H IH, 94 | { exact h }, 95 | { apply is_contr_E_succ, exact IH } 96 | end 97 | 98 | definition is_contr_E (r : ℕ) (x : Z2) (h : is_contr (E' x.1 x.2)) : is_contr (E c r x) := 99 | is_contr_E_of_le c !zero_le x (is_contr_equiv_closed_rev (equiv_of_isomorphism (e c x)) h) 100 | 101 | definition is_contr_Einf (x : Z2) (h : is_contr (E' x.1 x.2)) : is_contr (Einf c x) := 102 | is_contr_E c (s₀ c x) x h 103 | 104 | definition E_isomorphism {r₁ r₂ : ℕ} {ns : Z2} (H : r₁ ≤ r₂) 105 | (H1 : Π⦃r⦄, r₁ ≤ r → r < r₂ → is_contr (E c r (ns - deg_d c r))) 106 | (H2 : Π⦃r⦄, r₁ ≤ r → r < r₂ → is_contr (E c r (ns + deg_d c r))) : 107 | E c r₂ ns ≃lm E c r₁ ns := 108 | begin 109 | assert H3 : Π⦃r⦄, r₁ ≤ r → r ≤ r₂ → E c r ns ≃lm E c r₁ ns, 110 | { intro r Hr₁ Hr₂, 111 | induction Hr₁ with r Hr₁ IH, reflexivity, 112 | let Hr₂' := le_of_succ_le Hr₂, 113 | refine α c r ns ⬝lm homology_isomorphism _ _ _ _ ⬝lm IH Hr₂', 114 | exact is_contr_equiv_closed (equiv_ap (E c r) !deg_d_inv_eq⁻¹) (H1 Hr₁ Hr₂), 115 | exact is_contr_equiv_closed (equiv_ap (E c r) !deg_d_eq⁻¹) (H2 Hr₁ Hr₂) }, 116 | exact H3 H (le.refl _) 117 | end 118 | 119 | definition E_isomorphism0 {r : ℕ} {n s : ℤ} 120 | (H1 : Πr', r' < r → is_contr (E' (n - (deg_d c r').1) (s - (deg_d c r').2))) 121 | (H2 : Πr', r' < r → is_contr (E' (n + (deg_d c r').1) (s + (deg_d c r').2))) : 122 | E c r (n, s) ≃lm E' n s := 123 | E_isomorphism c !zero_le (λr' Hr₁ Hr₂, is_contr_E c r' _ (H1 r' Hr₂)) 124 | (λr' Hr₁ Hr₂, is_contr_E c r' _ (H2 r' Hr₂)) ⬝lm 125 | e c (n, s) 126 | 127 | definition Einf_isomorphism (r₁ : ℕ) {ns : Z2} 128 | (H1 : Π⦃r⦄, r₁ ≤ r → is_contr (E c r (ns - deg_d c r))) 129 | (H2 : Π⦃r⦄, r₁ ≤ r → is_contr (E c r (ns + deg_d c r))) : 130 | Einf c ns ≃lm E c r₁ ns := 131 | begin 132 | cases le.total r₁ (s₀ c ns) with Hr Hr, 133 | exact E_isomorphism c Hr (λr Hr₁ Hr₂, H1 Hr₁) (λr Hr₁ Hr₂, H2 Hr₁), 134 | exact f c Hr 135 | end 136 | 137 | definition Einf_isomorphism0 {n s : ℤ} 138 | (H1 : Πr, is_contr (E' (n - (deg_d c r).1) (s - (deg_d c r).2))) 139 | (H2 : Πr, is_contr (E' (n + (deg_d c r).1) (s + (deg_d c r).2))) : 140 | Einf c (n, s) ≃lm E' n s := 141 | E_isomorphism0 c (λr Hr, H1 r) (λr Hr, H2 r) 142 | 143 | definition convergence_0 (n : ℤ) (H : Πm, lb c m = 0) : 144 | is_built_from (Dinf n) (λ(k : ℕ), Einf c (n - k, k)) := 145 | is_built_from_isomorphism isomorphism.rfl 146 | (λk, left_module.isomorphism_of_eq (ap (Einf c) 147 | (prod_eq (ap (sub n) (ap (add _) !H ⬝ add_zero _)) (ap (add _) !H ⬝ add_zero _)))) 148 | (HDinf c n) 149 | 150 | /- we call a spectral sequence normal if it is a first-quadrant spectral sequence and 151 | the degree of d on page r (for r ≥ 2) is (r, -(r-1)). 152 | The indexing is different, because we start counting pages at 2. -/ 153 | include c 154 | structure is_normal : Type := 155 | (normal1 : Π{n} s, n < 0 → is_contr (E' n s)) 156 | (normal2 : Πn {s}, s < 0 → is_contr (E' n s)) 157 | (normal3 : Π(r : ℕ), deg_d c r = (r+2, -(r+1))) 158 | open is_normal 159 | variable {c} 160 | variable (nc : is_normal c) 161 | include nc 162 | 163 | definition deg_d_normal_pr1 (r : ℕ) : (deg_d c r).1 = r+2 := ap pr1 (normal3 nc r) 164 | definition deg_d_normal_pr2 (r : ℕ) : (deg_d c r).2 = -(r+1) := ap pr2 (normal3 nc r) 165 | 166 | definition stable_range {n s : ℤ} {r : ℕ} (H1 : n < r + 2) (H2 : s < r + 1) : 167 | Einf c (n, s) ≃lm E c r (n, s) := 168 | begin 169 | fapply Einf_isomorphism, 170 | { intro r' Hr', apply is_contr_E, apply normal1 nc, 171 | refine lt_of_le_of_lt (le_of_eq (ap (λx, n - x.1) (normal3 nc r'))) _, 172 | apply sub_lt_left_of_lt_add, 173 | refine lt_of_lt_of_le H1 (le.trans _ (le_of_eq !add_zero⁻¹)), 174 | exact add_le_add_right (of_nat_le_of_nat_of_le Hr') 2 }, 175 | { intro r' Hr', apply is_contr_E, apply normal2 nc, 176 | refine lt_of_le_of_lt (le_of_eq (ap (λx, s + x.2) (normal3 nc r'))) _, 177 | change s - (r' + 1) < 0, 178 | apply sub_lt_left_of_lt_add, 179 | refine lt_of_lt_of_le H2 (le.trans _ (le_of_eq !add_zero⁻¹)), 180 | exact add_le_add_right (of_nat_le_of_nat_of_le Hr') 1 }, 181 | end 182 | 183 | definition deg_d_normal_eq (r : ℕ) (x : Z2) : deg (d c r) x = x + (r+2, -(r+1)) := 184 | deg_d_eq c r x ⬝ ap (add x) (is_normal.normal3 nc r) 185 | 186 | omit nc 187 | 188 | 189 | end spectral_sequence 190 | -------------------------------------------------------------------------------- /algebra/splice.hlean: -------------------------------------------------------------------------------- 1 | /- 2 | Copyright (c) 2016 Floris van Doorn. All rights reserved. 3 | Released under Apache 2.0 license as described in the file LICENSE. 4 | 5 | Authors: Floris van Doorn 6 | 7 | Given a sequence of LES's, we want to splice them together. 8 | ... -> G_{1,k+1} -> G_{1,k} -> ... -> G_{1,1} -> G_{1,0} 9 | ... -> G_{2,k+1} -> G_{2,k} -> ... -> G_{2,1} -> G_{2,0} 10 | ... 11 | ... -> G_{n,k+1} -> G_{n,k} -> ... -> G_{n,1} -> G_{n,0} 12 | ... 13 | 14 | If we have equivalences: 15 | G_{n,m) = G_{n+1,m+k} 16 | G_{n,m+1) = G_{n+1,m+k+1} 17 | such that the evident squares commute, we can obtain a single sequence 18 | 19 | ... -> G_{n,m} -> G_{n+1,m+k-1} -> ... -> G_{n+1,m} -> G_{n+2,m+k-1} -> ... 20 | 21 | However, in this formalization, we will only do this for k = 3, because we get more definitional 22 | equalities in this specific case than in the general case. The reason is that we need to check 23 | whether a term `x : fin (succ k)` represents `k`. If we do this in general using 24 | if x = k then ... else ... 25 | we don't get definitionally that x = k and the successor of x is 0, which means that when defining 26 | maps G_{n,m} -> G_{n+1,m+k-1} we need to transport along those paths, which is annoying. 27 | 28 | So far, the splicing seems to be only needed for k = 3, so it seems to be sufficient. 29 | 30 | -/ 31 | 32 | import homotopy.chain_complex 33 | 34 | open prod prod.ops succ_str fin pointed nat algebra eq is_trunc equiv is_equiv 35 | 36 | /- fin -/ 37 | 38 | -- definition cyclic_pred {n : ℕ} (x : fin n) : fin n := 39 | -- begin 40 | -- cases n with n, 41 | -- { exfalso, apply not_lt_zero _ (is_lt x)}, 42 | -- { cases x with m H, cases m with m, 43 | -- { exact fin.mk n !self_lt_succ}, 44 | -- { apply fin.mk m, exact lt.trans !self_lt_succ H}} 45 | -- end 46 | 47 | -- definition stratified_succ2 {N : succ_str} {n : ℕ} (x : stratified_type N n) 48 | -- : stratified_type N n := 49 | -- (nat.cases_on (pr2 x) (S (pr1 x)) (λa, pr1 x), cyclic_pred (pr2 x)) 50 | 51 | -- definition stratified2 [reducible] [constructor] (N : succ_str) (n : ℕ) : succ_str := 52 | -- succ_str.mk (stratified_type N n) stratified_succ2 53 | 54 | 55 | namespace chain_complex 56 | 57 | definition stratified_succ_max {N : succ_str} {n : ℕ} (x : stratified N n) (p : val (pr2 x) = n) 58 | : S x = (S (pr1 x), 0) := 59 | begin 60 | unfold [stratified, succ_str.S, stratified_succ], 61 | apply prod_eq, 62 | { exact if_pos p}, 63 | { exact dif_pos p} 64 | end 65 | 66 | definition splice_type [unfold 5] {N M : succ_str} (G : N → chain_complex M) (m : M) 67 | (x : stratified N 2) : Set* := 68 | G x.1 (m +' val x.2) 69 | 70 | definition splice_map {N M : succ_str} (G : N → chain_complex M) (m : M) 71 | (e0 : Πn, G (S n) m ≃* G n (m +' 3)) : 72 | Π(x : stratified N 2), splice_type G m (S x) →* splice_type G m x 73 | | (n, fin.mk 0 H) := proof cc_to_fn (G n) m qed 74 | | (n, fin.mk 1 H) := proof cc_to_fn (G n) (S m) qed 75 | | (n, fin.mk 2 H) := proof cc_to_fn (G n) (S (S m)) ∘* e0 n qed 76 | | (n, fin.mk (k+3) H) := begin exfalso, apply lt_le_antisymm H, apply le_add_left end 77 | 78 | definition is_chain_complex_splice_map {N M : succ_str} (G : N → chain_complex M) (m : M) 79 | (e0 : Πn, G (S n) m ≃* G n (m +' 3)) (e1 : Πn, G (S n) (S m) ≃* G n (S (m +' 3))) 80 | (p : Πn, e0 n ∘* cc_to_fn (G (S n)) m ~ cc_to_fn (G n) (m +' 3) ∘* e1 n) : 81 | Π(x : stratified N 2) (y : splice_type G m (S (S x))), 82 | splice_map G m e0 x (splice_map G m e0 (S x) y) = pt 83 | | (n, fin.mk 0 H) y := proof cc_is_chain_complex (G n) m y qed 84 | | (n, fin.mk 1 H) y := proof cc_is_chain_complex (G n) (S m) (e0 n y) qed 85 | | (n, fin.mk 2 H) y := proof ap (cc_to_fn (G n) (S (S m))) (p n y) ⬝ 86 | cc_is_chain_complex (G n) (S (S m)) (e1 n y) qed 87 | | (n, fin.mk (k+3) H) y := begin exfalso, apply lt_le_antisymm H, apply le_add_left end 88 | 89 | definition splice [constructor] {N M : succ_str} (G : N → chain_complex M) (m : M) 90 | (e0 : Πn, G (S n) m ≃* G n (m +' 3)) (e1 : Πn, G (S n) (S m) ≃* G n (S (m +' 3))) 91 | (p : Πn, e0 n ∘* cc_to_fn (G (S n)) m ~ cc_to_fn (G n) (m +' 3) ∘* e1 n) : 92 | chain_complex (stratified N 2) := 93 | chain_complex.mk (splice_type G m) (splice_map G m e0) (is_chain_complex_splice_map G m e0 e1 p) 94 | 95 | definition is_exact_splice {N M : succ_str} (G : N → chain_complex M) (m : M) 96 | (e0 : Πn, G (S n) m ≃* G n (m +' 3)) (e1 : Πn, G (S n) (S m) ≃* G n (S (m +' 3))) 97 | (p : Πn, e0 n ∘* cc_to_fn (G (S n)) m ~ cc_to_fn (G n) (m +' 3) ∘* e1 n) 98 | (H2 : Πn, is_exact (G n)) : Π(x : stratified N 2), is_exact_at (splice G m e0 e1 p) x 99 | | (n, fin.mk 0 H) := proof H2 n m qed 100 | | (n, fin.mk 1 H) := begin intro y q, induction H2 n (S m) proof y qed proof q qed with x r, 101 | apply image.mk ((e0 n)⁻¹ᵉ x), 102 | exact ap (pmap.to_fun (cc_to_fn (G n) (S (S m)))) (to_right_inv (e0 n) x) ⬝ r end 103 | | (n, fin.mk 2 H) := 104 | begin intro y q, induction H2 n (S (S m)) proof e0 n y qed proof q qed with x r, 105 | apply image.mk ((e1 n)⁻¹ᵉ x), 106 | refine _ ⬝ to_left_inv (e0 n) y, refine _ ⬝ ap (e0 n)⁻¹ᵉ r, apply @eq_inv_of_eq _ _ (e0 n), 107 | refine p n ((e1 n)⁻¹ᵉ x) ⬝ _, apply ap (cc_to_fn (G n) (m +' 3)), exact to_right_inv (e1 n) x 108 | end 109 | | (n, fin.mk (k+3) H) := begin exfalso, apply lt_le_antisymm H, apply le_add_left end 110 | 111 | 112 | end chain_complex 113 | -------------------------------------------------------------------------------- /algebra/tensor.hlean: -------------------------------------------------------------------------------- 1 | /- 2 | Copyright (c) 2015 Floris van Doorn. All rights reserved. 3 | Released under Apache 2.0 license as described in the file LICENSE. 4 | Authors: Floris van Doorn, Egbert Rijke 5 | 6 | Tensor group 7 | -/ 8 | 9 | import .free_abelian_group 10 | 11 | open eq algebra is_trunc sigma sigma.ops prod trunc function equiv 12 | namespace group 13 | 14 | variables {G G' : Group} {g g' h h' k : G} {A B : AbGroup} 15 | 16 | /- Tensor group (WIP) -/ 17 | 18 | /- namespace tensor_group 19 | variables {A B} 20 | local abbreviation ι := @free_ab_group_inclusion 21 | 22 | inductive tensor_rel_type : free_ab_group (Set_of_Group A ×t Set_of_Group B) → Type := 23 | | mul_left : Π(a₁ a₂ : A) (b : B), tensor_rel_type (ι (a₁, b) * ι (a₂, b) * (ι (a₁ * a₂, b))⁻¹) 24 | | mul_right : Π(a : A) (b₁ b₂ : B), tensor_rel_type (ι (a, b₁) * ι (a, b₂) * (ι (a, b₁ * b₂))⁻¹) 25 | 26 | open tensor_rel_type 27 | 28 | definition tensor_rel' (x : free_ab_group (Set_of_Group A ×t Set_of_Group B)) : Prop := 29 | ∥ tensor_rel_type x ∥ 30 | 31 | definition tensor_group_rel (A B : AbGroup) 32 | : normal_subgroup_rel (free_ab_group (Set_of_Group A ×t Set_of_Group B)) := 33 | sorry /- relation generated by tensor_rel'-/ 34 | 35 | definition tensor_group [constructor] : AbGroup := 36 | quotient_ab_group (tensor_group_rel A B) 37 | 38 | end tensor_group-/ 39 | 40 | end group 41 | -------------------------------------------------------------------------------- /archive/smash_old.hlean: -------------------------------------------------------------------------------- 1 | /- below are some old tries to compute (A ∧ S¹) directly -/ 2 | 3 | exit 4 | 5 | /- smash A S¹ = red_susp A -/ 6 | 7 | definition red_susp_of_smash_pcircle [unfold 2] (x : smash A S¹*) : red_susp A := 8 | begin 9 | induction x using smash.elim, 10 | { induction b, exact base, exact equator a }, 11 | { exact base }, 12 | { exact base }, 13 | { reflexivity }, 14 | { exact circle_elim_constant equator_pt b } 15 | end 16 | 17 | definition smash_pcircle_of_red_susp [unfold 2] (x : red_susp A) : smash A S¹* := 18 | begin 19 | induction x, 20 | { exact pt }, 21 | { exact gluel' pt a ⬝ ap (smash.mk a) loop ⬝ gluel' a pt }, 22 | { refine !con.right_inv ◾ _ ◾ !con.right_inv, 23 | exact ap_is_constant gluer loop ⬝ !con.right_inv } 24 | end 25 | 26 | definition smash_pcircle_of_red_susp_of_smash_pcircle_pt [unfold 3] (a : A) (x : S¹*) : 27 | smash_pcircle_of_red_susp (red_susp_of_smash_pcircle (smash.mk a x)) = smash.mk a x := 28 | begin 29 | induction x, 30 | { exact gluel' pt a }, 31 | { exact abstract begin apply eq_pathover, 32 | refine ap_compose smash_pcircle_of_red_susp _ _ ⬝ph _, 33 | refine ap02 _ (elim_loop pt (equator a)) ⬝ !elim_equator ⬝ph _, 34 | -- make everything below this a lemma defined by path induction? 35 | refine !con_idp⁻¹ ⬝pv _, refine !con.assoc⁻¹ ⬝ph _, apply whisker_bl, apply whisker_lb, 36 | apply whisker_tl, apply hrfl end end } 37 | end 38 | 39 | definition concat2o [unfold 10] {A B : Type} {f g h : A → B} {q : f ~ g} {r : g ~ h} {a a' : A} 40 | {p : a = a'} (s : q a =[p] q a') (t : r a =[p] r a') : q a ⬝ r a =[p] q a' ⬝ r a' := 41 | by induction p; exact idpo 42 | 43 | definition apd_con_fn [unfold 10] {A B : Type} {f g h : A → B} {q : f ~ g} {r : g ~ h} {a a' : A} 44 | (p : a = a') : apd (λa, q a ⬝ r a) p = concat2o (apd q p) (apd r p) := 45 | by induction p; reflexivity 46 | 47 | -- definition apd_con_fn_constant [unfold 10] {A B : Type} {f : A → B} {b b' : B} {q : Πa, f a = b} 48 | -- {r : b = b'} {a a' : A} (p : a = a') : 49 | -- apd (λa, q a ⬝ r) p = concat2o (apd q p) (pathover_of_eq _ idp) := 50 | -- by induction p; reflexivity 51 | 52 | 53 | definition smash_pcircle_pequiv_red [constructor] (A : Type*) : smash A S¹* ≃* red_susp A := 54 | begin 55 | fapply pequiv_of_equiv, 56 | { fapply equiv.MK, 57 | { exact red_susp_of_smash_pcircle }, 58 | { exact smash_pcircle_of_red_susp }, 59 | { exact abstract begin intro x, induction x, 60 | { reflexivity }, 61 | { apply eq_pathover, apply hdeg_square, 62 | refine ap_compose red_susp_of_smash_pcircle _ _ ⬝ ap02 _ !elim_equator ⬝ _ ⬝ !ap_id⁻¹, 63 | refine !ap_con ⬝ (!ap_con ⬝ !elim_gluel' ◾ !ap_compose'⁻¹) ◾ !elim_gluel' ⬝ _, 64 | esimp, exact !idp_con ⬝ !elim_loop }, 65 | { exact sorry } end end }, 66 | { intro x, induction x, 67 | { exact smash_pcircle_of_red_susp_of_smash_pcircle_pt a b }, 68 | { exact gluel pt }, 69 | { exact gluer pt }, 70 | { apply eq_pathover_id_right, 71 | refine ap_compose smash_pcircle_of_red_susp _ _ ⬝ph _, 72 | unfold [red_susp_of_smash_pcircle], 73 | refine ap02 _ !elim_gluel ⬝ph _, 74 | esimp, apply whisker_rt, exact vrfl }, 75 | { apply eq_pathover_id_right, 76 | refine ap_compose smash_pcircle_of_red_susp _ _ ⬝ph _, 77 | unfold [red_susp_of_smash_pcircle], 78 | -- not sure why so many implicit arguments are needed here... 79 | refine ap02 _ (@smash.elim_gluer A S¹* _ (λa, circle.elim red_susp.base (equator a)) red_susp.base red_susp.base (λa, refl red_susp.base) (circle_elim_constant equator_pt) b) ⬝ph _, 80 | apply square_of_eq, induction b, 81 | { exact whisker_right _ !con.right_inv }, 82 | { apply eq_pathover_dep, refine !apd_con_fn ⬝pho _ ⬝hop !apd_con_fn⁻¹, 83 | refine ap (λx, concat2o x _) !rec_loop ⬝pho _ ⬝hop (ap011 concat2o (apd_compose1 (λa b, ap smash_pcircle_of_red_susp b) (circle_elim_constant equator_pt) loop) !apd_constant')⁻¹, 84 | exact sorry } 85 | 86 | }}}, 87 | { reflexivity } 88 | end 89 | 90 | /- smash A S¹ = susp A -/ 91 | open susp 92 | 93 | 94 | definition susp_of_smash_pcircle [unfold 2] (x : smash A S¹*) : susp A := 95 | begin 96 | induction x using smash.elim, 97 | { induction b, exact pt, exact merid a ⬝ (merid pt)⁻¹ }, 98 | { exact pt }, 99 | { exact pt }, 100 | { reflexivity }, 101 | { induction b, reflexivity, apply eq_pathover_constant_right, apply hdeg_square, 102 | exact !elim_loop ⬝ !con.right_inv } 103 | end 104 | 105 | definition smash_pcircle_of_susp [unfold 2] (x : susp A) : smash A S¹* := 106 | begin 107 | induction x, 108 | { exact pt }, 109 | { exact pt }, 110 | { exact gluel' pt a ⬝ (ap (smash.mk a) loop ⬝ gluel' a pt) }, 111 | end 112 | 113 | -- the definitions below compile, but take a long time to do so and have sorry's in them 114 | definition smash_pcircle_of_susp_of_smash_pcircle_pt [unfold 3] (a : A) (x : S¹*) : 115 | smash_pcircle_of_susp (susp_of_smash_pcircle (smash.mk a x)) = smash.mk a x := 116 | begin 117 | induction x, 118 | { exact gluel' pt a }, 119 | { exact abstract begin apply eq_pathover, 120 | refine ap_compose smash_pcircle_of_susp _ _ ⬝ph _, 121 | refine ap02 _ (elim_loop north (merid a ⬝ (merid pt)⁻¹)) ⬝ph _, 122 | refine !ap_con ⬝ (!elim_merid ◾ (!ap_inv ⬝ !elim_merid⁻²)) ⬝ph _, 123 | -- make everything below this a lemma defined by path induction? 124 | exact sorry, 125 | -- refine !con_idp⁻¹ ⬝pv _, apply whisker_tl, refine !con.assoc⁻¹ ⬝ph _, 126 | -- apply whisker_bl, apply whisker_lb, 127 | -- refine !con_idp⁻¹ ⬝pv _, apply whisker_tl, apply hrfl 128 | -- refine !con_idp⁻¹ ⬝pv _, apply whisker_tl, 129 | -- refine !con.assoc⁻¹ ⬝ph _, apply whisker_bl, apply whisker_lb, apply hrfl 130 | -- apply square_of_eq, rewrite [+con.assoc], apply whisker_left, apply whisker_left, 131 | -- symmetry, apply con_eq_of_eq_inv_con, esimp, apply con_eq_of_eq_con_inv, 132 | -- refine _⁻² ⬝ !con_inv, refine _ ⬝ !con.assoc, 133 | -- refine _ ⬝ whisker_right _ !inv_con_cancel_right⁻¹, refine _ ⬝ !con.right_inv⁻¹, 134 | -- refine !con.right_inv ◾ _, refine _ ◾ !con.right_inv, 135 | -- refine !ap_mk_right ⬝ !con.right_inv 136 | end end } 137 | end 138 | 139 | -- definition smash_pcircle_of_susp_of_smash_pcircle_gluer_base (b : S¹*) 140 | -- : square (smash_pcircle_of_susp_of_smash_pcircle_pt (Point A) b) 141 | -- (gluer pt) 142 | -- (ap smash_pcircle_of_susp (ap (λ a, susp_of_smash_pcircle a) (gluer b))) 143 | -- (gluer b) := 144 | -- begin 145 | -- refine ap02 _ !elim_gluer ⬝ph _, 146 | -- induction b, 147 | -- { apply square_of_eq, exact whisker_right _ !con.right_inv }, 148 | -- { apply square_pathover', exact sorry } 149 | -- end 150 | 151 | exit 152 | definition smash_pcircle_pequiv [constructor] (A : Type*) : smash A S¹* ≃* susp A := 153 | begin 154 | fapply pequiv_of_equiv, 155 | { fapply equiv.MK, 156 | { exact susp_of_smash_pcircle }, 157 | { exact smash_pcircle_of_susp }, 158 | { exact abstract begin intro x, induction x, 159 | { reflexivity }, 160 | { exact merid pt }, 161 | { apply eq_pathover_id_right, 162 | refine ap_compose susp_of_smash_pcircle _ _ ⬝ph _, 163 | refine ap02 _ !elim_merid ⬝ph _, 164 | rewrite [↑gluel', +ap_con, +ap_inv, -ap_compose'], 165 | refine (_ ◾ _⁻² ◾ _ ◾ (_ ◾ _⁻²)) ⬝ph _, 166 | rotate 5, do 2 (unfold [susp_of_smash_pcircle]; apply elim_gluel), 167 | esimp, apply elim_loop, do 2 (unfold [susp_of_smash_pcircle]; apply elim_gluel), 168 | refine idp_con (merid a ⬝ (merid (Point A))⁻¹) ⬝ph _, 169 | apply square_of_eq, refine !idp_con ⬝ _⁻¹, apply inv_con_cancel_right } end end }, 170 | { intro x, induction x using smash.rec, 171 | { exact smash_pcircle_of_susp_of_smash_pcircle_pt a b }, 172 | { exact gluel pt }, 173 | { exact gluer pt }, 174 | { apply eq_pathover_id_right, 175 | refine ap_compose smash_pcircle_of_susp _ _ ⬝ph _, 176 | unfold [susp_of_smash_pcircle], 177 | refine ap02 _ !elim_gluel ⬝ph _, 178 | esimp, apply whisker_rt, exact vrfl }, 179 | { apply eq_pathover_id_right, 180 | refine ap_compose smash_pcircle_of_susp _ _ ⬝ph _, 181 | unfold [susp_of_smash_pcircle], 182 | refine ap02 _ !elim_gluer ⬝ph _, 183 | induction b, 184 | { apply square_of_eq, exact whisker_right _ !con.right_inv }, 185 | { exact sorry} 186 | }}}, 187 | { reflexivity } 188 | end 189 | 190 | end smash 191 | -------------------------------------------------------------------------------- /choice.hlean: -------------------------------------------------------------------------------- 1 | import types.trunc types.sum types.lift types.unit 2 | 3 | open pi prod sum unit bool trunc is_trunc is_equiv eq equiv lift pointed 4 | 5 | namespace choice 6 | universe variables u v 7 | 8 | -- the following brilliant name is from Agda 9 | definition unchoose [unfold 4] (n : ℕ₋₂) {X : Type} (A : X → Type) : trunc n (Πx, A x) → Πx, trunc n (A x) := 10 | trunc.elim (λf x, tr (f x)) 11 | 12 | definition has_choice [class] (n : ℕ₋₂) (X : Type.{u}) : Type.{max u (v+1)} := 13 | Π(A : X → Type.{v}), is_equiv (unchoose n A) 14 | 15 | definition choice_equiv [constructor] {n : ℕ₋₂} {X : Type} [H : has_choice.{u v} n X] 16 | (A : X → Type) : trunc n (Πx, A x) ≃ (Πx, trunc n (A x)) := 17 | equiv.mk _ (H A) 18 | 19 | definition has_choice_of_succ (X : Type) (H : Πk, has_choice.{_ v} (k.+1) X) (n : ℕ₋₂) : 20 | has_choice.{_ v} n X := 21 | begin 22 | cases n with n, 23 | { intro A, exact is_equiv_of_is_contr _ _ _ }, 24 | { exact H n } 25 | end 26 | 27 | /- currently we prove it using univalence, which means we cannot apply it to lift. -/ 28 | definition has_choice_equiv_closed (n : ℕ₋₂) {A B : Type} (f : A ≃ B) (hA : has_choice.{u v} n B) 29 | : has_choice.{u v} n A := 30 | begin 31 | induction f using rec_on_ua_idp, exact hA 32 | end 33 | 34 | definition has_choice_empty [instance] (n : ℕ₋₂) : has_choice.{_ v} n empty := 35 | begin 36 | intro A, fapply adjointify, 37 | { intro f, apply tr, intro x, induction x }, 38 | { intro f, apply eq_of_homotopy, intro x, induction x }, 39 | { intro g, induction g with g, apply ap tr, apply eq_of_homotopy, intro x, induction x } 40 | end 41 | 42 | definition has_choice_unit [instance] : Πn, has_choice.{_ v} n unit := 43 | begin 44 | intro n A, fapply adjointify, 45 | { intro f, induction f ⋆ with a, apply tr, intro u, induction u, exact a }, 46 | { intro f, apply eq_of_homotopy, intro u, induction u, esimp, generalize f ⋆, intro a, 47 | induction a, reflexivity }, 48 | { intro g, induction g with g, apply ap tr, apply eq_of_homotopy, 49 | intro u, induction u, reflexivity } 50 | end 51 | 52 | definition has_choice_sum [instance] (n : ℕ₋₂) (A B : Type.{u}) 53 | [has_choice.{_ v} n A] [has_choice.{_ v} n B] : has_choice.{_ v} n (A ⊎ B) := 54 | begin 55 | intro P, fapply is_equiv_of_equiv_of_homotopy, 56 | { exact calc 57 | trunc n (Πx, P x) ≃ trunc n ((Πa, P (inl a)) × Πb, P (inr b)) 58 | : trunc_equiv_trunc n !equiv_sum_rec⁻¹ᵉ 59 | ... ≃ trunc n (Πa, P (inl a)) × trunc n (Πb, P (inr b)) : trunc_prod_equiv 60 | ... ≃ (Πa, trunc n (P (inl a))) × Πb, trunc n (P (inr b)) 61 | : by exact prod_equiv_prod (choice_equiv _) (choice_equiv _) 62 | ... ≃ Πx, trunc n (P x) : equiv_sum_rec }, 63 | { intro f, induction f, apply eq_of_homotopy, intro x, esimp, induction x with a b: reflexivity } 64 | end 65 | 66 | definition has_choice_bool [instance] (n : ℕ₋₂) : has_choice.{_ v} n bool := 67 | has_choice_equiv_closed n bool_equiv_unit_sum_unit _ 68 | 69 | definition has_choice_lift.{u'} [instance] (n : ℕ₋₂) (A : Type) [has_choice.{_ v} n A] : 70 | has_choice.{_ v} n (lift.{u u'} A) := 71 | sorry --has_choice_equiv_closed n !equiv_lift⁻¹ᵉ _ 72 | 73 | definition has_choice_punit [instance] (n : ℕ₋₂) : has_choice.{_ v} n punit := has_choice_unit n 74 | definition has_choice_pbool [instance] (n : ℕ₋₂) : has_choice.{_ v} n pbool := has_choice_bool n 75 | definition has_choice_plift [instance] (n : ℕ₋₂) (A : Type*) [has_choice.{_ v} n A] 76 | : has_choice.{_ v} n (plift A) := has_choice_lift n A 77 | definition has_choice_psum [instance] (n : ℕ₋₂) (A B : Type*) [has_choice.{_ v} n A] [has_choice.{_ v} n B] 78 | : has_choice.{_ v} n (psum A B) := has_choice_sum n A B 79 | 80 | end choice 81 | -------------------------------------------------------------------------------- /cohomology/cofiber_sequence.hlean: -------------------------------------------------------------------------------- 1 | /- 2 | Copyright (c) 2017 Floris van Doorn. All rights reserved. 3 | Released under Apache 2.0 license as described in the file LICENSE. 4 | Authors: Floris van Doorn 5 | 6 | Cofiber sequence of a pointed map 7 | -/ 8 | 9 | import .basic ..homotopy.pushout 10 | 11 | open pointed eq cohomology sigma sigma.ops fiber cofiber chain_complex nat succ_str algebra prod group pushout int 12 | 13 | namespace cohomology 14 | 15 | definition pred_fun {A : ℕ → Type*} (f : Πn, A n →* A (n+1)) (n : ℕ) : A (pred n) →* A n := 16 | begin cases n with n, exact pconst (A 0) (A 0), exact f n end 17 | 18 | definition type_chain_complex_snat' [constructor] (A : ℕ → Type*) (f : Πn, A n →* A (n+1)) 19 | (p : Πn (x : A n), f (n+1) (f n x) = pt) : type_chain_complex -ℕ := 20 | type_chain_complex.mk A (pred_fun f) 21 | begin 22 | intro n, cases n with n, intro x, reflexivity, cases n with n, 23 | intro x, exact respect_pt (f 0), exact p n 24 | end 25 | 26 | definition chain_complex_snat' [constructor] (A : ℕ → Set*) (f : Πn, A n →* A (n+1)) 27 | (p : Πn (x : A n), f (n+1) (f n x) = pt) : chain_complex -ℕ := 28 | chain_complex.mk A (pred_fun f) 29 | begin 30 | intro n, cases n with n, intro x, reflexivity, cases n with n, 31 | intro x, exact respect_pt (f 0), exact p n 32 | end 33 | 34 | definition is_exact_at_t_snat' [constructor] {A : ℕ → Type*} (f : Πn, A n →* A (n+1)) 35 | (p : Πn (x : A n), f (n+1) (f n x) = pt) (q : Πn x, f (n+1) x = pt → fiber (f n) x) (n : ℕ) 36 | : is_exact_at_t (type_chain_complex_snat' A f p) (n+2) := 37 | q n 38 | 39 | definition cofiber_sequence_helper [constructor] (v : Σ(X Y : Type*), X →* Y) 40 | : Σ(Y Z : Type*), Y →* Z := 41 | ⟨v.2.1, pcofiber v.2.2, pcod v.2.2⟩ 42 | 43 | definition cofiber_sequence_helpern (v : Σ(X Y : Type*), X →* Y) (n : ℕ) 44 | : Σ(Z X : Type*), Z →* X := 45 | iterate cofiber_sequence_helper n v 46 | 47 | section 48 | universe variable u 49 | parameters {X Y : pType.{u}} (f : X →* Y) 50 | include f 51 | 52 | definition cofiber_sequence_carrier (n : ℕ) : Type* := 53 | (cofiber_sequence_helpern ⟨X, Y, f⟩ n).1 54 | 55 | definition cofiber_sequence_fun (n : ℕ) 56 | : cofiber_sequence_carrier n →* cofiber_sequence_carrier (n+1) := 57 | (cofiber_sequence_helpern ⟨X, Y, f⟩ n).2.2 58 | 59 | definition cofiber_sequence : type_chain_complex.{0 u} -ℕ := 60 | begin 61 | fapply type_chain_complex_snat', 62 | { exact cofiber_sequence_carrier }, 63 | { exact cofiber_sequence_fun }, 64 | { intro n x, exact pcod_pcompose (cofiber_sequence_fun n) x } 65 | end 66 | 67 | end 68 | 69 | section 70 | universe variable u 71 | parameters {X Y : pType.{u}} (f : X →* Y) (H : cohomology_theory.{u}) 72 | include f 73 | 74 | definition cohomology_groups [reducible] : -3ℤ → AbGroup 75 | | (n, fin.mk 0 p) := H n X 76 | | (n, fin.mk 1 p) := H n Y 77 | | (n, fin.mk k p) := H n (pcofiber f) 78 | 79 | -- definition cohomology_groups_pequiv_loop_spaces2 [reducible] 80 | -- : Π(n : -3ℤ), ptrunc 0 (loop_spaces2 n) ≃* cohomology_groups n 81 | -- | (n, fin.mk 0 p) := by reflexivity 82 | -- | (n, fin.mk 1 p) := by reflexivity 83 | -- | (n, fin.mk 2 p) := by reflexivity 84 | -- | (n, fin.mk (k+3) p) := begin exfalso, apply lt_le_antisymm H, apply le_add_left end 85 | 86 | definition coboundary (n : ℤ) : H (pred n) X →g H n (pcofiber f) := 87 | H ^→ n (pcofiber_pcod f ∘* pcod (pcod f)) ∘g (Hsusp_neg H n X)⁻¹ᵍ 88 | 89 | definition cohomology_groups_fun : Π(n : -3ℤ), cohomology_groups (S n) →g cohomology_groups n 90 | | (n, fin.mk 0 p) := proof H ^→ n f qed 91 | | (n, fin.mk 1 p) := proof H ^→ n (pcod f) qed 92 | | (n, fin.mk 2 p) := proof coboundary n qed 93 | | (n, fin.mk (k+3) p) := begin exfalso, apply lt_le_antisymm p, apply le_add_left end 94 | 95 | -- definition cohomology_groups_fun_pcohomology_loop_spaces_fun2 [reducible] 96 | -- : Π(n : -3ℤ), cohomology_groups_pequiv_loop_spaces2 n ∘* ptrunc_functor 0 (loop_spaces_fun2 n) ~* 97 | -- cohomology_groups_fun n ∘* cohomology_groups_pequiv_loop_spaces2 (S n) 98 | -- | (n, fin.mk 0 p) := by reflexivity 99 | -- | (n, fin.mk 1 p) := by reflexivity 100 | -- | (n, fin.mk 2 p) := 101 | -- begin 102 | -- refine !pid_pcompose ⬝* _ ⬝* !pcompose_pid⁻¹*, 103 | -- refine !ptrunc_functor_pcompose 104 | -- end 105 | -- | (n, fin.mk (k+3) p) := begin exfalso, apply lt_le_antisymm H, apply le_add_left end 106 | 107 | open cohomology_theory 108 | 109 | definition cohomology_groups_chain_0 (n : ℤ) (x : H n (pcofiber f)) : H ^→ n f (H ^→ n (pcod f) x) = 1 := 110 | begin 111 | refine (Hcompose H n (pcod f) f x)⁻¹ ⬝ _, 112 | refine Hhomotopy H n (pcod_pcompose f) x ⬝ _, 113 | exact Hconst H n x 114 | end 115 | 116 | definition cohomology_groups_chain_1 (n : ℤ) (x : H (pred n) X) : H ^→ n (pcod f) (coboundary n x) = 1 := 117 | begin 118 | refine (Hcompose H n (pcofiber_pcod f ∘* pcod (pcod f)) (pcod f) ((Hsusp_neg H n X)⁻¹ᵍ x))⁻¹ ⬝ _, 119 | refine Hhomotopy H n (!passoc ⬝* pwhisker_left _ !pcod_pcompose ⬝* !pcompose_pconst) _ ⬝ _, 120 | exact Hconst H n _ 121 | end 122 | 123 | definition cohomology_groups_chain_2 (n : ℤ) (x : H (pred n) Y) : coboundary n (H ^→ (pred n) f x) = 1 := 124 | begin 125 | exact sorry 126 | -- refine ap (H ^→ n (pcofiber_pcod f ∘* pcod (pcod f))) _ ⬝ _, 127 | --Hsusp_neg_inv_natural H n (pcofiber_pcod f ∘* pcod (pcod f)) _ 128 | end 129 | 130 | definition cohomology_groups_chain : Π(n : -3ℤ) (x : cohomology_groups (S (S n))), 131 | cohomology_groups_fun n (cohomology_groups_fun (S n) x) = 1 132 | | (n, fin.mk 0 p) := cohomology_groups_chain_0 n 133 | | (n, fin.mk 1 p) := cohomology_groups_chain_1 n 134 | | (n, fin.mk 2 p) := cohomology_groups_chain_2 n 135 | | (n, fin.mk (k+3) p) := begin exfalso, apply lt_le_antisymm p, apply le_add_left end 136 | 137 | definition LES_of_cohomology_groups [constructor] : chain_complex -3ℤ := 138 | chain_complex.mk (λn, cohomology_groups n) (λn, pmap_of_homomorphism (cohomology_groups_fun n)) cohomology_groups_chain 139 | 140 | definition is_exact_LES_of_cohomology_groups : is_exact LES_of_cohomology_groups := 141 | begin 142 | intro n, 143 | exact sorry 144 | end 145 | 146 | end 147 | 148 | end cohomology 149 | -------------------------------------------------------------------------------- /cohomology/gysin.hlean: -------------------------------------------------------------------------------- 1 | /- the construction of the Gysin sequence using the Serre spectral sequence -/ 2 | -- author: Floris van Doorn 3 | 4 | import .serre 5 | 6 | open eq pointed is_trunc is_conn is_equiv equiv sphere fiber chain_complex left_module spectrum nat 7 | prod nat int algebra function spectral_sequence fin group 8 | 9 | namespace cohomology 10 | universe variable u 11 | /- 12 | Given a pointed map E →* B with as fiber the sphere S^{n+1} and an abelian group A. 13 | The only nontrivial differentials in the spectral sequence of this map are the following 14 | differentials on page n: 15 | d_m = d_(m-1,n+1)^n : E_(m-1,n+1)^n → E_(m+n+1,0)^n 16 | Note that ker d_m = E_(m-1,n+1)^∞ and coker d_m = E_(m+n+1,0)^∞. 17 | Each diagonal on the ∞-page has at most two nontrivial groups, which means that 18 | coker d_{m-1} and ker d_m are the only two nontrivial groups building up D_{m+n}^∞, 19 | where D^∞ is the abutment of the spectral sequence. 20 | This gives the short exact sequences: 21 | coker d_{m-1} → D_{m+n}^∞ → ker d_m 22 | We can splice these SESs together to get a LES 23 | ... E_(m+n,0)^n → D_{m+n}^∞ → E_(m-1,n+1)^n → E_(m+n+1,0)^n → D_{m+n+1}^∞ ... 24 | Now we have 25 | E_(p,q)^n = E_(p,q)^0 = H^p(B; H^q(S^{n+1}; A)) = H^p(B; A) if q = n+1 or q = 0 26 | and 27 | D_{n}^∞ = H^n(E; A) 28 | This gives the Gysin sequence 29 | ... H^{m+n}(B; A) → H^{m+n}(E; A) → H^{m-1}(B; A) → H^{m+n+1}(B; A) → H^{m+n+1}(E; A) ... 30 | -/ 31 | 32 | 33 | definition gysin_trivial_Epage {E B : pType.{u}} {n : ℕ} (HB : is_conn 1 B) (f : E →* B) 34 | (e : pfiber f ≃* sphere (n+1)) (A : AbGroup) (r : ℕ) (p q : ℤ) (hq : q ≠ 0) 35 | (hq' : q ≠ of_nat (n+1)): 36 | is_contr (convergent_spectral_sequence.E (serre_spectral_sequence_map_of_is_conn pt f 37 | (EM_spectrum A) 0 (is_strunc_EM_spectrum A) HB) r (p, q)) := 38 | begin 39 | intros, apply is_contr_E, apply is_contr_ordinary_cohomology, esimp, 40 | refine is_contr_equiv_closed_rev _ (unreduced_ordinary_cohomology_sphere_of_neq A hq' hq), 41 | apply group.equiv_of_isomorphism, apply unreduced_ordinary_cohomology_isomorphism, exact e⁻¹ᵉ* 42 | end 43 | 44 | definition gysin_trivial_Epage2 {E B : pType.{u}} {n : ℕ} (HB : is_conn 1 B) (f : E →* B) 45 | (e : pfiber f ≃* sphere (n+1)) (A : AbGroup) (r : ℕ) (p q : ℤ) (hq : q > n+1) : 46 | is_contr (convergent_spectral_sequence.E (serre_spectral_sequence_map_of_is_conn pt f 47 | (EM_spectrum A) 0 (is_strunc_EM_spectrum A) HB) r (p, q)) := 48 | begin 49 | intros, apply gysin_trivial_Epage HB f e A r p q, 50 | { intro h, subst h, apply not_lt_zero (n+1), exact lt_of_of_nat_lt_of_nat hq }, 51 | { intro h, subst h, exact lt.irrefl _ hq } 52 | end 53 | 54 | definition gysin_sequence' {E B : pType.{u}} {n : ℕ} (HB : is_conn 1 B) (f : E →* B) 55 | (e : pfiber f ≃* sphere (n+1)) (A : AbGroup) : module_chain_complex rℤ -3ℤ := 56 | let c := serre_spectral_sequence_map_of_is_conn pt f (EM_spectrum A) 0 57 | (is_strunc_EM_spectrum A) HB in 58 | let cn : is_normal c := !is_normal_serre_spectral_sequence_map_of_is_conn in 59 | have deg_d_x : Π(m : ℤ), deg (convergent_spectral_sequence.d c n) ((m - 1) - 1, n + 1) = 60 | (n + m - 0, 0), 61 | begin 62 | intro m, refine deg_d_normal_eq cn _ _ ⬝ _, 63 | refine prod_eq _ !add.right_inv, 64 | refine ap (λx, x + (n+2)) !sub_sub ⬝ _, 65 | refine add.comm4 m (- 2) n 2 ⬝ _, 66 | refine ap (λx, x + 0) !add.comm 67 | end, 68 | have trivial_E : Π(r : ℕ) (p q : ℤ) (hq : q ≠ 0) (hq' : q ≠ of_nat (n+1)), 69 | is_contr (convergent_spectral_sequence.E c r (p, q)), 70 | from gysin_trivial_Epage HB f e A, 71 | have trivial_E' : Π(r : ℕ) (p q : ℤ) (hq : q > n+1), 72 | is_contr (convergent_spectral_sequence.E c r (p, q)), 73 | from gysin_trivial_Epage2 HB f e A, 74 | left_module.LES_of_SESs _ _ _ (λm, convergent_spectral_sequence.d c n (m - 1, n + 1)) 75 | begin 76 | intro m, 77 | fapply short_exact_mod_isomorphism, 78 | rotate 3, 79 | { fapply short_exact_mod_of_is_contr_submodules 80 | (convergence_0 c (n + m) (λm, neg_zero)), 81 | { exact zero_lt_succ n }, 82 | { intro k Hk0 Hkn, apply trivial_E, exact λh, Hk0 (of_nat.inj h), 83 | exact λh, Hkn (of_nat.inj h), }}, 84 | { symmetry, refine Einf_isomorphism c (n+1) _ _ ⬝lm 85 | convergent_spectral_sequence.α c n (n + m - 0, 0) ⬝lm 86 | isomorphism_of_eq (ap (graded_homology _ _) _) ⬝lm 87 | !graded_homology_isomorphism ⬝lm 88 | homology_isomorphism_cokernel_module _ _ _, 89 | { intros r Hr, apply trivial_E', apply of_nat_lt_of_nat_of_lt, 90 | rewrite [zero_add], exact lt_succ_of_le Hr }, 91 | { intros r Hr, apply is_contr_E, apply is_normal.normal2 cn, 92 | refine lt_of_le_of_lt (le_of_eq (ap (λx : ℤ × ℤ, 0 + pr2 x) (is_normal.normal3 cn r))) _, 93 | esimp, rewrite [-sub_eq_add_neg], apply sub_lt_of_pos, apply of_nat_lt_of_nat_of_lt, 94 | apply succ_pos }, 95 | { exact (deg_d_x m)⁻¹ }, 96 | { intro x, apply @eq_of_is_contr, apply is_contr_E, 97 | apply is_normal.normal2 cn, 98 | refine lt_of_le_of_lt (@le_of_eq ℤ _ _ _ (ap (pr2 ∘ deg (convergent_spectral_sequence.d c n)) 99 | (deg_d_x m) ⬝ ap pr2 (deg_d_normal_eq cn _ _))) _, 100 | refine lt_of_le_of_lt (le_of_eq (zero_add (-(n+1)))) _, 101 | apply neg_neg_of_pos, apply of_nat_succ_pos }}, 102 | { reflexivity }, 103 | { symmetry, 104 | refine Einf_isomorphism c (n+1) _ _ ⬝lm 105 | convergent_spectral_sequence.α c n (n + m - (n+1), n+1) ⬝lm 106 | graded_homology_isomorphism_kernel_module _ _ _ _ ⬝lm 107 | isomorphism_of_eq (ap (graded_kernel _) _), 108 | { intros r Hr, apply trivial_E', apply of_nat_lt_of_nat_of_lt, 109 | apply lt_add_of_pos_right, apply zero_lt_succ }, 110 | { intros r Hr, apply is_contr_E, apply is_normal.normal2 cn, 111 | refine lt_of_le_of_lt (le_of_eq (ap (λx : ℤ × ℤ, (n+1)+pr2 x) (is_normal.normal3 cn r))) _, 112 | esimp, rewrite [-sub_eq_add_neg], apply sub_lt_right_of_lt_add, 113 | apply of_nat_lt_of_nat_of_lt, rewrite [zero_add], exact lt_succ_of_le Hr }, 114 | { apply trivial_image_of_is_contr, rewrite [deg_d_inv_eq], 115 | apply trivial_E', apply of_nat_lt_of_nat_of_lt, 116 | apply lt_add_of_pos_right, apply zero_lt_succ }, 117 | { refine prod_eq _ rfl, refine ap (add _) !neg_add ⬝ _, 118 | refine add.comm4 n m (-n) (- 1) ⬝ _, 119 | refine ap (λx, x + _) !add.right_inv ⬝ !zero_add }} 120 | end 121 | 122 | definition gysin_sequence'_zero {E B : Type*} {n : ℕ} (HB : is_conn 1 B) (f : E →* B) 123 | (e : pfiber f ≃* sphere (n+1)) (A : AbGroup) (m : ℤ) : 124 | gysin_sequence' HB f e A (m, 0) ≃lm LeftModule_int_of_AbGroup (uoH^m+n+1[B, A]) := 125 | let c := serre_spectral_sequence_map_of_is_conn pt f (EM_spectrum A) 0 126 | (is_strunc_EM_spectrum A) HB in 127 | let cn : is_normal c := !is_normal_serre_spectral_sequence_map_of_is_conn in 128 | begin 129 | refine LES_of_SESs_zero _ _ m ⬝lm _, 130 | transitivity convergent_spectral_sequence.E c n (m+n+1, 0), 131 | exact isomorphism_of_eq (ap (convergent_spectral_sequence.E c n) 132 | (deg_d_normal_eq cn _ _ ⬝ prod_eq (add.comm4 m (- 1) n 2) (add.right_inv (n+1)))), 133 | refine E_isomorphism0 _ _ _ ⬝lm 134 | lm_iso_int.mk (unreduced_ordinary_cohomology_isomorphism_right _ _ _), 135 | { intros r hr, apply is_contr_ordinary_cohomology, 136 | refine is_contr_equiv_closed_rev 137 | (equiv_of_isomorphism (cohomology_change_int _ _ _ ⬝g uoH^≃r+1[e⁻¹ᵉ*, A])) 138 | (unreduced_ordinary_cohomology_sphere_of_neq_nat A _ _), 139 | { exact !zero_sub ⬝ ap neg (deg_d_normal_pr2 cn r) ⬝ !neg_neg }, 140 | { apply ne_of_lt, apply add_lt_add_right, exact hr }, 141 | { apply succ_ne_zero }}, 142 | { intros r hr, apply is_contr_ordinary_cohomology, 143 | refine is_contr_equiv_closed_rev 144 | (equiv_of_isomorphism (cohomology_change_int _ _ (!zero_add ⬝ deg_d_normal_pr2 cn r))) 145 | (is_contr_ordinary_cohomology_of_neg _ _ _), 146 | { rewrite [-neg_zero], apply neg_lt_neg, apply of_nat_lt_of_nat_of_lt, apply zero_lt_succ }}, 147 | { exact uoH^≃ 0[e⁻¹ᵉ*, A] ⬝g unreduced_ordinary_cohomology_sphere_zero _ _ (succ_ne_zero n) } 148 | end 149 | 150 | definition gysin_sequence'_one {E B : Type*} {n : ℕ} (HB : is_conn 1 B) (f : E →* B) 151 | (e : pfiber f ≃* sphere (n+1)) (A : AbGroup) (m : ℤ) : 152 | gysin_sequence' HB f e A (m, 1) ≃lm LeftModule_int_of_AbGroup (uoH^m - 1[B, A]) := 153 | let c := serre_spectral_sequence_map_of_is_conn pt f (EM_spectrum A) 0 154 | (is_strunc_EM_spectrum A) HB in 155 | let cn : is_normal c := !is_normal_serre_spectral_sequence_map_of_is_conn in 156 | begin 157 | refine LES_of_SESs_one _ _ m ⬝lm _, 158 | refine E_isomorphism0 _ _ _ ⬝lm 159 | lm_iso_int.mk (unreduced_ordinary_cohomology_isomorphism_right _ _ _), 160 | { intros r hr, apply is_contr_ordinary_cohomology, 161 | refine is_contr_equiv_closed_rev 162 | (equiv_of_isomorphism uoH^≃_[e⁻¹ᵉ*, A]) 163 | (unreduced_ordinary_cohomology_sphere_of_gt _ _), 164 | { apply lt_add_of_pos_right, apply zero_lt_succ }}, 165 | { intros r hr, apply is_contr_ordinary_cohomology, 166 | refine is_contr_equiv_closed_rev 167 | (equiv_of_isomorphism (cohomology_change_int _ _ _ ⬝g uoH^≃n-r[e⁻¹ᵉ*, A])) 168 | (unreduced_ordinary_cohomology_sphere_of_neq_nat A _ _), 169 | { refine ap (add _) (deg_d_normal_pr2 cn r) ⬝ add_sub_comm n 1 r 1 ⬝ !add_zero ⬝ _, 170 | symmetry, apply of_nat_sub, exact le_of_lt hr }, 171 | { apply ne_of_lt, exact lt_of_le_of_lt (nat.sub_le n r) (lt.base n) }, 172 | { apply ne_of_gt, exact nat.sub_pos_of_lt hr }}, 173 | { refine uoH^≃n+1[e⁻¹ᵉ*, A] ⬝g unreduced_ordinary_cohomology_sphere _ _ (succ_ne_zero n) } 174 | end 175 | 176 | -- todo: maybe rewrite n+m to m+n (or above rewrite m+n+1 to n+m+1 or n+(m+1))? 177 | definition gysin_sequence'_two {E B : Type*} {n : ℕ} (HB : is_conn 1 B) (f : E →* B) 178 | (e : pfiber f ≃* sphere (n+1)) (A : AbGroup) (m : ℤ) : 179 | gysin_sequence' HB f e A (m, 2) ≃lm LeftModule_int_of_AbGroup (uoH^n+m[E, A]) := 180 | LES_of_SESs_two _ _ m 181 | 182 | end cohomology 183 | -------------------------------------------------------------------------------- /cohomology/projective_space.hlean: -------------------------------------------------------------------------------- 1 | /- A computation of the cohomology groups of K(ℤ,2) using the Serre spectral sequence 2 | 3 | Author: Floris van Doorn-/ 4 | 5 | import .serre 6 | 7 | open eq spectrum EM EM.ops int pointed cohomology left_module algebra group fiber is_equiv equiv 8 | prod is_trunc function exact_couple 9 | 10 | namespace temp 11 | 12 | definition uH0_circle : uH^0[circle] ≃g gℤ := 13 | sorry 14 | 15 | definition uH1_circle : uH^1[circle] ≃g gℤ := 16 | sorry 17 | 18 | definition uH_circle_of_ge (n : ℤ) (h : n ≥ 2) : uH^n[circle] ≃g trivial_ab_group := 19 | sorry 20 | 21 | definition f : unit → K agℤ 2 := 22 | λx, pt 23 | 24 | definition fserre : 25 | (λp q, uoH^p[K agℤ 2, H^q[circle₊]]) ⟹ᵍ (λn, H^n[unit₊]) := 26 | proof 27 | convergent_exact_couple_g_isomorphism 28 | (serre_convergence_map_of_is_conn pt f (EM_spectrum agℤ) 0 29 | (is_strunc_EM_spectrum agℤ) (is_conn_EM agℤ 2)) 30 | begin 31 | intro n s, apply unreduced_ordinary_cohomology_isomorphism_right, 32 | apply unreduced_cohomology_isomorphism, symmetry, 33 | refine !fiber_const_equiv ⬝e _, 34 | refine loop_EM _ 1 ⬝e _, 35 | exact EM_pequiv_circle 36 | end 37 | begin intro n, reflexivity end 38 | qed 39 | exit -- this file needs to be updated after reindexing of spectral sequences 40 | section 41 | local notation `X` := converges_to.X fserre 42 | local notation `E∞` := convergence_theorem.Einf (converges_to.HH fserre) 43 | local notation `E∞d` := convergence_theorem.Einfdiag (converges_to.HH fserre) 44 | local notation `E` := exact_couple.E X 45 | 46 | definition fbuilt (n : ℤ) : 47 | is_built_from (LeftModule_int_of_AbGroup (H^-n[unit₊])) (E∞d (n, 0)) := 48 | is_built_from_of_converges_to fserre n 49 | 50 | definition fEinf0 : E∞ (0, 0) ≃lm LeftModule_int_of_AbGroup agℤ := 51 | isomorphism_zero_of_is_built_from (fbuilt 0) (by reflexivity) ⬝lm 52 | lm_iso_int.mk (cohomology_change_int _ _ neg_zero ⬝g 53 | cohomology_isomorphism pbool_pequiv_add_point_unit _ _ ⬝g ordinary_cohomology_pbool _) 54 | 55 | definition fEinfd (n : ℤ) (m : ℕ) (p : n ≠ 0) : is_contr (E∞d (n, 0) m) := 56 | have p' : -n ≠ 0, from λH, p (eq_zero_of_neg_eq_zero H), 57 | is_contr_quotients (fbuilt n) (@(is_trunc_equiv_closed_rev -2 58 | (group.equiv_of_isomorphism (cohomology_isomorphism pbool_pequiv_add_point_unit _ _))) 59 | (EM_dimension' _ _ p')) _ 60 | 61 | definition fEinf (n : ℤ) (m : ℕ) (p : n ≠ 0) : is_contr (E∞ (n, -m)) := 62 | transport (is_contr ∘ E∞) 63 | begin 64 | induction m with m q, reflexivity, refine ap (deg (exact_couple.i X)) q ⬝ _, 65 | exact prod_eq idp (neg_add m (1 : ℤ))⁻¹ᵖ 66 | end 67 | (fEinfd n m p) 68 | 69 | definition is_contr_fD (n s : ℤ) (p : s > 0) : is_contr (E (n, s)) := 70 | have is_contr H^-s[circle₊], from 71 | is_contr_ordinary_cohomology_of_neg _ _ (neg_neg_of_pos p), 72 | have is_contr (uoH^-(n-s)[K agℤ 2, H^-s[circle₊]]), from 73 | is_contr_unreduced_ordinary_cohomology _ _ _ _, 74 | @(is_contr_equiv_closed (left_module.equiv_of_isomorphism (converges_to.e fserre (n, s))⁻¹ˡᵐ)) 75 | this 76 | 77 | definition is_contr_fD2 (n s : ℤ) (p : n > s) : is_contr (E (n, s)) := 78 | have -(n-s) < 0, from neg_neg_of_pos (sub_pos_of_lt p), 79 | @(is_contr_equiv_closed (left_module.equiv_of_isomorphism (converges_to.e fserre (n, s))⁻¹ˡᵐ)) 80 | (is_contr_ordinary_cohomology_of_neg _ _ this) 81 | 82 | definition is_contr_fD3 (n s : ℤ) (p : s ≤ - 2) : is_contr (E (n, s)) := 83 | have -s ≥ 2, from sorry, --from neg_neg_of_pos (sub_pos_of_lt p), 84 | @(is_contr_equiv_closed (group.equiv_of_isomorphism (unreduced_ordinary_cohomology_isomorphism_right _ (uH_circle_of_ge _ this)⁻¹ᵍ _) ⬝e 85 | left_module.equiv_of_isomorphism (converges_to.e fserre (n, s))⁻¹ˡᵐ)) 86 | (is_contr_ordinary_cohomology _ _ _ !is_contr_unit) 87 | --(unreduced_ordinary_cohomology_isomorphism_right _ _ _) 88 | --(is_contr_ordinary_cohomology_of_neg _ _ this) 89 | --(is_contr_ordinary_cohomology_of_neg _ _ this) 90 | definition fE00 : E (0,0) ≃lm LeftModule_int_of_AbGroup agℤ := 91 | begin 92 | refine (Einf_isomorphism fserre 0 _ _)⁻¹ˡᵐ ⬝lm fEinf0, 93 | intro r H, apply is_contr_fD2, exact sub_nat_lt 0 (r+1), 94 | intro r H, apply is_contr_fD, change 0 + (r + 1) >[ℤ] 0, 95 | apply of_nat_lt_of_nat_of_lt, 96 | apply nat.zero_lt_succ, 97 | end 98 | 99 | definition Ex0 (n : ℕ) : AddGroup_of_AddAbGroup (E (-n,0)) ≃g uH^n[K agℤ 2] := 100 | begin 101 | refine group_isomorphism_of_lm_isomorphism_int (converges_to.e fserre (-n,0)) ⬝g _, 102 | refine cohomology_change_int _ _ (ap neg !sub_zero ⬝ !neg_neg) ⬝g 103 | unreduced_ordinary_cohomology_isomorphism_right _ uH0_circle _, 104 | end 105 | 106 | definition Ex1 (n : ℕ) : AddGroup_of_AddAbGroup (E (-(n+(1 : ℤ)),- (1 : ℤ))) ≃g uH^n[K agℤ 2] := 107 | begin 108 | refine group_isomorphism_of_lm_isomorphism_int (converges_to.e fserre (-(n+(1 : ℤ)),- (1 : ℤ))) ⬝g _, 109 | refine cohomology_change_int _ _ (ap neg _ ⬝ !neg_neg) ⬝g 110 | unreduced_ordinary_cohomology_isomorphism_right _ !uH1_circle _, 111 | exact ap (λx, x - - (1 : ℤ)) !neg_add ⬝ !add_sub_cancel 112 | end 113 | 114 | definition uH0 : uH^0[K agℤ 2] ≃g gℤ := 115 | (Ex0 0)⁻¹ᵍ ⬝g group_isomorphism_of_lm_isomorphism_int fE00 116 | 117 | definition fE10 : is_contr (E (- (1 : ℤ),0)) := 118 | begin 119 | refine @(is_trunc_equiv_closed _ _) (fEinf (- (1 : ℤ)) 0 dec_star), 120 | apply equiv_of_isomorphism, 121 | refine Einf_isomorphism fserre 0 _ _, 122 | intro r H, exact sorry, exact sorry --apply is_contr_fD2, change (- 1) - (- 1) >[ℤ] (- 0) - (r + 1), 123 | -- apply is_contr_fD, change (-0) - (r + 1) >[ℤ] 0, 124 | --exact sub_nat_lt 0 r, 125 | -- intro r H, apply is_contr_fD, change 0 + (r + 1) >[ℤ] 0, 126 | -- apply of_nat_lt_of_nat_of_lt, 127 | -- apply nat.zero_lt_succ, 128 | end 129 | 130 | definition uH1 : is_contr (uH^1[K agℤ 2]) := 131 | begin 132 | refine @(is_trunc_equiv_closed -2 (group.equiv_of_isomorphism !Ex0)) fE10, 133 | end 134 | 135 | end 136 | 137 | end temp 138 | -------------------------------------------------------------------------------- /coind_colim.hlean: -------------------------------------------------------------------------------- 1 | -- author: Floris van Doorn 2 | 3 | import .colimit.seq_colim 4 | 5 | open nat seq_colim eq equiv is_equiv is_trunc function 6 | 7 | namespace seq_colim 8 | 9 | variables {A : ℕ → Type} {f : seq_diagram A} 10 | 11 | definition ι0 [reducible] : A 0 → seq_colim f := 12 | ι f 13 | 14 | variable (f) 15 | definition ι0' [reducible] : A 0 → seq_colim f := 16 | ι f 17 | 18 | definition glue0 (a : A 0) : shift_down f (ι0 (f a)) = ι f a := 19 | glue f a 20 | 21 | definition rec_coind_point {P : Π⦃A : ℕ → Type⦄ (f : seq_diagram A), seq_colim f → Type} 22 | (P0 : Π⦃A⦄ (f : seq_diagram A) (a : A 0), P f (ι0 a)) 23 | (Ps : Π⦃A⦄ (f : seq_diagram A) (x : seq_colim (shift_diag f)), 24 | P (shift_diag f) x → P f (shift_down f x)) 25 | (Pe : Π⦃A⦄ (f : seq_diagram A) (a : A 0), 26 | pathover (P f) (Ps f (ι0 (f a)) !P0) (proof glue f a qed) (P0 f a)) 27 | (n : ℕ) : Π{A : ℕ → Type} {f : seq_diagram A} (a : A n), P f (ι f a) := 28 | begin 29 | induction n with n IH: intro A f a, 30 | { exact P0 f a }, 31 | { exact Ps f (ι _ a) (IH a) } 32 | end 33 | 34 | definition rec_coind_point_succ {P : Π⦃A : ℕ → Type⦄ (f : seq_diagram A), seq_colim f → Type} 35 | (P0 : Π⦃A⦄ (f : seq_diagram A) (a : A 0), P f (ι0 a)) 36 | (Ps : Π⦃A⦄ (f : seq_diagram A) (x : seq_colim (shift_diag f)), 37 | P (shift_diag f) x → P f (shift_down f x)) 38 | (Pe : Π⦃A⦄ (f : seq_diagram A) (a : A 0), 39 | pathover (P f) (Ps f (ι0 (f a)) !P0) _ (P0 f a)) 40 | (n : ℕ) {A : ℕ → Type} {f : seq_diagram A} (a : A (succ n)) : 41 | rec_coind_point P0 Ps Pe (succ n) a = Ps f (ι _ a) (rec_coind_point P0 Ps Pe n a) := 42 | by reflexivity 43 | 44 | definition rec_coind {P : Π⦃A : ℕ → Type⦄ (f : seq_diagram A), seq_colim f → Type} 45 | (P0 : Π⦃A⦄ (f : seq_diagram A) (a : A 0), P f (ι0 a)) 46 | (Ps : Π⦃A⦄ (f : seq_diagram A) (x : seq_colim (shift_diag f)), 47 | P (shift_diag f) x → P f (shift_down f x)) 48 | (Pe : Π⦃A⦄ (f : seq_diagram A) (a : A 0), 49 | pathover (P f) (Ps f (ι0 (f a)) !P0) (proof glue f a qed) (P0 f a)) 50 | {A : ℕ → Type} {f : seq_diagram A} (x : seq_colim f) : P f x := 51 | begin 52 | induction x, 53 | { exact rec_coind_point P0 Ps Pe n a }, 54 | { revert A f a, induction n with n IH: intro A f a, 55 | { exact Pe f a }, 56 | { rewrite [rec_coind_point_succ _ _ _ n, rec_coind_point_succ], 57 | note p := IH _ (shift_diag f) a, 58 | refine change_path _ (pathover_ap _ _ (apo (Ps f) p)), 59 | exact !elim_glue 60 | }}, 61 | end 62 | 63 | definition rec_coind_pt2 {P : Π⦃A : ℕ → Type⦄ (f : seq_diagram A), seq_colim f → Type} 64 | (P0 : Π⦃A⦄ (f : seq_diagram A) (a : A 0), P f (ι0 a)) 65 | (Ps : Π⦃A⦄ (f : seq_diagram A) (x : seq_colim (shift_diag f)), 66 | P (shift_diag f) x → P f (shift_down f x)) 67 | (Pe : Π⦃A⦄ (f : seq_diagram A) (a : A 0), 68 | pathover (P f) (Ps f (ι0 (f a)) !P0) _ (P0 f a)) 69 | {A : ℕ → Type} {f : seq_diagram A} (x : seq_colim (shift_diag f)) 70 | : rec_coind P0 Ps Pe (shift_down f x) = Ps f x (rec_coind P0 Ps Pe x) := 71 | begin 72 | induction x, 73 | { reflexivity }, 74 | { apply eq_pathover_dep, 75 | apply hdeg_squareover, esimp, 76 | refine apd_compose2 (rec_coind P0 Ps Pe) _ _ ⬝ _ ⬝ (apd_compose1 (Ps f) _ _)⁻¹, 77 | exact sorry 78 | --refine ap (λx, pathover_of_pathover_ap _ _ (x)) _ ⬝ _ , 79 | } 80 | end 81 | 82 | definition elim_coind_point {P : Π⦃A : ℕ → Type⦄ (f : seq_diagram A), Type} 83 | (P0 : Π⦃A⦄ (f : seq_diagram A) (a : A 0), P f) 84 | (Ps : Π⦃A⦄ (f : seq_diagram A) (x : seq_colim (shift_diag f)), P (shift_diag f) → P f) 85 | (Pe : Π⦃A⦄ (f : seq_diagram A) (a : A 0), Ps f (ι0 (f a)) (P0 _ (f a)) = P0 f a) 86 | (n : ℕ) : Π{A : ℕ → Type} (f : seq_diagram A) (a : A n), P f := 87 | begin 88 | induction n with n IH: intro A f a, 89 | { exact P0 f a }, 90 | { exact Ps f (ι _ a) (IH _ a) } 91 | end 92 | 93 | definition elim_coind_point_succ {P : Π⦃A : ℕ → Type⦄ (f : seq_diagram A), Type} 94 | (P0 : Π⦃A⦄ (f : seq_diagram A) (a : A 0), P f) 95 | (Ps : Π⦃A⦄ (f : seq_diagram A) (x : seq_colim (shift_diag f)), P (shift_diag f) → P f) 96 | (Pe : Π⦃A⦄ (f : seq_diagram A) (a : A 0), Ps f (ι0 (f a)) (P0 _ (f a)) = P0 f a) 97 | (n : ℕ) {A : ℕ → Type} {f : seq_diagram A} (a : A (succ n)) : 98 | elim_coind_point P0 Ps Pe (succ n) f a = 99 | Ps f (ι _ a) (elim_coind_point P0 Ps Pe n (shift_diag f) a) := 100 | by reflexivity 101 | 102 | definition elim_coind_path {P : Π⦃A : ℕ → Type⦄ (f : seq_diagram A), Type} 103 | (P0 : Π⦃A⦄ (f : seq_diagram A) (a : A 0), P f) 104 | (Ps : Π⦃A⦄ (f : seq_diagram A) (x : seq_colim (shift_diag f)), P (shift_diag f) → P f) 105 | (Pe : Π⦃A⦄ (f : seq_diagram A) (a : A 0), Ps f (ι0 (f a)) (P0 _ (f a)) = P0 f a) 106 | (n : ℕ) : Π{A : ℕ → Type} (f : seq_diagram A) (a : A n), 107 | elim_coind_point P0 Ps Pe (succ n) f (f a) = elim_coind_point P0 Ps Pe n f a := 108 | begin 109 | induction n with n IH: intro A f a, 110 | { exact Pe f a }, 111 | { rewrite [elim_coind_point_succ _ _ _ n, elim_coind_point_succ], 112 | note p := IH (shift_diag f) a, 113 | refine ap011 (Ps f) !glue p } 114 | end 115 | 116 | definition elim_coind {P : Π⦃A : ℕ → Type⦄ (f : seq_diagram A), Type} 117 | (P0 : Π⦃A⦄ (f : seq_diagram A) (a : A 0), P f) 118 | (Ps : Π⦃A⦄ (f : seq_diagram A) (x : seq_colim (shift_diag f)), P (shift_diag f) → P f) 119 | (Pe : Π⦃A⦄ (f : seq_diagram A) (a : A 0), Ps f (ι0 (f a)) (P0 _ (f a)) = P0 f a) 120 | {A : ℕ → Type} {f : seq_diagram A} (x : seq_colim f) : P f := 121 | begin 122 | induction x, 123 | { exact elim_coind_point P0 Ps Pe n f a }, 124 | { exact elim_coind_path P0 Ps Pe n f a }, 125 | end 126 | 127 | definition elim_coind_pt2 {P : Π⦃A : ℕ → Type⦄ (f : seq_diagram A), Type} 128 | (P0 : Π⦃A⦄ (f : seq_diagram A) (a : A 0), P f) 129 | (Ps : Π⦃A⦄ (f : seq_diagram A) (x : seq_colim (shift_diag f)), P (shift_diag f) → P f) 130 | (Pe : Π⦃A⦄ (f : seq_diagram A) (a : A 0), Ps f (ι0 (f a)) (P0 _ (f a)) = P0 f a) 131 | {A : ℕ → Type} {f : seq_diagram A} (x : seq_colim (shift_diag f)) 132 | : elim_coind P0 Ps Pe (shift_down f x) = Ps f x (elim_coind P0 Ps Pe x) := 133 | begin 134 | induction x, 135 | { reflexivity }, 136 | { apply eq_pathover, apply hdeg_square, 137 | refine ap_compose (elim_coind P0 Ps Pe) _ _ ⬝ _ ⬝ (ap_eq_ap011 (Ps f) _ _ _)⁻¹, 138 | refine ap02 _ !elim_glue ⬝ !elim_glue ⬝ ap011 (ap011 _) !ap_id⁻¹ !elim_glue⁻¹ } 139 | end 140 | 141 | end seq_colim 142 | -------------------------------------------------------------------------------- /colimit/README.md: -------------------------------------------------------------------------------- 1 | This folder contains a formalization of various properties about sequential colimits. Most importantly, we prove that sigma-types commute with colimits. It accompanies a submitted paper by Kristina Sojakova, Floris van Doorn and Egbert Rijke. 2 | 3 | This repository contains some unproven results, marked by `sorry`. No unproven results are used for any theorems discussed in the paper. You can write `print axioms theoremname` in a file to verify that `sorry` is not used in the proofs. 4 | 5 | You will need a working version of Lean 2 to compile this repository. Installation instructions for Lean 2 can be found [here](https://github.com/leanprover/lean2). After that, you can run `linja` (or `path/to/lean2/bin/linja`) from the command-line in the main directory to compile this repository. 6 | -------------------------------------------------------------------------------- /colimit/local_ext.hlean: -------------------------------------------------------------------------------- 1 | /- 2 | Copyright (c) 2016 Floris van Doorn. All rights reserved. 3 | Released under Apache 2.0 license as described in the file LICENSE. 4 | Authors: Floris van Doorn, Egbert Rijke 5 | -/ 6 | 7 | import hit.two_quotient .seq_colim 8 | 9 | open eq prod sum two_quotient sigma function relation e_closure nat seq_colim 10 | 11 | namespace localization 12 | section quasi_local_extension 13 | 14 | universe variables u v w 15 | parameters {A : Type.{u}} {P : A → Type.{v}} {Q : A → Type.{w}} (F : Πa, P a → Q a) 16 | definition is_local [class] (Y : Type) : Type := 17 | Π(a : A), is_equiv (λg, g ∘ F a : (Q a → Y) → (P a → Y)) 18 | 19 | 20 | 21 | section 22 | parameter (X : Type.{max u v w}) 23 | local abbreviation Y := X + Σa, (P a → X) × Q a 24 | 25 | -- do we want to remove the contractible pairs? 26 | inductive qleR : Y → Y → Type := 27 | | J : Π{a : A} (f : P a → X) (p : P a), qleR (inr ⟨a, (f, F a p)⟩) (inl (f p)) 28 | | k : Π{a : A} (g : Q a → X) (q : Q a), qleR (inl (g q)) (inr ⟨a, (g ∘ F a, q)⟩) 29 | 30 | inductive qleQ : Π⦃y₁ y₂ : Y⦄, e_closure qleR y₁ y₂ → e_closure qleR y₁ y₂ → Type := 31 | | K : Π{a : A} (g : Q a → X) (p : P a), qleQ [qleR.k g (F a p)] [qleR.J (g ∘ F a) p]⁻¹ʳ 32 | 33 | definition one_step_localization : Type := two_quotient qleR qleQ 34 | definition incl : X → one_step_localization := incl0 _ _ ∘ inl 35 | 36 | end 37 | variables (X : Type.{max u v w}) {Z : Type} 38 | 39 | definition n_step_localization : ℕ → Type := 40 | nat.rec X (λn Y, localization.one_step_localization F Y) 41 | 42 | definition incln (n : ℕ) : 43 | n_step_localization X n → n_step_localization X (succ n) := 44 | localization.incl F (n_step_localization X n) 45 | 46 | -- localization if P and Q consist of ω-compact types 47 | definition localization : Type := seq_colim (incln X) 48 | definition incll : X → localization X := ι' _ 0 49 | 50 | protected definition rec {P : localization X → Type} [Πz, is_local (P z)] 51 | (H : Πx, P (incll X x)) (z : localization X) : P z := 52 | begin 53 | exact sorry 54 | end 55 | 56 | definition extend {Y Z : Type} (f : Y → Z) [is_local Z] (x : one_step_localization Y) : Z := 57 | begin 58 | induction x, 59 | { induction a, 60 | { exact f a}, 61 | { induction a with a v, induction v with f q, exact sorry}}, 62 | { exact sorry}, 63 | { exact sorry} 64 | end 65 | 66 | protected definition elim {Y : Type} [is_local Y] 67 | (H : X → Y) (z : localization X) : Y := 68 | begin 69 | induction z with n x n x, 70 | { induction n with n IH, 71 | { exact H x}, 72 | induction x, 73 | { induction a, 74 | { exact IH a}, 75 | { induction a with a v, induction v with f q, exact sorry}}, 76 | { exact sorry}, 77 | exact sorry}, 78 | exact sorry 79 | end 80 | 81 | 82 | end quasi_local_extension 83 | end localization 84 | -------------------------------------------------------------------------------- /colimit/omega_compact.hlean: -------------------------------------------------------------------------------- 1 | /- 2 | Copyright (c) 2015 Floris van Doorn. All rights reserved. 3 | Released under Apache 2.0 license as described in the file LICENSE. 4 | Authors: Floris van Doorn, Egbert Rijke 5 | -/ 6 | 7 | import .seq_colim types.unit 8 | 9 | open eq nat is_equiv equiv is_trunc pi unit function prod unit sigma sigma.ops sum prod trunc fin 10 | algebra 11 | 12 | namespace seq_colim 13 | 14 | universe variable u 15 | variables {A : ℕ → Type.{u}} (f : seq_diagram A) 16 | variables {n : ℕ} (a : A n) 17 | 18 | definition arrow_colim_of_colim_arrow [unfold 4] {X : Type} 19 | (g : seq_colim (seq_diagram_arrow_left f X)) (x : X) : seq_colim f := 20 | begin induction g with n g n g, exact ι f (g x), exact glue f (g x) end 21 | 22 | definition omega_compact [class] (X : Type) : Type := 23 | Π⦃A : ℕ → Type⦄ (f : seq_diagram A), 24 | is_equiv (arrow_colim_of_colim_arrow f : 25 | seq_colim (seq_diagram_arrow_left f X) → (X → seq_colim f)) 26 | 27 | definition equiv_of_omega_compact [unfold 4] (X : Type) [H : omega_compact X] 28 | {A : ℕ → Type} (f : seq_diagram A) : 29 | seq_colim (seq_diagram_arrow_left f X) ≃ (X → seq_colim f) := 30 | equiv.mk _ (H f) 31 | 32 | definition omega_compact_of_equiv [unfold 4] (X : Type) 33 | (H : Π⦃A : ℕ → Type⦄ (f : seq_diagram A), 34 | seq_colim (seq_diagram_arrow_left f X) ≃ (X → seq_colim f)) 35 | (p : Π⦃A : ℕ → Type⦄ (f : seq_diagram A) {n : ℕ} (g : X → A n) (x : X), 36 | H f (ι _ g) x = ι _ (g x)) 37 | (q : Π⦃A : ℕ → Type⦄ (f : seq_diagram A) {n : ℕ} (g : X → A n) (x : X), 38 | square (p f (@f n ∘ g) x) (p f g x) (ap (λg, H f g x) 39 | (glue (seq_diagram_arrow_left f X) g)) (glue f (g x))) 40 | : omega_compact X := 41 | λA f, is_equiv_of_equiv_of_homotopy (H f) 42 | begin 43 | intro g, apply eq_of_homotopy, intro x, 44 | induction g with n g n g, 45 | { exact p f g x }, 46 | { apply eq_pathover, refine _ ⬝hp !elim_glue⁻¹, exact q f g x } 47 | end 48 | 49 | local attribute is_contr_seq_colim [instance] 50 | definition is_contr_empty_arrow [instance] (X : Type) : is_contr (empty → X) := 51 | by apply is_trunc_pi; contradiction 52 | 53 | definition omega_compact_empty [instance] [constructor] : omega_compact empty := 54 | begin 55 | intro A f, 56 | fapply adjointify, 57 | { intro g, exact ι' _ 0 empty.elim}, 58 | { intro g, apply eq_of_homotopy, contradiction}, 59 | { intro h, apply is_prop.elim} 60 | end 61 | 62 | definition omega_compact_unit' [instance] [constructor] : omega_compact unit := 63 | begin 64 | intro A f, 65 | fapply adjointify, 66 | { intro g, induction g ⋆, 67 | { exact ι _ (λx, a)}, 68 | { apply glue}}, 69 | { intro g, apply eq_of_homotopy, intro u, induction u, 70 | induction g ⋆, 71 | { reflexivity}, 72 | { esimp, apply eq_pathover_id_right, apply hdeg_square, 73 | refine ap_compose (λx, arrow_colim_of_colim_arrow f x ⋆) _ _ ⬝ _, 74 | refine ap02 _ !elim_glue ⬝ _, apply elim_glue}}, 75 | { intro h, induction h with n h n h, 76 | { esimp, apply ap (ι' _ n), apply unit_arrow_eq}, 77 | { esimp, apply eq_pathover_id_right, 78 | refine ap_compose (seq_colim.elim _ _ _) _ _ ⬝ph _, 79 | refine ap02 _ !elim_glue ⬝ph _, 80 | refine !elim_glue ⬝ph _, 81 | refine _ ⬝pv natural_square_tr (@glue _ (seq_diagram_arrow_left f unit) n) (unit_arrow_eq h), 82 | refine _ ⬝ (ap_compose (ι' _ _) _ _)⁻¹, 83 | apply ap02, unfold [seq_diagram_arrow_left], 84 | apply unit_arrow_eq_compose}} 85 | end 86 | 87 | -- The following is a start of a different proof that unit is omega-compact, 88 | -- which proves first that the types are equivalent 89 | definition omega_compact_unit [instance] [constructor] : omega_compact unit := 90 | begin 91 | fapply omega_compact_of_equiv, 92 | { intro A f, refine _ ⬝e !arrow_unit_left⁻¹ᵉ, fapply seq_colim_equiv, 93 | { intro n, apply arrow_unit_left }, 94 | intro n f, reflexivity }, 95 | { intros, induction x, reflexivity }, 96 | { intros, induction x, esimp, apply hdeg_square, exact !elim_glue ⬝ !idp_con }, 97 | end 98 | 99 | local attribute equiv_of_omega_compact [constructor] 100 | definition omega_compact_prod [instance] [constructor] {X Y : Type} [omega_compact.{_ u} X] 101 | [omega_compact.{u u} Y] : omega_compact.{_ u} (X × Y) := 102 | begin 103 | fapply omega_compact_of_equiv, 104 | { intro A f, 105 | exact calc 106 | seq_colim (seq_diagram_arrow_left f (X × Y)) 107 | ≃ seq_colim (seq_diagram_arrow_left (seq_diagram_arrow_left f Y) X) : 108 | begin 109 | apply seq_colim_equiv (λn, !imp_imp_equiv_prod_imp⁻¹ᵉ), 110 | intro n f, reflexivity 111 | end 112 | ... ≃ (X → seq_colim (seq_diagram_arrow_left f Y)) : !equiv_of_omega_compact 113 | ... ≃ (X → Y → seq_colim f) : arrow_equiv_arrow_right _ !equiv_of_omega_compact 114 | ... ≃ (X × Y → seq_colim f) : imp_imp_equiv_prod_imp }, 115 | { intros, induction x with x y, reflexivity }, 116 | { intros, induction x with x y, apply hdeg_square, 117 | refine ap_compose (λz, arrow_colim_of_colim_arrow f z y) _ _ ⬝ _, 118 | refine ap02 _ (ap_compose (λz, arrow_colim_of_colim_arrow _ z x) _ _) ⬝ _, 119 | refine ap02 _ (ap02 _ !elim_glue) ⬝ _, refine ap02 _ (ap02 _ !idp_con) ⬝ _, esimp, 120 | refine ap02 _ !elim_glue ⬝ _, apply elim_glue } 121 | end 122 | 123 | definition not_omega_compact_nat : ¬(omega_compact.{0 0} ℕ) := 124 | assume H, 125 | let e := equiv_of_omega_compact ℕ seq_diagram_fin ⬝e 126 | arrow_equiv_arrow_right _ seq_colim_fin_equiv in 127 | begin 128 | -- check_expr e, 129 | have Πx, ∥ Σn, Πm, e x m < n ∥, 130 | begin 131 | intro f, induction f using seq_colim.rec_prop with n f, 132 | refine tr ⟨n, _⟩, intro m, exact is_lt (f m) 133 | end, 134 | induction this (e⁻¹ᵉ id) with x, induction x with n H2, 135 | apply lt.irrefl n, 136 | refine lt_of_le_of_lt (le_of_eq _) (H2 n), 137 | exact ap10 (right_inv e id)⁻¹ n 138 | end 139 | 140 | exit 141 | print seq_diagram_over 142 | definition seq_colim_over_equiv {X : Type} {A : X → ℕ → Type} (g : Π⦃x n⦄, A x n → A x (succ n)) 143 | (x : X) 144 | : @seq_colim_over _ (constant_seq X) _ _ ≃ seq_colim (@g x) := 145 | begin 146 | 147 | end 148 | 149 | definition seq_colim_pi_equiv {X : Type} {A : X → ℕ → Type} (g : Π⦃x n⦄, A x n → A x (succ n)) 150 | [omega_compact X] : (Πx, seq_colim (@g x)) ≃ seq_colim (seq_diagram_pi g) := 151 | -- calc 152 | -- (Πx, seq_colim (@g x)) ≃ Πx, seq_colim (@g x) 153 | begin 154 | refine !pi_equiv_arrow_sigma ⬝e _, 155 | refine sigma_equiv_sigma_left (arrow_equiv_arrow_right X (sigma_equiv_sigma_left (seq_colim_constant_seq X)⁻¹ᵉ)) ⬝e _, 156 | exact sigma_equiv_sigma_left (arrow_equiv_arrow_right X _) ⬝e _, 157 | end 158 | 159 | set_option pp.universes true 160 | print seq_diagram_arrow_left 161 | 162 | end seq_colim 163 | -------------------------------------------------------------------------------- /colimit/omega_compact_sum.hlean: -------------------------------------------------------------------------------- 1 | import .omega_compact ..homotopy.fwedge 2 | 3 | open eq nat seq_colim is_trunc equiv is_equiv trunc sigma sum pi function algebra sigma.ops 4 | 5 | variables {A A' : ℕ → Type} (f : seq_diagram A) (f' : seq_diagram A') {n : ℕ} (a : A n) 6 | universe variable u 7 | 8 | definition kshift_up (k : ℕ) (x : seq_colim f) : seq_colim (kshift_diag f k) := 9 | begin 10 | induction x with n a n a, 11 | { apply ι' (kshift_diag f k) n, exact lrep f (le_add_left n k) a }, 12 | { exact ap (ι _) (lrep_f f _ a ⬝ lrep_irrel f _ _ a ⬝ !f_lrep⁻¹) ⬝ !glue } 13 | end 14 | 15 | definition kshift_down [unfold 4] (k : ℕ) (x : seq_colim (kshift_diag f k)) : seq_colim f := 16 | begin 17 | induction x with n a n a, 18 | { exact ι' f (k + n) a }, 19 | { exact glue f a } 20 | end 21 | 22 | definition kshift_equiv_eq_kshift_up (k : ℕ) (a : A n) : kshift_equiv f k (ι f a) = kshift_up f k (ι f a) := 23 | begin 24 | induction k with k p, 25 | { exact ap (ι _) !lrep_eq_transport⁻¹ }, 26 | { exact sorry } 27 | end 28 | 29 | definition kshift_equiv2 [constructor] (k : ℕ) : seq_colim f ≃ seq_colim (kshift_diag f k) := 30 | begin 31 | refine equiv_change_fun (kshift_equiv f k) _, 32 | exact kshift_up f k, 33 | intro x, induction x with n a n a, 34 | { exact kshift_equiv_eq_kshift_up f k a }, 35 | { exact sorry } 36 | end 37 | 38 | definition kshift_equiv_inv_eq_kshift_down (k : ℕ) (a : A (k + n)) : 39 | kshift_equiv_inv f k (ι' (kshift_diag f k) n a) = kshift_down f k (ι' (kshift_diag f k) n a) := 40 | begin 41 | induction k with k p, 42 | { exact apd011 (ι' _) _ !pathover_tr⁻¹ᵒ }, 43 | { exact sorry } 44 | end 45 | 46 | definition kshift_equiv_inv2 [constructor] (k : ℕ) : seq_colim (kshift_diag f k) ≃ seq_colim f := 47 | begin 48 | refine equiv_change_fun (equiv_change_inv (kshift_equiv_inv f k) _) _, 49 | { exact kshift_up f k }, 50 | { intro x, induction x with n a n a, 51 | { exact kshift_equiv_eq_kshift_up f k a }, 52 | { exact sorry }}, 53 | { exact kshift_down f k }, 54 | { intro x, induction x with n a n a, 55 | { exact !kshift_equiv_inv_eq_kshift_down }, 56 | { exact sorry }} 57 | end 58 | 59 | definition seq_colim_over_weakened_sequence [unfold 5] (x : seq_colim f) : 60 | seq_colim_over (weakened_sequence f f') x ≃ seq_colim f' := 61 | begin 62 | induction x with n a n a, 63 | { exact kshift_equiv_inv2 f' n }, 64 | { apply equiv_pathover_inv, apply arrow_pathover_constant_left, intro x, 65 | apply pathover_of_tr_eq, refine !seq_colim_over_glue ⬝ _, exact sorry } 66 | end 67 | 68 | definition seq_colim_prod' [constructor] : seq_colim (seq_diagram_prod f f') ≃ seq_colim f × seq_colim f' := 69 | calc 70 | seq_colim (seq_diagram_prod f f') ≃ seq_colim (seq_diagram_sigma (weakened_sequence f f')) : 71 | by exact seq_colim_equiv (λn, !sigma.equiv_prod⁻¹ᵉ) (λn a, idp) 72 | ... ≃ Σ(x : seq_colim f), seq_colim_over (weakened_sequence f f') x : 73 | by exact (sigma_seq_colim_over_equiv _ (weakened_sequence f f'))⁻¹ᵉ 74 | ... ≃ Σ(x : seq_colim f), seq_colim f' : 75 | by exact sigma_equiv_sigma_right (seq_colim_over_weakened_sequence f f') 76 | ... ≃ seq_colim f × seq_colim f' : 77 | by exact sigma.equiv_prod (seq_colim f) (seq_colim f') 78 | 79 | open prod prod.ops 80 | example {a' : A' n} : seq_colim_prod' f f' (ι _ (a, a')) = (ι f a, ι f' a') := idp 81 | 82 | definition seq_colim_prod_inv {a' : A' n} : (seq_colim_prod' f f')⁻¹ᵉ (ι f a, ι f' a') = (ι _ (a, a')) := 83 | begin 84 | exact sorry 85 | end 86 | 87 | definition prod_seq_colim_of_seq_colim_prod (x : seq_colim (seq_diagram_prod f f')) : 88 | seq_colim f × seq_colim f' := 89 | begin 90 | induction x with n x n x, 91 | { exact (ι f x.1, ι f' x.2) }, 92 | { exact prod_eq (glue f x.1) (glue f' x.2) } 93 | end 94 | 95 | definition seq_colim_prod [constructor] : 96 | seq_colim (seq_diagram_prod f f') ≃ seq_colim f × seq_colim f' := 97 | begin 98 | refine equiv_change_fun (seq_colim_prod' f f') _, 99 | exact prod_seq_colim_of_seq_colim_prod f f', 100 | intro x, induction x with n x n x, 101 | { reflexivity }, 102 | { induction x with a a', apply eq_pathover, apply hdeg_square, esimp, 103 | refine _ ⬝ !elim_glue⁻¹, 104 | refine ap_compose ((sigma.equiv_prod (seq_colim f) (seq_colim f') ∘ 105 | sigma_equiv_sigma_right (seq_colim_over_weakened_sequence f f')) ∘ 106 | sigma_colim_of_colim_sigma (weakened_sequence f f')) _ _ ⬝ _, 107 | refine ap02 _ (!elim_glue ⬝ !idp_con) ⬝ _, 108 | refine !ap_compose ⬝ _, refine ap02 _ !elim_glue ⬝ _, 109 | refine !ap_compose ⬝ _, esimp, refine ap02 _ !ap_sigma_functor_id_sigma_eq ⬝ _, 110 | apply inj (prod_eq_equiv _ _), apply pair_eq, 111 | { exact !ap_compose' ⬝ !sigma_eq_pr1 ⬝ !prod_eq_pr1⁻¹ }, 112 | { refine !ap_compose' ⬝ _ ⬝ !prod_eq_pr2⁻¹, esimp, 113 | refine !sigma_eq_pr2_constant ⬝ _, 114 | refine !eq_of_pathover_apo ⬝ _, exact sorry }} 115 | end 116 | 117 | local attribute equiv_of_omega_compact [constructor] 118 | 119 | definition omega_compact_sum [instance] [constructor] {X Y : Type} [omega_compact.{_ u} X] 120 | [omega_compact.{u u} Y] : omega_compact.{_ u} (X ⊎ Y) := 121 | begin 122 | fapply omega_compact_of_equiv, 123 | { intro A f, 124 | exact calc 125 | seq_colim (seq_diagram_arrow_left f (X ⊎ Y)) 126 | ≃ seq_colim (seq_diagram_prod (seq_diagram_arrow_left f X) (seq_diagram_arrow_left f Y)) : 127 | by exact seq_colim_equiv (λn, !imp_prod_imp_equiv_sum_imp⁻¹ᵉ) (λn f, idp) 128 | ... ≃ seq_colim (seq_diagram_arrow_left f X) × seq_colim (seq_diagram_arrow_left f Y) : 129 | by apply seq_colim_prod 130 | ... ≃ (X → seq_colim f) × (Y → seq_colim f) : 131 | by exact prod_equiv_prod (equiv_of_omega_compact X f) (equiv_of_omega_compact Y f) 132 | ... ≃ ((X ⊎ Y) → seq_colim f) : 133 | by exact !imp_prod_imp_equiv_sum_imp }, 134 | { intros, induction x with x y: reflexivity }, 135 | { intros, induction x with x y: apply hdeg_square, 136 | { refine ap_compose (((λz, arrow_colim_of_colim_arrow f z _) ∘ pr1) ∘ 137 | seq_colim_prod _ _) _ _ ⬝ _, refine ap02 _ (!elim_glue ⬝ !idp_con) ⬝ _, 138 | refine !ap_compose ⬝ _, refine ap02 _ !elim_glue ⬝ _, 139 | refine !ap_compose ⬝ _, refine ap02 _ !prod_eq_pr1 ⬝ !elim_glue }, 140 | { refine ap_compose (((λz, arrow_colim_of_colim_arrow f z _) ∘ pr2) ∘ 141 | seq_colim_prod _ _) _ _ ⬝ _, refine ap02 _ (!elim_glue ⬝ !idp_con) ⬝ _, 142 | refine !ap_compose ⬝ _, refine ap02 _ !elim_glue ⬝ _, 143 | refine !ap_compose ⬝ _, refine ap02 _ !prod_eq_pr2 ⬝ !elim_glue }}, 144 | end 145 | 146 | open wedge pointed circle 147 | 148 | /- needs fwedge! -/ 149 | definition seq_diagram_fwedge (X : Type*) : seq_diagram (λn, @fwedge (A n) (λa, X)) := 150 | sorry f 151 | 152 | definition seq_colim_fwedge_equiv (X : Type*) [is_trunc 1 X] : 153 | seq_colim (seq_diagram_fwedge f X) ≃ @fwedge (seq_colim f) (λn, X) := 154 | sorry 155 | 156 | definition not_omega_compact_fwedge_nat_circle : ¬(omega_compact.{0 0} (@fwedge ℕ (λn, S¹*))) := 157 | assume H, 158 | sorry 159 | -------------------------------------------------------------------------------- /colimit/sequence.hlean: -------------------------------------------------------------------------------- 1 | /- 2 | Copyright (c) 2015 Floris van Doorn. All rights reserved. 3 | Released under Apache 2.0 license as described in the file LICENSE. 4 | Authors: Floris van Doorn, Egbert Rijke 5 | -/ 6 | 7 | import ..move_to_lib types.fin types.trunc 8 | 9 | open nat eq equiv sigma sigma.ops is_equiv is_trunc trunc prod fiber function is_conn 10 | 11 | namespace seq_colim 12 | 13 | definition seq_diagram [reducible] (A : ℕ → Type) : Type := Π⦃n⦄, A n → A (succ n) 14 | 15 | structure Seq_diagram : Type := 16 | (carrier : ℕ → Type) 17 | (struct : seq_diagram carrier) 18 | 19 | definition is_equiseq [reducible] {A : ℕ → Type} (f : seq_diagram A) : Type := 20 | forall (n : ℕ), is_equiv (@f n) 21 | 22 | structure Equi_seq : Type := 23 | (carrier : ℕ → Type) 24 | (maps : seq_diagram carrier) 25 | (prop : is_equiseq maps) 26 | 27 | protected abbreviation Mk [constructor] := Seq_diagram.mk 28 | attribute Seq_diagram.carrier [coercion] 29 | attribute Seq_diagram.struct [coercion] 30 | 31 | variables {A A' : ℕ → Type} (f : seq_diagram A) (f' : seq_diagram A') {n m k : ℕ} 32 | include f 33 | 34 | definition lrep {n m : ℕ} (H : n ≤ m) : A n → A m := 35 | begin 36 | induction H with m H fs, 37 | { exact id }, 38 | { exact @f m ∘ fs } 39 | end 40 | 41 | definition lrep_irrel_pathover {n m m' : ℕ} (H₁ : n ≤ m) (H₂ : n ≤ m') (p : m = m') (a : A n) : 42 | lrep f H₁ a =[p] lrep f H₂ a := 43 | apo (λm H, lrep f H a) !is_prop.elimo 44 | 45 | definition lrep_irrel {n m : ℕ} (H₁ H₂ : n ≤ m) (a : A n) : lrep f H₁ a = lrep f H₂ a := 46 | ap (λH, lrep f H a) !is_prop.elim 47 | 48 | definition lrep_eq_transport {n m : ℕ} (H : n ≤ m) (p : n = m) (a : A n) : lrep f H a = transport A p a := 49 | begin induction p, exact lrep_irrel f H (nat.le_refl n) a end 50 | 51 | definition lrep_irrel2 {n m : ℕ} (H₁ H₂ : n ≤ m) (a : A n) : 52 | lrep_irrel f (le.step H₁) (le.step H₂) a = ap (@f m) (lrep_irrel f H₁ H₂ a) := 53 | begin 54 | have H₁ = H₂, from !is_prop.elim, induction this, 55 | refine ap02 _ !is_prop_elim_self ⬝ _ ⬝ ap02 _(ap02 _ !is_prop_elim_self⁻¹), 56 | reflexivity 57 | end 58 | 59 | definition lrep_eq_lrep_irrel {n m m' : ℕ} (H₁ : n ≤ m) (H₂ : n ≤ m') (a₁ a₂ : A n) (p : m = m') : 60 | (lrep f H₁ a₁ = lrep f H₁ a₂) ≃ (lrep f H₂ a₁ = lrep f H₂ a₂) := 61 | equiv_apd011 (λm H, lrep f H a₁ = lrep f H a₂) (is_prop.elimo p H₁ H₂) 62 | 63 | definition lrep_eq_lrep_irrel_natural {n m m' : ℕ} {H₁ : n ≤ m} (H₂ : n ≤ m') {a₁ a₂ : A n} 64 | (p : m = m') (q : lrep f H₁ a₁ = lrep f H₁ a₂) : 65 | lrep_eq_lrep_irrel f (le.step H₁) (le.step H₂) a₁ a₂ (ap succ p) (ap (@f m) q) = 66 | ap (@f m') (lrep_eq_lrep_irrel f H₁ H₂ a₁ a₂ p q) := 67 | begin 68 | esimp [lrep_eq_lrep_irrel], 69 | symmetry, 70 | refine fn_tro_eq_tro_fn2 _ (λa₁ a₂, ap (@f _)) q ⬝ _, 71 | refine ap (λx, x ▸o _) (@is_prop.elim _ _ _ _), 72 | apply is_trunc_pathover 73 | end 74 | 75 | definition is_equiv_lrep [constructor] [Hf : is_equiseq f] {n m : ℕ} (H : n ≤ m) : 76 | is_equiv (lrep f H) := 77 | begin 78 | induction H with m H Hlrepf, 79 | { apply is_equiv_id }, 80 | { exact is_equiv_compose (@f _) (lrep f H) _ _ }, 81 | end 82 | 83 | local attribute is_equiv_lrep [instance] 84 | definition lrep_back [reducible] [Hf : is_equiseq f] {n m : ℕ} (H : n ≤ m) : A m → A n := 85 | (lrep f H)⁻¹ᶠ 86 | 87 | section generalized_lrep 88 | 89 | /- lreplace le_of_succ_le with this -/ 90 | 91 | definition lrep_f {n m : ℕ} (H : succ n ≤ m) (a : A n) : 92 | lrep f H (f a) = lrep f (le_of_succ_le H) a := 93 | begin 94 | induction H with m H p, 95 | { reflexivity }, 96 | { exact ap (@f m) p } 97 | end 98 | 99 | definition lrep_lrep {n m k : ℕ} (H1 : n ≤ m) (H2 : m ≤ k) (a : A n) : 100 | lrep f H2 (lrep f H1 a) = lrep f (nat.le_trans H1 H2) a := 101 | begin 102 | induction H2 with k H2 p, 103 | { reflexivity }, 104 | { exact ap (@f k) p } 105 | end 106 | 107 | definition f_lrep {n m : ℕ} (H : n ≤ m) (a : A n) : f (lrep f H a) = lrep f (le.step H) a := idp 108 | 109 | definition rep (m : ℕ) (a : A n) : A (n + m) := 110 | lrep f (le_add_right n m) a 111 | 112 | definition rep0 (m : ℕ) (a : A 0) : A m := 113 | lrep f (zero_le m) a 114 | 115 | definition rep_pathover_rep0 {n : ℕ} (a : A 0) : rep f n a =[nat.zero_add n] rep0 f n a := 116 | !lrep_irrel_pathover 117 | 118 | definition rep_f (k : ℕ) (a : A n) : 119 | pathover A (rep f k (f a)) (succ_add n k) (rep f (succ k) a) := 120 | begin 121 | induction k with k IH, 122 | { constructor }, 123 | { unfold [succ_add], apply pathover_ap, exact apo f IH} 124 | end 125 | 126 | definition rep_rep (k l : ℕ) (a : A n) : 127 | pathover A (rep f k (rep f l a)) (nat.add_assoc n l k) (rep f (l + k) a) := 128 | begin 129 | induction k with k IH, 130 | { constructor}, 131 | { apply pathover_ap, exact apo f IH} 132 | end 133 | 134 | variables {f f'} 135 | definition is_trunc_fun_lrep (k : ℕ₋₂) (H : n ≤ m) (H2 : Πn, is_trunc_fun k (@f n)) : 136 | is_trunc_fun k (lrep f H) := 137 | begin induction H with m H IH, apply is_trunc_fun_id, exact is_trunc_fun_compose k (H2 m) IH end 138 | 139 | definition is_conn_fun_lrep (k : ℕ₋₂) (H : n ≤ m) (H2 : Πn, is_conn_fun k (@f n)) : 140 | is_conn_fun k (lrep f H) := 141 | begin induction H with m H IH, apply is_conn_fun_id, exact is_conn_fun_compose k (H2 m) IH end 142 | 143 | definition lrep_natural (τ : Π⦃n⦄, A n → A' n) (p : Π⦃n⦄ (a : A n), τ (f a) = f' (τ a)) 144 | {n m : ℕ} (H : n ≤ m) (a : A n) : τ (lrep f H a) = lrep f' H (τ a) := 145 | begin 146 | induction H with m H IH, reflexivity, exact p (lrep f H a) ⬝ ap (@f' m) IH 147 | end 148 | 149 | definition rep_natural (τ : Π⦃n⦄, A n → A' n) (p : Π⦃n⦄ (a : A n), τ (f a) = f' (τ a)) 150 | {n : ℕ} (k : ℕ) (a : A n) : τ (rep f k a) = rep f' k (τ a) := 151 | lrep_natural τ p _ a 152 | 153 | definition rep0_natural (τ : Π⦃n⦄, A n → A' n) (p : Π⦃n⦄ (a : A n), τ (f a) = f' (τ a)) 154 | (k : ℕ) (a : A 0) : τ (rep0 f k a) = rep0 f' k (τ a) := 155 | lrep_natural τ p _ a 156 | 157 | variables (f f') 158 | 159 | end generalized_lrep 160 | 161 | section shift 162 | 163 | definition shift_diag [unfold_full] : seq_diagram (λn, A (succ n)) := 164 | λn a, f a 165 | 166 | definition kshift_diag [unfold_full] (k : ℕ) : seq_diagram (λn, A (k + n)) := 167 | λn a, f a 168 | 169 | definition kshift_diag' [unfold_full] (k : ℕ) : seq_diagram (λn, A (n + k)) := 170 | λn a, transport A (succ_add n k)⁻¹ (f a) 171 | 172 | definition lrep_kshift_diag {n m k : ℕ} (H : m ≤ k) (a : A (n + m)) : 173 | lrep (kshift_diag f n) H a = lrep f (nat.add_le_add_left2 H n) a := 174 | by induction H with k H p; reflexivity; exact ap (@f _) p 175 | 176 | end shift 177 | 178 | section constructions 179 | 180 | omit f 181 | 182 | definition constant_seq (X : Type) : seq_diagram (λ n, X) := 183 | λ n x, x 184 | 185 | definition seq_diagram_arrow_left [unfold_full] (X : Type) : seq_diagram (λn, X → A n) := 186 | λn g x, f (g x) 187 | 188 | definition seq_diagram_prod [unfold_full] : seq_diagram (λn, A n × A' n) := 189 | λn, prod_functor (@f n) (@f' n) 190 | 191 | open fin 192 | definition seq_diagram_fin [unfold_full] : seq_diagram fin := 193 | lift_succ 194 | 195 | definition id0_seq [unfold_full] (a₁ a₂ : A 0) : ℕ → Type := 196 | λ k, rep0 f k a₁ = rep0 f k a₂ 197 | 198 | definition id0_seq_diagram [unfold_full] (a₁ a₂ : A 0) : seq_diagram (id0_seq f a₁ a₂) := 199 | λ (k : ℕ) (p : rep0 f k a₁ = rep0 f k a₂), ap (@f k) p 200 | 201 | definition id_seq [unfold_full] (n : ℕ) (a₁ a₂ : A n) : ℕ → Type := 202 | λ k, rep f k a₁ = rep f k a₂ 203 | 204 | definition id_seq_diagram [unfold_full] (n : ℕ) (a₁ a₂ : A n) : seq_diagram (id_seq f n a₁ a₂) := 205 | λ (k : ℕ) (p : rep f k a₁ = rep f k a₂), ap (@f (n + k)) p 206 | 207 | definition trunc_diagram [unfold_full] (k : ℕ₋₂) (f : seq_diagram A) : 208 | seq_diagram (λn, trunc k (A n)) := 209 | λn, trunc_functor k (@f n) 210 | 211 | end constructions 212 | 213 | section over 214 | 215 | variable {A} 216 | variable (P : Π⦃n⦄, A n → Type) 217 | 218 | definition seq_diagram_over : Type := Π⦃n⦄ {a : A n}, P a → P (f a) 219 | 220 | definition weakened_sequence [unfold_full] : seq_diagram_over f (λn a, A' n) := 221 | λn a a', f' a' 222 | 223 | definition id0_seq_diagram_over [unfold_full] (a₀ : A 0) : 224 | seq_diagram_over f (λn a, rep0 f n a₀ = a) := 225 | λn a p, ap (@f n) p 226 | 227 | variable (g : seq_diagram_over f P) 228 | variables {f P} 229 | 230 | definition seq_diagram_of_over [unfold_full] {n : ℕ} (a : A n) : 231 | seq_diagram (λk, P (rep f k a)) := 232 | λk p, g p 233 | 234 | definition seq_diagram_sigma [unfold 6] : seq_diagram (λn, Σ(x : A n), P x) := 235 | λn v, ⟨f v.1, g v.2⟩ 236 | 237 | variables (f P) 238 | 239 | theorem rep_f_equiv [constructor] (a : A n) (k : ℕ) : 240 | P (lrep f (le_add_right (succ n) k) (f a)) ≃ P (lrep f (le_add_right n (succ k)) a) := 241 | equiv_apd011 P (rep_f f k a) 242 | 243 | theorem rep_rep_equiv [constructor] (a : A n) (k l : ℕ) : 244 | P (rep f (l + k) a) ≃ P (rep f k (rep f l a)) := 245 | (equiv_apd011 P (rep_rep f k l a))⁻¹ᵉ 246 | 247 | end over 248 | 249 | omit f 250 | definition seq_diagram_pi {X : Type} {A : X → ℕ → Type} (g : Π⦃x n⦄, A x n → A x (succ n)) : 251 | seq_diagram (λn, Πx, A x n) := 252 | λn f x, g (f x) 253 | 254 | variables {f f'} 255 | definition seq_diagram_over_fiber (g : Π⦃n⦄, A' n → A n) 256 | (p : Π⦃n⦄ (a : A' n), g (f' a) = f (g a)) : seq_diagram_over f (λn, fiber (@g n)) := 257 | λk a, fiber_functor (@f' k) (@f k) (@p k) idp 258 | 259 | definition seq_diagram_fiber (g : Π⦃n⦄, A' n → A n) (p : Π⦃n⦄ (a : A' n), g (f' a) = f (g a)) 260 | {n : ℕ} (a : A n) : seq_diagram (λk, fiber (@g (n + k)) (rep f k a)) := 261 | seq_diagram_of_over (seq_diagram_over_fiber g p) a 262 | 263 | definition seq_diagram_fiber0 (g : Π⦃n⦄, A' n → A n) (p : Π⦃n⦄ (a : A' n), g (f' a) = f (g a)) 264 | (a : A 0) : seq_diagram (λk, fiber (@g k) (rep0 f k a)) := 265 | λk, fiber_functor (@f' k) (@f k) (@p k) idp 266 | 267 | 268 | end seq_colim 269 | -------------------------------------------------------------------------------- /component.hlean: -------------------------------------------------------------------------------- 1 | -- Author: Floris van Doorn 2 | 3 | import homotopy.connectedness .move_to_lib 4 | 5 | open eq equiv pointed is_conn is_trunc sigma prod trunc function group nat fiber 6 | 7 | namespace is_conn 8 | 9 | open sigma.ops pointed trunc_index 10 | 11 | /- this is equivalent to pfiber (A → ∥A∥₀) ≡ connect 0 A -/ 12 | definition component [constructor] (A : Type*) : Type* := 13 | pType.mk (Σ(a : A), merely (pt = a)) ⟨pt, tr idp⟩ 14 | 15 | lemma is_conn_component [instance] (A : Type*) : is_conn 0 (component A) := 16 | is_conn_zero_pointed' 17 | begin intro x, induction x with a p, induction p with p, induction p, exact tidp end 18 | 19 | definition component_incl [constructor] (A : Type*) : component A →* A := 20 | pmap.mk pr1 idp 21 | 22 | definition is_embedding_component_incl [instance] (A : Type*) : is_embedding (component_incl A) := 23 | is_embedding_pr1 _ 24 | 25 | definition component_intro [constructor] {A B : Type*} (f : A →* B) (H : merely_constant f) : 26 | A →* component B := 27 | begin 28 | fapply pmap.mk, 29 | { intro a, refine ⟨f a, _⟩, exact tinverse (merely_constant_pmap H a) }, 30 | exact subtype_eq !respect_pt 31 | end 32 | 33 | definition component_functor [constructor] {A B : Type*} (f : A →* B) : 34 | component A →* component B := 35 | component_intro (f ∘* component_incl A) !merely_constant_of_is_conn 36 | 37 | -- definition component_elim [constructor] {A B : Type*} (f : A →* B) (H : merely_constant f) : 38 | -- A →* component B := 39 | -- begin 40 | -- fapply pmap.mk, 41 | -- { intro a, refine ⟨f a, _⟩, exact tinverse (merely_constant_pmap H a) }, 42 | -- exact subtype_eq !respect_pt 43 | -- end 44 | 45 | definition loop_component (A : Type*) : Ω (component A) ≃* Ω A := 46 | loop_pequiv_loop_of_is_embedding (component_incl A) 47 | 48 | lemma loopn_component (n : ℕ) (A : Type*) : Ω[n+1] (component A) ≃* Ω[n+1] A := 49 | !loopn_succ_in ⬝e* loopn_pequiv_loopn n (loop_component A) ⬝e* !loopn_succ_in⁻¹ᵉ* 50 | 51 | -- lemma fundamental_group_component (A : Type*) : π₁ (component A) ≃g π₁ A := 52 | -- isomorphism_of_equiv (trunc_equiv_trunc 0 (loop_component A)) _ 53 | 54 | lemma homotopy_group_component (n : ℕ) (A : Type*) : πg[n+1] (component A) ≃g πg[n+1] A := 55 | homotopy_group_isomorphism_of_is_embedding (n+1) (component_incl A) 56 | 57 | definition is_trunc_component [instance] (n : ℕ₋₂) (A : Type*) [is_trunc n A] : 58 | is_trunc n (component A) := 59 | begin 60 | apply @is_trunc_sigma, intro a, cases n with n, 61 | { refine is_contr_of_inhabited_prop _ _, exact tr !is_prop.elim }, 62 | { exact is_trunc_succ_of_is_prop _ _ _ }, 63 | end 64 | 65 | definition ptrunc_component' (n : ℕ₋₂) (A : Type*) : 66 | ptrunc (n.+2) (component A) ≃* component (ptrunc (n.+2) A) := 67 | begin 68 | fapply pequiv.MK', 69 | { exact ptrunc.elim (n.+2) (component_functor !ptr) }, 70 | { intro x, cases x with x p, induction x with a, 71 | refine tr ⟨a, _⟩, 72 | note q := trunc_functor -1 !tr_eq_tr_equiv p, 73 | exact trunc_trunc_equiv_left _ !minus_one_le_succ q }, 74 | { exact sorry }, 75 | { exact sorry } 76 | end 77 | 78 | definition ptrunc_component (n : ℕ₋₂) (A : Type*) : 79 | ptrunc n (component A) ≃* component (ptrunc n A) := 80 | begin 81 | cases n with n, exact sorry, 82 | cases n with n, exact sorry, 83 | exact ptrunc_component' n A 84 | end 85 | 86 | definition break_into_components (A : Type) : A ≃ Σ(x : trunc 0 A), Σ(a : A), ∥ tr a = x ∥ := 87 | calc 88 | A ≃ Σ(a : A) (x : trunc 0 A), tr a = x : 89 | by exact (@sigma_equiv_of_is_contr_right _ _ (λa, !is_contr_sigma_eq))⁻¹ᵉ 90 | ... ≃ Σ(x : trunc 0 A) (a : A), tr a = x : 91 | by apply sigma_comm_equiv 92 | ... ≃ Σ(x : trunc 0 A), Σ(a : A), ∥ tr a = x ∥ : 93 | by exact sigma_equiv_sigma_right (λx, sigma_equiv_sigma_right (λa, !trunc_equiv⁻¹ᵉ)) 94 | 95 | definition pfiber_pequiv_component_of_is_contr [constructor] {A B : Type*} (f : A →* B) 96 | [is_contr B] 97 | /- extra condition, something like trunc_functor 0 f is an embedding -/ : pfiber f ≃* component A := 98 | sorry 99 | 100 | end is_conn 101 | -------------------------------------------------------------------------------- /heq.hlean: -------------------------------------------------------------------------------- 1 | -- Author: Floris van Doorn 2 | 3 | open eq is_trunc 4 | 5 | variables {I : Type} [is_set I] {P : I → Type} {i j k : I} {x x₁ x₂ : P i} {y y₁ y₂ : P j} {z : P k} 6 | {Q : Π⦃i⦄, P i → Type} 7 | 8 | structure heq (x : P i) (y : P j) : Type := 9 | (p : i = j) 10 | (q : x =[p] y) 11 | 12 | namespace eq 13 | notation x ` ==[`:50 P:0 `] `:0 y:50 := @heq _ _ P _ _ x y 14 | infix ` == `:50 := heq -- mostly for printing, since it will be almost always ambiguous what P is 15 | 16 | definition pathover_of_heq {p : i = j} (q : x ==[P] y) : x =[p] y := 17 | change_path !is_set.elim (heq.q q) 18 | 19 | definition eq_of_heq (p : x₁ ==[P] x₂) : x₁ = x₂ := 20 | eq_of_pathover_idp (pathover_of_heq p) 21 | 22 | definition heq.elim (p : x ==[P] y) (q : Q x) : Q y := 23 | begin 24 | induction p with p r, induction r, exact q 25 | end 26 | 27 | definition heq.refl [refl] (x : P i) : x ==[P] x := 28 | heq.mk idp idpo 29 | 30 | definition heq.rfl : x ==[P] x := 31 | heq.refl x 32 | 33 | definition heq.symm [symm] (p : x ==[P] y) : y ==[P] x := 34 | begin 35 | induction p with p q, constructor, exact q⁻¹ᵒ 36 | end 37 | 38 | definition heq_of_eq (p : x₁ = x₂) : x₁ ==[P] x₂ := 39 | heq.mk idp (pathover_idp_of_eq p) 40 | 41 | definition heq.trans [trans] (p : x ==[P] y) (p₂ : y ==[P] z) : x ==[P] z := 42 | begin 43 | induction p with p q, induction p₂ with p₂ q₂, constructor, exact q ⬝o q₂ 44 | end 45 | 46 | infix ` ⬝he `:72 := heq.trans 47 | postfix `⁻¹ʰᵉ`:(max+10) := heq.symm 48 | 49 | 50 | definition heq_of_heq_of_eq (p : x ==[P] y) (p₂ : y = y₂) : x ==[P] y₂ := 51 | p ⬝he heq_of_eq p₂ 52 | 53 | definition heq_of_eq_of_heq (p : x = x₂) (p₂ : x₂ ==[P] y) : x ==[P] y := 54 | heq_of_eq p ⬝he p₂ 55 | 56 | infix ` ⬝hep `:73 := concato_eq 57 | infix ` ⬝phe `:74 := eq_concato 58 | 59 | definition heq_tr (p : i = j) (x : P i) : x ==[P] transport P p x := 60 | heq.mk p !pathover_tr 61 | 62 | definition tr_heq (p : i = j) (x : P i) : transport P p x ==[P] x := 63 | (heq_tr p x)⁻¹ʰᵉ 64 | 65 | end eq 66 | -------------------------------------------------------------------------------- /homology/sphere.hlean: -------------------------------------------------------------------------------- 1 | /- 2 | Copyright (c) 2017 Kuen-Bang Hou (Favonia). 3 | Released under Apache 2.0 license as described in the file LICENSE. 4 | 5 | Author: Kuen-Bang Hou (Favonia) 6 | -/ 7 | 8 | import .basic 9 | 10 | open eq pointed group algebra circle sphere nat equiv susp 11 | function sphere homology int lift 12 | 13 | namespace homology 14 | 15 | section 16 | parameter (theory : homology_theory) 17 | 18 | open homology_theory 19 | 20 | theorem Hsphere : Π(n : ℤ)(m : ℕ), HH theory n (plift (sphere m)) ≃g HH theory (n - m) (plift (sphere 0)) := 21 | begin 22 | intros n m, revert n, induction m with m, 23 | { exact λ n, isomorphism_ap (λ n, HH theory n (plift (sphere 0))) (sub_zero n)⁻¹ }, 24 | { intro n, exact calc 25 | HH theory n (plift (susp (sphere m))) 26 | ≃g HH theory (succ (pred n)) (plift (susp (sphere m))) 27 | : by exact isomorphism_ap (λ n, HH theory n (plift (susp (sphere m)))) (succ_pred n)⁻¹ 28 | ... ≃g HH theory (pred n) (plift (sphere m)) : by exact Hplift_susp theory (pred n) (sphere m) 29 | ... ≃g HH theory (pred n - m) (plift (sphere 0)) : by exact v_0 (pred n) 30 | ... ≃g HH theory (n - succ m) (plift (sphere 0)) 31 | : by exact isomorphism_ap (λ n, HH theory n (plift (sphere 0))) (sub_sub n 1 m ⬝ ap (λ m, n - m) (add.comm 1 m)) 32 | } 33 | end 34 | end 35 | 36 | end homology 37 | -------------------------------------------------------------------------------- /homology/torus.hlean: -------------------------------------------------------------------------------- 1 | /- 2 | Copyright (c) 2017 Kuen-Bang Hou (Favonia). 3 | Released under Apache 2.0 license as described in the file LICENSE. 4 | 5 | Author: Kuen-Bang Hou (Favonia) 6 | -/ 7 | 8 | import .basic .sphere ..homotopy.susp_product 9 | 10 | open eq pointed group algebra circle sphere nat equiv susp 11 | function sphere homology int lift prod smash 12 | 13 | namespace homology 14 | 15 | section 16 | parameter (theory : ordinary_homology_theory) 17 | 18 | open ordinary_homology_theory 19 | 20 | theorem Hptorus : Π(n : ℤ)(m : ℕ), HH theory n (plift (sphere m ×* sphere m)) ≃g 21 | HH theory n (plift (sphere m)) ×g (HH theory n (plift (sphere m)) ×g HH theory n (plift (sphere (m + m)))) := λ n m, 22 | calc HH theory n (plift (sphere m ×* sphere m)) 23 | ≃g HH theory (n + 1) (plift (⅀ (sphere m ×* sphere m))) : by exact (Hplift_susp theory n (sphere m ×* sphere m))⁻¹ᵍ 24 | ... ≃g HH theory (n + 1) (plift (⅀ (sphere m) ∨ (⅀ (sphere m) ∨ ⅀ (sphere m ∧ sphere m)))) 25 | : by exact Hplift_isomorphism theory (n + 1) (susp_product (sphere m) (sphere m)) 26 | ... ≃g HH theory (n + 1) (plift (⅀ (sphere m))) ×g HH theory (n + 1) (plift (⅀ (sphere m) ∨ (⅀ (sphere m ∧ sphere m)))) 27 | : by exact Hplift_wedge theory (n + 1) (⅀ (sphere m)) (⅀ (sphere m) ∨ (⅀ (sphere m ∧ sphere m))) 28 | ... ≃g HH theory n (plift (sphere m)) ×g (HH theory n (plift (sphere m)) ×g HH theory n (plift (sphere (m + m)))) 29 | : by exact product_isomorphism (Hplift_susp theory n (sphere m)) 30 | (calc 31 | HH theory (n + 1) (plift (⅀ (sphere m) ∨ (⅀ (sphere m ∧ sphere m)))) 32 | ≃g HH theory (n + 1) (plift (⅀ (sphere m))) ×g HH theory (n + 1) (plift (⅀ (sphere m ∧ sphere m))) 33 | : by exact Hplift_wedge theory (n + 1) (⅀ (sphere m)) (⅀ (sphere m ∧ sphere m)) 34 | ... ≃g HH theory n (plift (sphere m)) ×g HH theory n (plift (sphere (m + m))) 35 | : by exact product_isomorphism (Hplift_susp theory n (sphere m)) 36 | (Hplift_susp theory n (sphere m ∧ sphere m) ⬝g Hplift_isomorphism theory n (sphere_smash_sphere m m))) 37 | 38 | end 39 | 40 | end homology 41 | -------------------------------------------------------------------------------- /homotopy/EMRing.hlean: -------------------------------------------------------------------------------- 1 | -- Authors: Floris van Doorn 2 | 3 | import .EM .smash_adjoint ..algebra.ring ..algebra.arrow_group 4 | 5 | open algebra eq EM is_equiv equiv is_trunc is_conn pointed trunc susp smash group nat function 6 | 7 | namespace EM 8 | 9 | 10 | definition EM1product_adj {R : Ring} : 11 | EM1 (AddGroup_of_Ring R) →* ppmap (EM1 (AddGroup_of_Ring R)) (EMadd1 (AddAbGroup_of_Ring R) 1) := 12 | begin 13 | have is_trunc 1 (ppmap (EM1 (AddGroup_of_Ring R)) (EMadd1 (AddAbGroup_of_Ring R) 1)), 14 | from is_trunc_pmap_of_is_conn _ _ !is_conn_EM1 _ _ _ (le.refl 2) !is_trunc_EMadd1, 15 | apply EM1_pmap, fapply inf_homomorphism.mk, 16 | { intro r, refine pfunext _ _, exact !loop_EM2⁻¹ᵉ* ∘* EM1_functor (ring_right_action r), }, 17 | { intro r r', exact sorry } 18 | end 19 | 20 | definition EMproduct_map {A B C : AbGroup} (φ : A → B →g C) (n m : ℕ) (a : A) : 21 | EMadd1 B n →* EMadd1 C n := 22 | begin 23 | fapply EMadd1_functor (φ a) n 24 | end 25 | 26 | definition EM0EMadd1product {A B C : AbGroup} (φ : A →g B →gg C) (n : ℕ) : 27 | A →* EMadd1 B n →** EMadd1 C n := 28 | EMadd1_pfunctor B C n ∘* pmap_of_homomorphism φ 29 | 30 | -- TODO: simplify 31 | definition EMadd1product {A B C : AbGroup} (φ : A →g B →gg C) (n m : ℕ) : 32 | EMadd1 A n →* EMadd1 B m →** EMadd1 C (m + succ n) := 33 | begin 34 | assert H1 : is_trunc n.+1 (EMadd1 B m →** EMadd1 C (m + succ n)), 35 | { refine is_trunc_pmap_of_is_conn _ (m.-1) !is_conn_EMadd1 _ _ _ _ !is_trunc_EMadd1, 36 | exact le_of_eq (trunc_index.of_nat_add_plus_two_of_nat m n)⁻¹ᵖ }, 37 | apply EMadd1_pmap, 38 | refine (gloopn_pmap_isomorphism (succ n) _ _)⁻¹ᵍ⁸ ∘∞g 39 | gpmap_loop_homomorphism_right (EMadd1 B m) (loopn_EMadd1_add_of_eq C !succ_add)⁻¹ᵉ* ∘∞g 40 | gloop_pmap_isomorphism _ _ ∘∞g 41 | (deloop_isomorphism _)⁻¹ᵍ⁸ ∘∞g 42 | EM_ehomomorphism B C (succ m) ∘∞g 43 | inf_homomorphism_of_homomorphism φ 44 | end 45 | 46 | definition EMproduct1 {A B C : AbGroup} (φ : A →g B →gg C) (n m : ℕ) : 47 | EM A n →* EM B m →** EM C (m + n) := 48 | begin 49 | cases n with n, 50 | { cases m with m, 51 | { exact pmap_of_homomorphism2 φ }, 52 | { exact EM0EMadd1product φ m }}, 53 | { cases m with m, 54 | { exact ppcompose_left (ptransport (EMadd1 C) (zero_add n)⁻¹) ∘* 55 | pmap_swap_map (EM0EMadd1product (homomorphism_swap φ) n) }, 56 | { exact ppcompose_left (ptransport (EMadd1 C) !succ_add⁻¹) ∘* EMadd1product φ n m }} 57 | end 58 | 59 | 60 | definition EMproduct2 {A B C : AbGroup} (φ : A →g B →gg C) (n m : ℕ) : 61 | EM A n →* (EM B m →** EM C (m + n)) := 62 | begin 63 | assert H1 : is_trunc n (gpmap_loop' (EM B m) (loop_EM C (m + n))), 64 | { exact is_trunc_pmap_of_is_conn_nat _ m !is_conn_EM _ _ _ !le.refl !is_trunc_EM }, 65 | apply EM_pmap (gpmap_loop' (EM B m) (loop_EM C (m + n))) n, 66 | exact sorry 67 | -- exact _ /- (loopn_ppmap_pequiv _ _ _)⁻¹ᵉ* -/ ∘∞g _ /-ppcompose_left !loopn_EMadd1_add⁻¹ᵉ*-/ ∘∞g 68 | -- _ ∘∞g inf_homomorphism_of_homomorphism φ 69 | 70 | end 71 | 72 | definition EMproduct3' {A B C : AbGroup} (φ : A →g B →gg C) (n m : ℕ) : 73 | gEM A n →∞g gpmap_loop' (EM B m) (loop_EM C (m + n)) := 74 | begin 75 | assert H1 : is_trunc n (gpmap_loop' (EM B m) (loop_EM C (m + n))), 76 | { exact is_trunc_pmap_of_is_conn_nat _ m !is_conn_EM _ _ _ !le.refl !is_trunc_EM }, 77 | -- refine EM_homomorphism _ _ _, 78 | -- --(gmap_loop' (EM B m) (loop_EM C (m + n))) n, 79 | -- exact _ /- (loopn_ppmap_pequiv _ _ _)⁻¹ᵉ* -/ ∘∞g _ /-ppcompose_left !loopn_EMadd1_add⁻¹ᵉ*-/ ∘∞g 80 | -- _ ∘∞g inf_homomorphism_of_homomorphism φ 81 | exact sorry 82 | end 83 | 84 | definition EMproduct4 {A B C : AbGroup} (φ : A →g B →gg C) (n m : ℕ) : 85 | gEM A n →∞g Ωg (EM B m →** EM C (m + n + 1)) := 86 | begin 87 | assert H1 : is_trunc (n+1) (EM B m →** EM C (m + n + 1)), 88 | { exact is_trunc_pmap_of_is_conn_nat _ m !is_conn_EM _ _ _ !le.refl !is_trunc_EM }, 89 | apply EM_homomorphism_gloop, 90 | refine (gloopn_pmap_isomorphism _ _ _)⁻¹ᵍ⁸ ∘∞g _ ∘∞g inf_homomorphism_of_homomorphism φ, 91 | 92 | -- exact _ /- (loopn_ppmap_pequiv _ _ _)⁻¹ᵉ* -/ ∘∞g _ /-ppcompose_left !loopn_EMadd1_add⁻¹ᵉ*-/ ∘∞g 93 | -- _ ∘∞g inf_homomorphism_of_homomorphism φ 94 | exact sorry 95 | end 96 | 97 | definition EMproduct5 {A B C : AbGroup} (φ : A →g B →gg C) (n m : ℕ) : 98 | InfGroup_of_deloopable (EM A n) →∞g InfGroup_of_deloopable (EM B m →** EM C (m + n)) := 99 | begin 100 | assert H1 : is_trunc (n + 1) (deloop (EM B m →** EM C (m + n))), 101 | { exact is_trunc_pmap_of_is_conn_nat _ m !is_conn_EM _ _ _ !le.refl !is_trunc_EM }, 102 | refine EM_homomorphism_deloopable _ _ _ _ _, 103 | 104 | -- exact _ /- (loopn_ppmap_pequiv _ _ _)⁻¹ᵉ* -/ ∘∞g _ /-ppcompose_left !loopn_EMadd1_add⁻¹ᵉ*-/ ∘∞g 105 | -- _ ∘∞g inf_homomorphism_of_homomorphism φ 106 | exact sorry 107 | end 108 | 109 | definition EMadd1product2 {A B C : AbGroup} (φ : A →g B →gg C) (n m : ℕ) : 110 | gEM A (n+1) →∞g Ωg[succ n] (EMadd1 B m →** EMadd1 C m) := 111 | begin 112 | assert H1 : is_trunc (n+1) (Ω[n] (EMadd1 B m →** EMadd1 C m)), 113 | { apply is_trunc_loopn, exact sorry }, 114 | -- refine EM_homomorphism_gloop (Ω[n] (EMadd1 B m →** EMadd1 C m)) _ _, 115 | /- the underlying pointed map is: -/ 116 | -- exact sorry 117 | -- refine (loopn_ppmap_pequiv _ _ _)⁻¹ᵉ* ∘* ppcompose_left !loopn_EMadd1_add⁻¹ᵉ* ∘* 118 | -- EM0EMadd1product φ m 119 | exact sorry 120 | end 121 | 122 | 123 | end EM 124 | -------------------------------------------------------------------------------- /homotopy/degree.hlean: -------------------------------------------------------------------------------- 1 | import homotopy.sphere2 ..move_to_lib 2 | 3 | open fin eq equiv group algebra sphere.ops pointed trunc is_equiv function circle int nat 4 | 5 | protected definition nat.eq_one_of_mul_eq_one {n : ℕ} (m : ℕ) (q : n * m = 1) : n = 1 := 6 | begin 7 | cases n with n, 8 | { exact empty.elim (succ_ne_zero 0 ((nat.zero_mul m)⁻¹ ⬝ q)⁻¹) }, 9 | { cases n with n, 10 | { reflexivity }, 11 | { apply empty.elim, cases m with m, 12 | { exact succ_ne_zero 0 q⁻¹ }, 13 | { apply nat.lt_irrefl 1, 14 | exact (calc 15 | 1 ≤ (m + 1) 16 | : succ_le_succ (nat.zero_le m) 17 | ... = 1 * (m + 1) 18 | : (nat.one_mul (m + 1))⁻¹ 19 | ... < (n + 2) * (m + 1) 20 | : nat.mul_lt_mul_of_pos_right 21 | (succ_le_succ (succ_le_succ (nat.zero_le n))) (zero_lt_succ m) 22 | ... = 1 : q) } } } 23 | end 24 | 25 | definition cases_of_nat_abs_eq {z : ℤ} (n : ℕ) (p : nat_abs z = n) 26 | : (z = of_nat n) ⊎ (z = - of_nat n) := 27 | begin 28 | cases p, apply by_cases_of_nat z, 29 | { intro n, apply sum.inl, reflexivity }, 30 | { intro n, apply sum.inr, exact ap int.neg (ap of_nat (nat_abs_neg n))⁻¹ } 31 | end 32 | 33 | definition eq_one_or_eq_neg_one_of_mul_eq_one {n : ℤ} (m : ℤ) (p : n * m = 1) : n = 1 ⊎ n = -1 := 34 | cases_of_nat_abs_eq 1 35 | (nat.eq_one_of_mul_eq_one (nat_abs m) 36 | ((int.nat_abs_mul n m)⁻¹ ⬝ ap int.nat_abs p)) 37 | 38 | definition endomorphism_int_unbundled (f : ℤ → ℤ) [is_add_hom f] (n : ℤ) : 39 | f n = f 1 * n := 40 | begin 41 | induction n using rec_nat_on with n IH n IH, 42 | { refine respect_zero f ⬝ _, exact !mul_zero⁻¹ }, 43 | { refine respect_add f n 1 ⬝ _, rewrite IH, 44 | rewrite [↑int.succ, left_distrib], apply ap (λx, _ + x), exact !mul_one⁻¹}, 45 | { rewrite [neg_nat_succ], refine respect_add f (-n) (- 1) ⬝ _, 46 | rewrite [IH, ↑int.pred, mul_sub_left_distrib], apply ap (λx, _ + x), 47 | refine _ ⬝ ap neg !mul_one⁻¹, exact respect_neg f 1 } 48 | end 49 | 50 | namespace sphere 51 | 52 | /- 53 | TODO: define for unbased maps, define for S 0, 54 | clear sorry s 55 | prove stable under suspension 56 | -/ 57 | 58 | attribute fundamental_group_of_circle fg_carrier_equiv_int [constructor] 59 | attribute untrunc_of_is_trunc [unfold 4] 60 | 61 | definition surf_eq_loop : @surf 1 = circle.loop := sorry 62 | /- 63 | Favonia had a good idea, which he got from Ulrik: use the cogroup structure on the suspension to construct a group structure on ΣX →* Y, from which you can easily show that deg(id) = 1. See in the Agda library the files cogroup, cohspace and Group/LoopSuspAdjoint (or something) 64 | -/ 65 | 66 | 67 | -- definition π2S2_surf : π2S2 (tr surf) = 1 :> ℤ := 68 | -- begin 69 | -- unfold [π2S2, chain_complex.LES_of_homotopy_groups], 70 | -- end 71 | 72 | -- check (pmap.to_fun 73 | -- (chain_complex.cc_to_fn 74 | -- (chain_complex.LES_of_homotopy_groups 75 | -- hopf.complex_phopf) 76 | -- (pair 1 2)) 77 | -- (tr surf)) 78 | 79 | -- eval (pmap.to_fun 80 | -- (chain_complex.cc_to_fn 81 | -- (chain_complex.LES_of_homotopy_groups 82 | -- hopf.complex_phopf) 83 | -- (pair 1 2)) 84 | -- (tr surf)) 85 | 86 | attribute gloopn [reducible] 87 | definition πnSn_surf (n : ℕ) : πnSn (n+1) (tr (@surf (n+1))) = 1 := 88 | begin 89 | cases n with n IH, 90 | { refine ap (πnSn _ ∘ tr) surf_eq_loop ⬝ _, apply transport_code_loop }, 91 | { unfold [πnSn], exact sorry} 92 | end 93 | 94 | definition deg {n : ℕ} [H : is_succ n] (f : S n →* S n) : ℤ := 95 | by induction H with n; exact πnSn (n+1) (π→g[n+1] f (tr (@surf (n+1)))) 96 | 97 | definition deg_id (n : ℕ) [H : is_succ n] : deg (pid (S n)) = (1 : ℤ) := 98 | by induction H with n; 99 | exact ap (πnSn (n+1)) (homotopy_group_functor_pid (succ n) (S (succ n)) (tr surf)) ⬝ πnSn_surf n 100 | 101 | definition deg_phomotopy {n : ℕ} [H : is_succ n] {f g : S n →* S n} (p : f ~* g) : 102 | deg f = deg g := 103 | begin 104 | induction H with n, 105 | exact ap (πnSn (n+1)) (homotopy_group_functor_phomotopy (succ n) p (tr surf)), 106 | end 107 | 108 | definition endomorphism_int (f : gℤ →g gℤ) (n : ℤ) : f n = f (1 : ℤ) *[ℤ] n := 109 | @endomorphism_int_unbundled f (homomorphism.addstruct f) n 110 | 111 | definition endomorphism_equiv_Z {X : Group} (e : X ≃g gℤ) {one : X} 112 | (p : e one = 1 :> ℤ) (φ : X →g X) (x : X) : e (φ x) = e (φ one) *[ℤ] e x := 113 | begin 114 | revert x, refine equiv_rect' (equiv_of_isomorphism e) _ _, 115 | intro n, 116 | refine endomorphism_int (e ∘g φ ∘g e⁻¹ᵍ) n ⬝ _, 117 | refine ap011 (@mul ℤ _) _ _, 118 | { esimp, apply ap (e ∘ φ), refine ap e⁻¹ᵍ p⁻¹ ⬝ _, 119 | exact to_left_inv (equiv_of_isomorphism e) one }, 120 | { symmetry, exact to_right_inv (equiv_of_isomorphism e) n} 121 | end 122 | 123 | definition deg_compose {n : ℕ} [H : is_succ n] (f g : S n →* S n) : 124 | deg (g ∘* f) = deg g *[ℤ] deg f := 125 | begin 126 | induction H with n, 127 | refine ap (πnSn (n+1)) (homotopy_group_functor_pcompose (succ n) g f (tr surf)) ⬝ _, 128 | apply endomorphism_equiv_Z !πnSn !πnSn_surf (π→g[n+1] g) 129 | end 130 | 131 | definition deg_equiv {n : ℕ} [H : is_succ n] (f : S n ≃* S n) : 132 | deg f = 1 ⊎ deg f = -1 := 133 | begin 134 | induction H with n, 135 | apply eq_one_or_eq_neg_one_of_mul_eq_one (deg f⁻¹ᵉ*), 136 | refine !deg_compose⁻¹ ⬝ _, 137 | refine deg_phomotopy (pright_inv f) ⬝ _, 138 | apply deg_id 139 | end 140 | 141 | end sphere 142 | -------------------------------------------------------------------------------- /homotopy/join_theorem.hlean: -------------------------------------------------------------------------------- 1 | /-- Authors: Clive, Egbert --/ 2 | 3 | import homotopy.connectedness homotopy.join 4 | 5 | open eq sigma pi function join is_conn is_trunc equiv is_equiv 6 | 7 | namespace retraction 8 | variables {A B C : Type} (r2 : B → C) (r1 : A → B) 9 | 10 | 11 | definition is_retraction_compose 12 | [Hr2 : is_retraction r2] [Hr1 : is_retraction r1] : 13 | is_retraction (r2 ∘ r1) := 14 | begin 15 | cases Hr2 with s2 s2_is_right_inverse, 16 | cases Hr1 with s1 s1_is_right_inverse, 17 | fapply is_retraction.mk, 18 | { exact s1 ∘ s2}, 19 | { intro b, esimp, 20 | calc 21 | r2 (r1 (s1 (s2 (b)))) = r2 (s2 (b)) : ap r2 (s1_is_right_inverse (s2 b)) 22 | ... = b : s2_is_right_inverse b 23 | 24 | }, /-- QED --/ 25 | end 26 | 27 | definition is_retraction_compose_equiv_left [Hr2 : is_equiv r2] [Hr1 : is_retraction r1] : is_retraction (r2 ∘ r1) := 28 | begin 29 | apply is_retraction_compose, 30 | end 31 | 32 | definition is_retraction_compose_equiv_right [Hr2 : is_retraction r2] [Hr1 : is_equiv r1] : is_retraction (r2 ∘ r1) := 33 | begin 34 | apply is_retraction_compose, 35 | end 36 | 37 | end retraction 38 | 39 | namespace is_conn 40 | section 41 | 42 | open retraction 43 | 44 | universe variable u 45 | parameters (n : ℕ₋₂) {A : Type.{u}} 46 | parameter sec : ΠV : trunctype.{u} n, 47 | is_retraction (const A : V → (A → V)) 48 | 49 | include sec 50 | 51 | protected definition intro : is_conn n A := 52 | begin 53 | apply is_conn_of_map_to_unit, 54 | apply is_conn_fun.intro, 55 | intro P, 56 | refine is_retraction_compose_equiv_right (const A) (pi_unit_left P), 57 | end 58 | end 59 | end is_conn 60 | 61 | section Join_Theorem 62 | 63 | variables (X Y : Type) 64 | (m n : ℕ₋₂) 65 | [HXm : is_conn m X] 66 | [HYn : is_conn n Y] 67 | 68 | include HXm HYn 69 | 70 | theorem is_conn_join : is_conn (m +2+ n) (join X Y) := 71 | begin 72 | apply is_conn.intro, 73 | intro V, 74 | apply is_retraction_of_is_equiv, 75 | apply is_equiv_of_is_contr_fun, 76 | intro f, 77 | refine is_contr_equiv_closed _ _, 78 | {exact unit}, 79 | symmetry, 80 | exact sorry 81 | end 82 | 83 | end Join_Theorem 84 | -------------------------------------------------------------------------------- /homotopy/realprojective.hlean: -------------------------------------------------------------------------------- 1 | -- Based on Buchholtz-Rijke: Real projective spaces in HoTT 2 | -- Author: Ulrik Buchholtz 3 | 4 | import homotopy.join 5 | 6 | open eq nat susp pointed sigma is_equiv equiv fiber is_trunc trunc 7 | trunc_index is_conn bool unit join pushout 8 | 9 | definition of_is_contr (A : Type) : is_contr A → A := @center A 10 | 11 | definition sigma_unit_left' [constructor] (B : unit → Type) 12 | : (Σx, B x) ≃ B star := 13 | begin 14 | fapply equiv.MK, 15 | { intro w, induction w with u b, induction u, exact b }, 16 | { intro b, exact ⟨ star, b ⟩ }, 17 | { intro b, reflexivity }, 18 | { intro w, induction w with u b, induction u, reflexivity } 19 | end 20 | 21 | definition sigma_eq_equiv' {A : Type} (B : A → Type) 22 | (a₁ a₂ : A) (b₁ : B a₁) (b₂ : B a₂) 23 | : (⟨a₁, b₁⟩ = ⟨a₂, b₂⟩) ≃ (Σ(p : a₁ = a₂), p ▸ b₁ = b₂) := 24 | calc (⟨a₁, b₁⟩ = ⟨a₂, b₂⟩) 25 | ≃ Σ(p : a₁ = a₂), b₁ =[p] b₂ : sigma_eq_equiv 26 | ... ≃ Σ(p : a₁ = a₂), p ▸ b₁ = b₂ 27 | : by apply sigma_equiv_sigma_right; intro e; apply pathover_equiv_tr_eq 28 | 29 | definition dec_eq_is_prop [instance] (A : Type) : is_prop (decidable_eq A) := 30 | begin 31 | apply is_prop.mk, intros h k, 32 | apply eq_of_homotopy, intro a, 33 | apply eq_of_homotopy, intro b, 34 | apply decidable.rec_on (h a b), 35 | { intro p, apply decidable.rec_on (k a b), 36 | { intro q, apply ap decidable.inl, apply is_set.elim }, 37 | { intro q, exact absurd p q } }, 38 | { intro p, apply decidable.rec_on (k a b), 39 | { intro q, exact absurd q p }, 40 | { intro q, apply ap decidable.inr, apply is_prop.elim } } 41 | end 42 | 43 | definition dec_eq_bool : decidable_eq bool := 44 | begin 45 | intro a, induction a: intro b: induction b, 46 | { exact decidable.inl idp }, 47 | { exact decidable.inr ff_ne_tt }, 48 | { exact decidable.inr (λ p, ff_ne_tt p⁻¹) }, 49 | { exact decidable.inl idp } 50 | end 51 | 52 | definition lemma_II_4 {A B : Type₀} (a : A) (b : B) 53 | (e f : A ≃ B) (p : e a = b) (q : f a = b) 54 | : (⟨e, p⟩ = ⟨f, q⟩) ≃ Σ (h : e ~ f), p = h a ⬝ q := 55 | calc (⟨e, p⟩ = ⟨f, q⟩) 56 | ≃ Σ (h : e = f), h ▸ p = q : sigma_eq_equiv' 57 | ... ≃ Σ (h : e ~ f), p = h a ⬝ q : 58 | begin 59 | apply sigma_equiv_sigma ((equiv_eq_char e f) ⬝e !eq_equiv_homotopy), 60 | intro h, induction h, esimp, change (p = q) ≃ (p = idp ⬝ q), 61 | rewrite idp_con 62 | end 63 | 64 | -- the type of two-element types 65 | structure BoolType := 66 | (carrier : Type₀) 67 | (bool_eq_carrier : ∥ bool = carrier ∥) 68 | attribute BoolType.carrier [coercion] 69 | 70 | -- the basepoint 71 | definition pointed_BoolType [instance] : pointed BoolType := 72 | pointed.mk (BoolType.mk bool (tr idp)) 73 | 74 | definition pBoolType : pType := pType.mk BoolType pt 75 | 76 | definition BoolType.sigma_char : BoolType ≃ { X : Type₀ | ∥ bool = X ∥ } := 77 | begin 78 | fapply equiv.MK: intro Xf: induction Xf with X f, 79 | { exact ⟨ X, f ⟩ }, { exact BoolType.mk X f }, 80 | { esimp }, { esimp } 81 | end 82 | 83 | definition BoolType.eq_equiv_equiv (A B : BoolType) 84 | : (A = B) ≃ (A ≃ B) := 85 | calc (A = B) 86 | ≃ (BoolType.sigma_char A = BoolType.sigma_char B) 87 | : eq_equiv_fn_eq 88 | ... ≃ (BoolType.carrier A = BoolType.carrier B) 89 | : begin 90 | induction A with A p, induction B with B q, 91 | symmetry, esimp, apply equiv_subtype 92 | end 93 | ... ≃ (A ≃ B) : eq_equiv_equiv A B 94 | 95 | definition lemma_II_3 {A B : BoolType} (a : A) (b : B) 96 | : (⟨A, a⟩ = ⟨B, b⟩) ≃ Σ (e : A ≃ B), e a = b := 97 | calc (⟨A, a⟩ = ⟨B, b⟩) 98 | ≃ Σ (e : A = B), e ▸ a = b : sigma_eq_equiv' 99 | ... ≃ Σ (e : A ≃ B), e a = b : 100 | begin 101 | apply sigma_equiv_sigma 102 | (BoolType.eq_equiv_equiv A B), 103 | intro e, induction e, unfold BoolType.eq_equiv_equiv, 104 | induction A with A p, esimp 105 | end 106 | 107 | definition theorem_II_2_lemma_1 (e : bool ≃ bool) 108 | (p : e tt = tt) : e ff = ff := 109 | sum.elim (dichotomy (e ff)) (λ q, q) 110 | begin 111 | intro q, apply empty.elim, apply ff_ne_tt, 112 | apply to_inv (eq_equiv_fn_eq e ff tt), 113 | exact q ⬝ p⁻¹, 114 | end 115 | 116 | definition theorem_II_2_lemma_2 (e : bool ≃ bool) 117 | (p : e tt = ff) : e ff = tt := 118 | sum.elim (dichotomy (e ff)) 119 | begin 120 | intro q, apply empty.elim, apply ff_ne_tt, 121 | apply to_inv (eq_equiv_fn_eq e ff tt), 122 | exact q ⬝ p⁻¹ 123 | end 124 | begin 125 | intro q, exact q 126 | end 127 | 128 | definition theorem_II_2 : is_contr (Σ (X : BoolType), X) := 129 | begin 130 | fapply is_contr.mk, 131 | { exact sigma.mk pt tt }, 132 | { intro w, induction w with Xf x, induction Xf with X f, 133 | apply to_inv (lemma_II_3 tt x), apply of_is_contr, 134 | induction f with f, induction f, induction x, 135 | { apply is_contr.mk ⟨ equiv_bnot, idp ⟩, 136 | intro w, induction w with e p, symmetry, 137 | apply to_inv (lemma_II_4 tt ff e equiv_bnot p idp), 138 | fapply sigma.mk, 139 | { intro b, induction b, 140 | { exact theorem_II_2_lemma_2 e p }, 141 | { exact p } }, 142 | { reflexivity } }, 143 | { apply is_contr.mk ⟨ erfl, idp ⟩, 144 | intro w, induction w with e p, symmetry, 145 | apply to_inv (lemma_II_4 tt tt e erfl p idp), 146 | fapply sigma.mk, 147 | { intro b, induction b, 148 | { exact theorem_II_2_lemma_1 e p }, 149 | { exact p } }, 150 | { reflexivity } } } 151 | end 152 | 153 | definition corollary_II_6 : Π A : BoolType, (pt = A) ≃ A := 154 | @total_space_method BoolType pt BoolType.carrier theorem_II_2 pt 155 | 156 | definition is_conn_BoolType [instance] : is_conn 0 BoolType := 157 | begin 158 | apply is_contr.mk (tr pt), 159 | intro X, induction X with X, induction X with X p, 160 | induction p with p, induction p, reflexivity 161 | end 162 | 163 | definition bool_type_dec_eq : Π (A : BoolType), decidable_eq A := 164 | @is_conn.is_conn.elim -1 pBoolType is_conn_BoolType 165 | (λ A : BoolType, decidable_eq A) _ dec_eq_bool 166 | 167 | definition alpha (A : BoolType) (x y : A) : bool := 168 | decidable.rec_on (bool_type_dec_eq A x y) 169 | (λ p, tt) (λ q, ff) 170 | 171 | definition alpha_inv (a b : bool) : alpha pt a (alpha pt a b) = b := 172 | begin 173 | induction a: induction b: esimp 174 | end 175 | 176 | definition is_equiv_alpha [instance] : Π {A : BoolType} (a : A), 177 | is_equiv (alpha A a) := 178 | begin 179 | apply @is_conn.elim -1 pBoolType is_conn_BoolType 180 | (λ A : BoolType, Π a : A, is_equiv (alpha A a)), 181 | intro a, 182 | exact adjointify (alpha pt a) (alpha pt a) (alpha_inv a) (alpha_inv a) 183 | end 184 | 185 | definition alpha_equiv (A : BoolType) (a : A) : A ≃ bool := 186 | equiv.mk (alpha A a) (is_equiv_alpha a) 187 | 188 | definition alpha_symm : Π (A : BoolType) (x y : A), 189 | alpha A x y = alpha A y x := 190 | begin 191 | apply @is_conn.elim -1 pBoolType is_conn_BoolType 192 | (λ A : BoolType, Π x y : A, alpha A x y = alpha A y x), 193 | intros x y, induction x: induction y: esimp 194 | end 195 | 196 | -- we define the type of types together with a line bundle 197 | structure two_cover := 198 | (carrier : Type₀) 199 | (cov : carrier → Type₀) 200 | (cov_eq : Π x : carrier, ∥ bool = cov x ∥ ) 201 | open two_cover 202 | 203 | definition unit_two_cover : two_cover := 204 | two_cover.mk unit (λ u, bool) (λ u, tr idp) 205 | 206 | open sigma.ops 207 | 208 | definition two_cover_step (X : two_cover) : two_cover := 209 | begin 210 | fapply two_cover.mk, 211 | { exact pushout (@sigma.pr1 (carrier X) (cov X)) (λ x, star) }, 212 | { fapply pushout.elim_type, 213 | { intro x, exact cov X x }, 214 | { intro u, exact BoolType.carrier pt }, 215 | { intro w, exact alpha_equiv 216 | (BoolType.mk (cov X w.1) (cov_eq X w.1)) w.2 } }, 217 | { fapply pushout.rec, 218 | { intro x, exact cov_eq X x }, 219 | { intro u, exact tr idp }, 220 | { intro w, apply is_prop.elimo } } 221 | end 222 | 223 | definition realprojective_two_cover : ℕ → two_cover := 224 | nat.rec unit_two_cover (λ x, two_cover_step) 225 | 226 | definition realprojective : ℕ → Type₀ := 227 | λ n, carrier (realprojective_two_cover n) 228 | 229 | definition realprojective_cov [reducible] (n : ℕ) 230 | : realprojective n → BoolType := 231 | λ x, BoolType.mk 232 | (cov (realprojective_two_cover n) x) 233 | (cov_eq (realprojective_two_cover n) x) 234 | 235 | definition theorem_III_3_u [reducible] (n : ℕ) 236 | : (Σ (w : Σ x, realprojective_cov n x), realprojective_cov n w.1) 237 | ≃ (Σ x, realprojective_cov n x) × bool := 238 | calc (Σ (w : Σ x, realprojective_cov n x), realprojective_cov n w.1) 239 | ≃ (Σ (w : Σ x, realprojective_cov n x), realprojective_cov n w.1) 240 | : sigma_assoc_comm_equiv 241 | ... ≃ Σ (w : Σ x, realprojective_cov n x), bool 242 | : @sigma_equiv_sigma_right (Σ x : realprojective n, realprojective_cov n x) 243 | (λ w, realprojective_cov n w.1) (λ w, bool) 244 | (λ w, alpha_equiv (realprojective_cov n w.1) w.2) 245 | ... ≃ (Σ x, realprojective_cov n x) × bool 246 | : equiv_prod 247 | 248 | definition theorem_III_3 (n : ℕ) 249 | : sphere n ≃ sigma (realprojective_cov n) := 250 | begin 251 | induction n with n IH, 252 | { symmetry, apply sigma_unit_left }, 253 | { apply equiv.trans (join_bool (sphere n))⁻¹ᵉ, 254 | apply equiv.trans (join_equiv_join erfl IH), 255 | symmetry, refine equiv.trans _ !join_symm, 256 | apply equiv.trans !pushout.flattening, esimp, 257 | fapply pushout.equiv, 258 | { unfold function.compose, exact theorem_III_3_u n}, 259 | { reflexivity }, 260 | { exact sigma_unit_left' (λ u, bool) }, 261 | { unfold function.compose, esimp, intro w, 262 | induction w with w z, induction w with x y, 263 | reflexivity }, 264 | { unfold function.compose, esimp, intro w, 265 | induction w with w z, induction w with x y, 266 | exact alpha_symm (realprojective_cov n x) y z } } 267 | end 268 | -------------------------------------------------------------------------------- /homotopy/spherical_fibrations.hlean: -------------------------------------------------------------------------------- 1 | import homotopy.join homotopy.smash types.nat.hott 2 | 3 | open eq equiv trunc function bool join sphere sphere.ops prod 4 | open pointed sigma smash is_trunc nat 5 | 6 | namespace spherical_fibrations 7 | 8 | /- classifying type of spherical fibrations -/ 9 | definition BG (n : ℕ) [is_succ n] : Type₁ := 10 | Σ(X : Type₀), ∥ X ≃ S (pred n) ∥ 11 | 12 | definition pointed_BG [instance] [constructor] (n : ℕ) [is_succ n] : pointed (BG n) := 13 | pointed.mk ⟨ S (pred n) , tr erfl ⟩ 14 | 15 | definition pBG [constructor] (n : ℕ) [is_succ n] : Type* := pointed.mk' (BG n) 16 | 17 | definition G (n : ℕ) [is_succ n] : Type₁ := 18 | pt = pt :> BG n 19 | 20 | definition G_char (n : ℕ) [is_succ n] : G n ≃ (S (pred n) ≃ S (pred n)) := 21 | calc 22 | G n ≃ Σ(p : pType.carrier (S (pred n)) = pType.carrier (S (pred n))), _ : sigma_eq_equiv 23 | ... ≃ (pType.carrier (S (pred n)) = pType.carrier (S (pred n))) : sigma_equiv_of_is_contr_right _ _ 24 | ... ≃ (S (pred n) ≃ S (pred n)) : eq_equiv_equiv 25 | 26 | definition mirror (n : ℕ) [is_succ n] : S (pred n) → G n := 27 | begin 28 | intro v, apply to_inv (G_char n), 29 | exact sorry 30 | end 31 | 32 | /- 33 | Can we give a fibration P : S n → Type, P base = F n = Ω(BF n) = (S. n ≃* S. n) 34 | and total space sigma P ≃ G (n+1) = Ω(BG (n+1)) = (S n.+1 ≃ S .n+1) 35 | 36 | Yes, let eval : BG (n+1) → S n be the evaluation map 37 | -/ 38 | definition is_succ_1 [instance] : is_succ 1 := is_succ.mk 0 39 | 40 | definition S_of_BG (n : ℕ) : Ω(pBG (n+1)) → S n := 41 | λ f, f..1 ▸ pt 42 | 43 | definition BG_succ (n : ℕ) [H : is_succ n] : BG n → BG (n+1) := 44 | begin 45 | induction H with n, 46 | intro X, cases X with X p, 47 | refine sigma.mk (susp X) _, induction p with f, apply tr, 48 | exact susp.equiv f 49 | end 50 | 51 | /- classifying type of pointed spherical fibrations -/ 52 | definition BF (n : ℕ) : Type₁ := 53 | Σ(X : Type*), ∥ X ≃* S n ∥ 54 | 55 | definition pointed_BF [instance] [constructor] (n : ℕ) : pointed (BF n) := 56 | pointed.mk ⟨ S n , tr pequiv.rfl ⟩ 57 | 58 | definition pBF [constructor] (n : ℕ) : Type* := pointed.mk' (BF n) 59 | 60 | definition BF_succ (n : ℕ) : BF n → BF (n+1) := 61 | begin 62 | intro X, cases X with X p, 63 | apply sigma.mk (susp X), induction p with f, apply tr, 64 | apply susp.susp_pequiv f 65 | end 66 | 67 | definition BF_of_BG {n : ℕ} [H : is_succ n] : BG n → BF n := 68 | begin 69 | induction H with n, 70 | intro X, cases X with X p, 71 | apply sigma.mk (pointed.MK (susp X) susp.north), 72 | induction p with f, apply tr, 73 | apply pequiv_of_equiv (susp.equiv f), 74 | reflexivity 75 | end 76 | 77 | definition BG_of_BF {n : ℕ} : BF n → BG (n + 1) := 78 | begin 79 | intro X, cases X with X hX, 80 | apply sigma.mk (carrier X), induction hX with fX, 81 | apply tr, exact fX 82 | end 83 | 84 | definition BG_mul {n m : ℕ} [Hn : is_succ n] [Hm : is_succ m] (X : BG n) (Y : BG m) : 85 | BG (n + m) := 86 | begin 87 | induction Hn with n, induction Hm with m, 88 | cases X with X pX, cases Y with Y pY, 89 | apply sigma.mk (join X Y), 90 | induction pX with fX, induction pY with fY, 91 | apply tr, rewrite [succ_add], 92 | exact join_equiv_join fX fY ⬝e join_sphere n m 93 | end 94 | 95 | definition BF_mul {n m : ℕ} (X : BF n) (Y : BF m) : BF (n + m) := 96 | begin 97 | cases X with X hX, cases Y with Y hY, 98 | apply sigma.mk (smash X Y), 99 | induction hX with fX, induction hY with fY, apply tr, 100 | exact sorry -- needs smash.spheres : psmash (S. n) (S. m) ≃ S. (n + m) 101 | end 102 | 103 | definition BF_of_BG_mul (n m : ℕ) [is_succ n] [is_succ m] (X : BG n) (Y : BG m) 104 | : BF_of_BG (BG_mul X Y) = BF_mul (BF_of_BG X) (BF_of_BG Y) := 105 | sorry 106 | 107 | -- Thom spaces 108 | namespace thom 109 | variables {X : Type} {n : ℕ} (α : X → BF n) 110 | 111 | -- the canonical section of an F-object 112 | protected definition sec (x : X) : carrier (sigma.pr1 (α x)) := 113 | Point _ 114 | 115 | open pushout sigma 116 | 117 | definition thom_space : Type := 118 | pushout (λx : X, ⟨x , thom.sec α x⟩) (const X unit.star) 119 | end thom 120 | 121 | /- 122 | Things to do: 123 | - Orientability and orientations 124 | * Thom class u ∈ ~Hⁿ(Tξ) 125 | * eventually prove Thom-Isomorphism (Rudyak IV.5.7) 126 | - define BG∞ and BF∞ as colimits of BG n and BF n 127 | - Ω(BF n) = ΩⁿSⁿ₁ + ΩⁿSⁿ₋₁ (self-maps of degree ±1) 128 | - succ_BF n is (n - 2) connected (from Freudenthal) 129 | - pfiber (BG_of_BF n) ≃* S. n 130 | - π₁(BF n)=π₁(BG n)=ℤ/2ℤ 131 | - double covers BSG and BSF 132 | - O : BF n → BG 1 = Σ(A : Type), ∥ A = bool ∥ 133 | - BSG n = sigma O 134 | - π₁(BSG n)=π₁(BSF n)=O 135 | - BSO(n), 136 | - find BF' n : Type₀ with BF' n ≃ BF n etc. 137 | - canonical bundle γₙ : ℝP(n) → ℝP∞=BO(1) → Type₀ 138 | prove T(γₙ) = ℝP(n+1) 139 | - BG∞ = BF∞ (in fact = BGL₁(S), the group of units of the sphere spectrum) 140 | - clutching construction: 141 | any f : S n → SG(n) gives S n.+1 → BSG(n) (mut.mut. for O(n),SO(n),etc.) 142 | - all bundles on S 3 are trivial, incl. tangent bundle 143 | - Adams' result on vector fields on spheres: 144 | there are maximally ρ(n)-1 indep.sections of the tangent bundle of S (n-1) 145 | where ρ(n) is the n'th Radon-Hurwitz number.→ 146 | -/ 147 | 148 | -- tangent bundle on S 2: 149 | 150 | namespace two_sphere 151 | 152 | definition tau : S 2 → BG 2 := 153 | begin 154 | intro v, induction v with x, do 2 exact pt, 155 | exact sorry 156 | end 157 | 158 | end two_sphere 159 | 160 | end spherical_fibrations 161 | -------------------------------------------------------------------------------- /homotopy/susp.hlean: -------------------------------------------------------------------------------- 1 | import .pushout types.pointed2 ..move_to_lib 2 | 3 | open susp eq pointed function is_equiv lift equiv is_trunc nat 4 | 5 | namespace susp 6 | variables {X X' Y Y' Z : Type*} 7 | 8 | definition susp_functor_of_fn [constructor] (f : X → Y) : susp X →* susp Y := 9 | pmap.mk (susp_functor' f) idp 10 | definition susp_pequiv_of_equiv [constructor] (f : X ≃ Y) : susp X ≃* susp Y := 11 | pequiv_of_equiv (susp.equiv f) idp 12 | 13 | definition iterate_susp_iterate_susp_rev (n m : ℕ) (A : Type*) : 14 | iterate_susp n (iterate_susp m A) ≃* iterate_susp (m + n) A := 15 | begin 16 | induction n with n e, 17 | { reflexivity }, 18 | { exact susp_pequiv e } 19 | end 20 | 21 | definition iterate_susp_pequiv [constructor] (n : ℕ) {X Y : Type*} (f : X ≃* Y) : 22 | iterate_susp n X ≃* iterate_susp n Y := 23 | begin 24 | induction n with n e, 25 | { exact f }, 26 | { exact susp_pequiv e } 27 | end 28 | 29 | open algebra nat 30 | definition iterate_susp_iterate_susp (n m : ℕ) (A : Type*) : 31 | iterate_susp n (iterate_susp m A) ≃* iterate_susp (n + m) A := 32 | iterate_susp_iterate_susp_rev n m A ⬝e* pequiv_of_eq (ap (λk, iterate_susp k A) (add.comm m n)) 33 | 34 | definition plift_susp.{u v} : Π(A : Type*), plift.{u v} (susp A) ≃* susp (plift.{u v} A) := 35 | begin 36 | intro A, 37 | calc 38 | plift.{u v} (susp A) ≃* susp A : by exact (pequiv_plift (susp A))⁻¹ᵉ* 39 | ... ≃* susp (plift.{u v} A) : by exact susp_pequiv (pequiv_plift.{u v} A) 40 | end 41 | 42 | definition is_contr_susp [instance] (A : Type) [H : is_contr A] : is_contr (susp A) := 43 | begin 44 | apply is_contr.mk north, 45 | intro x, induction x, 46 | reflexivity, 47 | exact merid !center, 48 | apply eq_pathover_constant_left_id_right, apply square_of_eq, 49 | exact whisker_left idp (ap merid !eq_of_is_contr) 50 | end 51 | 52 | definition loop_susp_pintro_phomotopy {X Y : Type*} {f g : ⅀ X →* Y} (p : f ~* g) : 53 | loop_susp_pintro X Y f ~* loop_susp_pintro X Y g := 54 | pwhisker_right (loop_susp_unit X) (Ω⇒ p) 55 | 56 | variables {A₀₀ A₂₀ A₀₂ A₂₂ : Type*} 57 | {f₁₀ : A₀₀ →* A₂₀} {f₁₂ : A₀₂ →* A₂₂} 58 | {f₀₁ : A₀₀ →* A₀₂} {f₂₁ : A₂₀ →* A₂₂} 59 | 60 | definition susp_functor_psquare (p : psquare f₁₀ f₁₂ f₀₁ f₂₁) : 61 | psquare (⅀→ f₁₀) (⅀→ f₁₂) (⅀→ f₀₁) (⅀→ f₂₁) := 62 | !susp_functor_pcompose⁻¹* ⬝* susp_functor_phomotopy p ⬝* !susp_functor_pcompose 63 | 64 | definition susp_to_loop_psquare (f₁₀ : A₀₀ →* A₂₀) (f₁₂ : A₀₂ →* A₂₂) 65 | (f₀₁ : susp A₀₀ →* A₀₂) (f₂₁ : susp A₂₀ →* A₂₂) : psquare (⅀→ f₁₀) f₁₂ f₀₁ f₂₁ → 66 | psquare f₁₀ (Ω→ f₁₂) (loop_susp_pintro A₀₀ A₀₂ f₀₁) (loop_susp_pintro A₂₀ A₂₂ f₂₁) := 67 | begin 68 | intro p, 69 | refine pvconcat _ (ap1_psquare p), 70 | exact (loop_susp_unit_natural f₁₀)⁻¹* 71 | end 72 | 73 | definition loop_to_susp_square (f₁₀ : A₀₀ →* A₂₀) (f₁₂ : A₀₂ →* A₂₂) 74 | (f₀₁ : A₀₀ →* Ω A₀₂) (f₂₁ : A₂₀ →* Ω A₂₂) : psquare f₁₀ (Ω→ f₁₂) f₀₁ f₂₁ → 75 | psquare (⅀→ f₁₀) f₁₂ (susp_pelim A₀₀ A₀₂ f₀₁) (susp_pelim A₂₀ A₂₂ f₂₁) := 76 | begin 77 | intro p, 78 | refine susp_functor_psquare p ⬝v* _, 79 | exact ptranspose (loop_susp_counit_natural f₁₂) 80 | end 81 | 82 | open pushout unit prod sigma sigma.ops 83 | 84 | section 85 | parameters {A : Type*} {n : ℕ} [HA : is_conn n A] 86 | 87 | -- we end up not using this, because to prove that the 88 | -- composition with the first projection is loop_susp_counit A 89 | -- is hideous without HIT computations on path constructors 90 | parameter (A) 91 | definition pullback_diagonal_prod_of_wedge : susp (Ω A) 92 | ≃ Σ (a : A) (w : wedge A A), prod_of_wedge w = (a, a) := 93 | begin 94 | refine equiv.trans _ 95 | (comm_equiv_unc (λ z, prod_of_wedge (prod.pr1 z) = (prod.pr2 z, prod.pr2 z))), 96 | apply equiv.symm, 97 | apply equiv.trans (sigma_equiv_sigma_right 98 | (λ w, sigma_equiv_sigma_right 99 | (λ a, prod_eq_equiv (prod_of_wedge w) (a, a)))), 100 | apply equiv.trans !pushout.flattening', esimp, 101 | fapply pushout.equiv 102 | (λ z, ⟨pt, z.2⟩) (λ z, ⟨pt, glue z.1 ▸ z.2⟩) (λ p, star) (λ p, star), 103 | { apply equiv.trans !sigma_unit_left, fapply equiv.MK, 104 | { intro z, induction z with a w, induction w with p q, exact p ⬝ q⁻¹ }, 105 | { intro p, exact ⟨pt, (p, idp)⟩ }, 106 | { intro p, reflexivity }, 107 | { intro z, induction z with a w, induction w with p q, induction q, 108 | reflexivity } }, 109 | { fapply equiv.MK, 110 | { intro z, exact star }, 111 | { intro u, exact ⟨pt, ⟨pt, (idp, idp)⟩ ⟩ }, 112 | { intro u, induction u, reflexivity }, 113 | { intro z, induction z with a w, induction w with b z, 114 | induction z with p q, induction p, esimp at q, induction q, 115 | reflexivity } }, 116 | { fapply equiv.MK, 117 | { intro z, exact star }, 118 | { intro u, exact ⟨pt, ⟨pt, (idp, idp)⟩ ⟩ }, 119 | { intro u, induction u, reflexivity }, 120 | { intro z, induction z with a w, induction w with b z, 121 | induction z with p q, induction q, esimp at p, induction p, 122 | reflexivity } }, 123 | { intro z, induction z with u w, induction u, induction w with a z, 124 | induction z with p q, reflexivity }, 125 | { intro z, induction z with u w, induction u, induction w with a z, 126 | induction z with p q, reflexivity } 127 | end 128 | 129 | parameter {A} 130 | -- instead we directly compare the fibers, using flattening twice 131 | definition fiber_loop_susp_counit_equiv (a : A) 132 | : fiber (loop_susp_counit A) a ≃ fiber prod_of_wedge (a, a) := 133 | begin 134 | apply equiv.trans !fiber.sigma_char, apply equiv.trans !pushout.flattening', 135 | apply equiv.symm, apply equiv.trans !fiber.sigma_char, 136 | apply equiv.trans (sigma_equiv_sigma_right 137 | (λ w, prod_eq_equiv (prod_of_wedge w) (a, a))), esimp, 138 | apply equiv.trans !pushout.flattening', 139 | esimp, 140 | fapply pushout.equiv (λ z, ⟨pt, z.2⟩) (λ z, ⟨pt, glue z.1 ▸ z.2⟩) 141 | (λ z, ⟨star, z.2⟩) (λ z, ⟨star, glue z.1 ▸ z.2⟩), 142 | { fapply equiv.MK, 143 | { intro w, induction w with u z, induction z with p q, 144 | exact ⟨q ⬝ p⁻¹, q⟩ }, 145 | { intro z, induction z with p q, apply dpair star, 146 | exact (p⁻¹ ⬝ q, q) }, 147 | { intro z, induction z with p q, esimp, induction q, esimp, 148 | rewrite [idp_con,inv_inv] }, 149 | { intro w, induction w with u z, induction u, induction z with p q, 150 | esimp, induction q, rewrite [idp_con,inv_inv] } }, 151 | { fapply equiv.MK, 152 | { intro w, induction w with b z, induction z with p q, exact ⟨star, q⟩ }, 153 | { intro z, induction z with u p, induction u, esimp at p, esimp, 154 | apply dpair a, esimp, exact (idp, p) }, 155 | { intro z, induction z with u p, induction u, reflexivity }, 156 | { intro w, induction w with b z, induction z with p q, esimp, 157 | induction p, reflexivity } }, 158 | { fapply equiv.MK, 159 | { intro w, induction w with b z, induction z with p q, exact ⟨star, p⟩ }, 160 | { intro z, induction z with u p, induction u, esimp at p, esimp, 161 | apply dpair a, esimp, exact (p, idp) }, 162 | { intro z, induction z with u p, induction u, reflexivity }, 163 | { intro w, induction w with b z, induction z with p q, esimp, 164 | induction q, reflexivity } }, 165 | { intro w, induction w with u z, induction u, induction z with p q, 166 | reflexivity }, 167 | { intro w, induction w with u z, induction u, induction z with p q, 168 | esimp, induction q, esimp, krewrite prod_transport, fapply sigma_eq, 169 | { exact idp }, 170 | { esimp, rewrite eq_transport_Fl, rewrite eq_transport_Fl, 171 | krewrite elim_glue, krewrite [-ap_compose' pr1 prod_of_wedge (glue star)], 172 | krewrite elim_glue, esimp, apply eq_pathover, rewrite idp_con, esimp, 173 | apply square_of_eq, rewrite [idp_con,idp_con,inv_inv] } } 174 | end 175 | 176 | include HA 177 | 178 | open is_conn trunc_index 179 | 180 | parameter (A) 181 | -- connectivity of loop_susp_counit 182 | definition is_conn_fun_loop_susp_counit {k : ℕ} (H : k ≤ 2 * n) 183 | : is_conn_fun k (loop_susp_counit A) := 184 | begin 185 | intro a, apply is_conn.is_conn_equiv_closed_rev k (fiber_loop_susp_counit_equiv a), 186 | fapply @is_conn.is_conn_of_le (fiber prod_of_wedge (a, a)) k (2 * n) 187 | (of_nat_le_of_nat H), 188 | assert H : of_nat (2 * n) = of_nat n + of_nat n, 189 | { rewrite (of_nat_add_of_nat n n), apply ap of_nat, 190 | apply trans (nat.mul_comm 2 n), 191 | apply ap (λ k, k + n), exact nat.zero_add n }, 192 | rewrite H, 193 | exact is_conn_fun_prod_of_wedge n n A A (a, a) 194 | end 195 | end 196 | 197 | end susp 198 | -------------------------------------------------------------------------------- /homotopy/susp_product.hlean: -------------------------------------------------------------------------------- 1 | import homotopy.susp homotopy.smash 2 | open susp smash pointed wedge prod 3 | 4 | definition susp_product (X Y : Type*) : ⅀ (X × Y) ≃* ⅀ X ∨ (⅀ Y ∨ ⅀ (X ∧ Y)) := 5 | sorry 6 | -------------------------------------------------------------------------------- /homotopy/susp_pset.hlean: -------------------------------------------------------------------------------- 1 | /- 2 | Copyright (c) 2018 Ulrik Buchholtz. All rights reserved. 3 | Released under Apache 2.0 license as described in the file LICENSE. 4 | Authors: Ulrik Buchholtz 5 | -/ 6 | 7 | import algebra.group_theory hit.set_quotient types.list homotopy.vankampen 8 | homotopy.susp .pushout ..algebra.free_group 9 | 10 | open eq pointed equiv is_equiv is_trunc set_quotient sum list susp trunc algebra 11 | group pi pushout is_conn fiber unit function paths 12 | 13 | -- TODO: move to lib 14 | namespace category 15 | open iso 16 | 17 | definition Groupoid_opposite [constructor] (C : Groupoid) : Groupoid := 18 | groupoid.MK (Opposite C) (λ x y f, @is_iso.mk _ (Opposite C) x y f 19 | (@is_iso.inverse _ C y x f ((@groupoid.all_iso _ C y x f))) 20 | (@is_iso.right_inverse _ C y x f ((@groupoid.all_iso _ C y x f))) 21 | (@is_iso.left_inverse _ C y x f ((@groupoid.all_iso _ C y x f)))) 22 | 23 | definition hom_Group (C : Groupoid) (x : C) : Group := 24 | Group.mk (hom x x) (hom_group x) 25 | 26 | definition fundamental_hom_group (A : Type*) : hom_Group (Groupoid_opposite (Π₁ A)) (Point A) ≃g π₁ A := 27 | begin 28 | fapply isomorphism_of_equiv, 29 | { reflexivity }, 30 | { intros p q, reflexivity } 31 | end 32 | 33 | -- [H : is_conn 0 A] : Groupoid_opposite (Π₁ A) ≃c Groupoid_of_Group (π₁ A) 34 | end category open category 35 | 36 | -- special purpose lemmas 37 | definition tr_trunc_eq (A : Type) (a : A) {x y : A} (p : x = y) (q : x = a) 38 | : transport (λ(z : A), trunc 0 (z = a)) p (tr q) = tr (p⁻¹ ⬝ q) := 39 | by induction p; induction q; reflexivity 40 | 41 | namespace susp 42 | section 43 | universe variable u 44 | parameters (A : pType.{u}) [H : is_set A] 45 | include H 46 | 47 | local notation `F` := Π₁⇒ (λ(a : A), star) 48 | 49 | local abbreviation C : Groupoid := Groupoid_bpushout (@id A) F F 50 | local abbreviation N : C := inl star 51 | local abbreviation S : C := inr star 52 | 53 | -- this goes via Groupoid_opposite (Π₁ (⅀ A)) ≃c Groupoid_of_Group (free_group A) 54 | -- definition fundamental_group_of_susp : π₁(⅀ A) ≃g free_group A := 55 | -- sorry 56 | 57 | definition pglueNS (a : A) : hom N S := 58 | class_of [ bpushout_prehom_index.DE (@id A) F F a ] 59 | 60 | definition pglueSN (a : A) : hom S N := 61 | class_of [ bpushout_prehom_index.ED (@id A) F F a ] 62 | 63 | definition f : A × hom N N → hom S N := 64 | prod.rec (λ a p, p ∘ pglueSN a) 65 | 66 | definition g : A × trunc 0 (@susp.north A = @susp.north A) → trunc 0 (@susp.south A = @susp.north A) := 67 | prod.rec (λ a p, tconcat (tr (merid a)⁻¹) p) 68 | 69 | definition foo : (Σ(z : susp A), trunc 0 (z = susp.north)) ≃ pushout prod.pr2 g := 70 | begin 71 | apply equiv.trans !pushout.flattening', 72 | fapply pushout.equiv, 73 | { apply sigma.equiv_prod }, 74 | { apply sigma.sigma_unit_left }, 75 | { apply sigma.sigma_unit_left }, 76 | { intro z, induction z with a p, induction p with p, reflexivity }, 77 | { intro z, induction z with a p, induction p with p, apply tr_trunc_eq } 78 | end 79 | 80 | definition bar : pushout prod.pr2 g ≃ pushout prod.pr2 f := 81 | begin 82 | fapply pushout.equiv, 83 | { apply prod.prod_equiv_prod_right, apply vankampen }, 84 | { apply vankampen }, 85 | { apply vankampen }, 86 | { intro z, induction z with a p, reflexivity }, 87 | { intro z, induction z with a p, 88 | change (encode (@id A) (λ(z : A), star) (λ(z : A), star) (tconcat (tr (merid a)⁻¹) p)) 89 | = (encode (@id A) (λ(z : A), star) (λ(z : A), star) p ∘ pglueSN a), 90 | revert p, fapply @trunc.rec 0 (@susp.north A = @susp.north A), 91 | { intro p, apply is_trunc_succ, apply is_trunc_eq, apply is_set_code }, intro p, 92 | apply trans (encode_tcon (@id A) (λ(z : A), star) (λ(z : A), star) (tr (merid a)⁻¹) (tr p)), 93 | apply ap (λ h, encode (@id A) (λ(z : A), star) (λ(z : A), star) (tr p) ∘ h), 94 | apply encode_decode_singleton } 95 | end 96 | 97 | definition pfiber_susp_equiv_sigma : pfiber (ptr 1 (⅀ A)) ≃ (Σ(z : susp A), trunc 0 (z = susp.north)) := 98 | begin 99 | apply equiv.trans !fiber.sigma_char, 100 | apply sigma.sigma_equiv_sigma_right, 101 | intro z, apply tr_eq_tr_equiv 102 | end 103 | 104 | definition is_trunc_susp_of_is_set : is_contr (Σ(z : susp A), trunc 0 (z = susp.north)) → is_trunc 1 (susp A) := 105 | begin 106 | intro K, 107 | apply is_trunc_of_is_equiv_tr, 108 | apply is_equiv_of_is_contr_fun, 109 | fapply @is_conn.elim -1 (ptrunc 1 (⅀ A)), 110 | exact is_contr_equiv_closed_rev pfiber_susp_equiv_sigma K 111 | end 112 | 113 | end 114 | 115 | end susp 116 | -------------------------------------------------------------------------------- /homotopy/three_by_three.hlean: -------------------------------------------------------------------------------- 1 | -- WIP 2 | 3 | import ..move_to_lib 4 | open function eq 5 | 6 | namespace pushout 7 | section 8 | 9 | -- structure span2 : Type := 10 | -- {A₀₀ A₀₂ A₀₄ A₂₀ A₂₂ A₂₄ A₄₀ A₄₂ A₄₄ : Type} 11 | -- {f₀₁ : A₀₂ → A₀₀} {f₂₁ : A₂₂ → A₂₀} {f₄₁ : A₄₂ → A₄₀} 12 | -- {f₀₃ : A₀₂ → A₀₄} {f₂₃ : A₂₂ → A₂₄} {f₄₃ : A₄₂ → A₄₄} 13 | -- {f₁₀ : A₂₀ → A₀₀} {f₁₂ : A₂₂ → A₀₂} {f₁₄ : A₂₄ → A₀₄} 14 | -- {f₃₀ : A₂₀ → A₄₀} {f₃₂ : A₂₂ → A₄₂} {f₃₄ : A₂₄ → A₄₄} 15 | -- (s₁₁ : f₀₁ ∘ f₁₂ ~ f₁₀ ∘ f₂₁) (s₃₁ : f₄₁ ∘ f₃₂ ~ f₃₀ ∘ f₂₁) 16 | -- (s₁₃ : f₀₃ ∘ f₁₂ ~ f₁₄ ∘ f₂₃) (s₃₃ : f₄₃ ∘ f₃₂ ~ f₃₄ ∘ f₂₃) 17 | 18 | structure three_by_three_span : Type := 19 | {A₀₀ A₂₀ A₄₀ A₀₂ A₂₂ A₄₂ A₀₄ A₂₄ A₄₄ : Type} 20 | {f₁₀ : A₂₀ → A₀₀} {f₃₀ : A₂₀ → A₄₀} 21 | {f₁₂ : A₂₂ → A₀₂} {f₃₂ : A₂₂ → A₄₂} 22 | {f₁₄ : A₂₄ → A₀₄} {f₃₄ : A₂₄ → A₄₄} 23 | {f₀₁ : A₀₂ → A₀₀} {f₀₃ : A₀₂ → A₀₄} 24 | {f₂₁ : A₂₂ → A₂₀} {f₂₃ : A₂₂ → A₂₄} 25 | {f₄₁ : A₄₂ → A₄₀} {f₄₃ : A₄₂ → A₄₄} 26 | (s₁₁ : f₀₁ ∘ f₁₂ ~ f₁₀ ∘ f₂₁) (s₃₁ : f₄₁ ∘ f₃₂ ~ f₃₀ ∘ f₂₁) 27 | (s₁₃ : f₀₃ ∘ f₁₂ ~ f₁₄ ∘ f₂₃) (s₃₃ : f₄₃ ∘ f₃₂ ~ f₃₄ ∘ f₂₃) 28 | 29 | open three_by_three_span 30 | variable (E : three_by_three_span) 31 | -- check (pushout.functor (f₂₁ E) (f₀₁ E) (f₄₁ E) (s₁₁ E) (s₃₁ E)) 32 | definition pushout2hv (E : three_by_three_span) : Type := 33 | pushout (pushout.functor (f₂₁ E) (f₀₁ E) (f₄₁ E) (s₁₁ E) (s₃₁ E)) 34 | (pushout.functor (f₂₃ E) (f₀₃ E) (f₄₃ E) (s₁₃ E) (s₃₃ E)) 35 | 36 | definition pushout2vh (E : three_by_three_span) : Type := 37 | pushout (pushout.functor (f₁₂ E) (f₁₀ E) (f₁₄ E) (s₁₁ E)⁻¹ʰᵗʸ (s₁₃ E)⁻¹ʰᵗʸ) 38 | (pushout.functor (f₃₂ E) (f₃₀ E) (f₃₄ E) (s₃₁ E)⁻¹ʰᵗʸ (s₃₃ E)⁻¹ʰᵗʸ) 39 | 40 | definition three_by_three (E : three_by_three_span) : pushout2hv E ≃ pushout2vh E := sorry 41 | 42 | end 43 | end pushout 44 | -------------------------------------------------------------------------------- /logic.hlean: -------------------------------------------------------------------------------- 1 | /- 2 | Copyright (c) 2017 Jeremy Avigad. All rights reserved. 3 | Released under Apache 2.0 license as described in the file LICENSE. 4 | Authors: Jeremy Avigad 5 | -/ 6 | import types.trunc 7 | open funext eq trunc is_trunc prod sum 8 | 9 | --reserve prefix `¬`:40 10 | --reserve prefix `~`:40 11 | --reserve infixr ` ∧ `:35 12 | --reserve infixr ` /\ `:35 13 | --reserve infixr ` \/ `:30 14 | --reserve infixr ` ∨ `:30 15 | --reserve infix ` <-> `:20 16 | --reserve infix ` ↔ `:20 17 | 18 | namespace logic 19 | 20 | section 21 | open trunc_index 22 | 23 | definition propext {p q : Prop} (h : p ↔ q) : p = q := 24 | tua (equiv_of_iff_of_is_prop h _ _) 25 | 26 | end 27 | 28 | definition false : Prop := trunctype.mk (lift empty) _ 29 | 30 | definition false.elim {A : Type} (h : false) : A := lift.rec empty.elim h 31 | 32 | definition true : Prop := trunctype.mk (lift unit) _ 33 | 34 | definition true.intro : true := lift.up unit.star 35 | 36 | definition trivial : true := lift.up unit.star 37 | 38 | definition and (p q : Prop) : Prop := tprod p q 39 | 40 | infixr ` ∧ ` := and 41 | infixr ` /\ ` := and 42 | 43 | definition and.intro {p q : Prop} (h₁ : p) (h₂ : q) : and p q := prod.mk h₁ h₂ 44 | 45 | definition and.left {p q : Prop} (h : p ∧ q) : p := prod.pr1 h 46 | 47 | definition and.right {p q : Prop} (h : p ∧ q) : q := prod.pr2 h 48 | 49 | definition not (p : Prop) : Prop := trunctype.mk (p → empty) _ 50 | 51 | definition or.inl := @or.intro_left 52 | 53 | definition or.inr := @or.intro_right 54 | 55 | definition or.elim {A B C : Type} [is_prop C] (h₀ : A ∨ B) (h₁ : (A → C)) (h₂ : B → C) : C := 56 | begin 57 | apply trunc.elim_on h₀, 58 | intro h₃, 59 | apply sum.elim h₃ h₁ h₂ 60 | end 61 | 62 | end logic 63 | -------------------------------------------------------------------------------- /pointed_cubes.hlean: -------------------------------------------------------------------------------- 1 | /- 2 | Copyright (c) 2017 Egbert Rijke. All rights reserved. 3 | Released under Apache 2.0 license as described in the file LICENSE. 4 | Authors: Egbert Rijke 5 | 6 | -/ 7 | 8 | /- 9 | The goal of this file is to extend the library of pointed types and pointed maps to support the library of prespectra 10 | 11 | -/ 12 | 13 | import types.pointed2 .pointed_pi 14 | 15 | open eq pointed 16 | 17 | definition psquare_of_phtpy_top {A B C D : Type*} {ftop : A →* B} {fbot : C →* D} {fleft : A →* C} {fright : B →* D} {ftop' : A →* B} (phtpy : ftop ~* ftop') (psq : psquare ftop' fbot fleft fright) : psquare ftop fbot fleft fright := 18 | begin 19 | induction phtpy using phomotopy_rec_idp, exact psq, 20 | end 21 | 22 | definition psquare_of_phtpy_bot {A B C D : Type*} {ftop : A →* B} {fbot : C →* D} {fleft : A →* C} {fright : B →* D} {fbot' : C →* D} (phtpy : fbot ~* fbot') (psq : psquare ftop fbot' fleft fright) : psquare ftop fbot fleft fright := 23 | begin 24 | induction phtpy using phomotopy_rec_idp, exact psq, 25 | end 26 | 27 | definition psquare_of_phtpy_left {A B C D : Type*} {ftop : A →* B} {fbot : C →* D} {fleft : A →* C} {fright : B →* D} {fleft' : A →* C} (phtpy : fleft ~* fleft') (psq : psquare ftop fbot fleft fright) : psquare ftop fbot fleft' fright := 28 | begin 29 | induction phtpy using phomotopy_rec_idp, exact psq, 30 | end 31 | 32 | definition psquare_of_phtpy_right {A B C D : Type*} {ftop : A →* B} {fbot : C →* D} {fleft : A →* C} {fright : B →* D} {fright' : B →* D} (phtpy : fright ~* fright') (psq : psquare ftop fbot fleft fright) : psquare ftop fbot fleft fright' := 33 | begin 34 | induction phtpy using phomotopy_rec_idp, exact psq, 35 | end 36 | 37 | definition psquare_of_pid_top_bot {A B : Type*} {fleft : A →* B} {fright : A →* B} (phtpy : fright ~* fleft) : psquare (pid A) (pid B) fleft fright := 38 | psquare_of_phomotopy ((pcompose_pid fright) ⬝* phtpy ⬝* (pid_pcompose fleft)⁻¹*) 39 | 40 | --print psquare_of_pid_top_bot 41 | 42 | --λ phtpy, psquare_of_phomotopy ((pid_pcompose fleft) ⬝* phtpy ⬝* ((pcompose_pid fright)⁻¹*)) 43 | 44 | definition psquare_of_pid_left_right {A B : Type*} {ftop : A →* B} {fbot : A →* B} (phtpy : ftop ~* fbot) : psquare ftop fbot (pid A) (pid B) := 45 | psquare_of_phomotopy ((pid_pcompose ftop) ⬝* phtpy ⬝* ((pcompose_pid fbot)⁻¹*)) 46 | 47 | --print psquare_of_pid_left_right 48 | 49 | definition psquare_hcompose {A B C D E F : Type*} {ftop : A →* B} {fbot : D →* E} {fleft : A →* D} {fright : B →* E} {gtop : B →* C} {gbot : E →* F} {gright : C →* F} (psq_left : psquare ftop fbot fleft fright) (psq_right : psquare gtop gbot fright gright) : psquare (gtop ∘* ftop) (gbot ∘* fbot) fleft gright := 50 | begin 51 | fapply psquare_of_phomotopy, 52 | refine (passoc gright gtop ftop)⁻¹* ⬝* _ ⬝* (passoc gbot fbot fleft)⁻¹*, 53 | refine (pwhisker_right ftop psq_right) ⬝* (passoc gbot fright ftop) ⬝* _, 54 | exact (pwhisker_left gbot psq_left), 55 | end 56 | 57 | definition psquare_vcompose {A B C D E F : Type*} {ftop : A →* B} {fbot : C →* D} {fleft : A →* C} {fright : B →* D} {gbot : E →* F} {gleft : C →* E} {gright : D →* F} (psq_top : psquare ftop fbot fleft fright) (psq_bot : psquare fbot gbot gleft gright) : psquare ftop gbot (gleft ∘* fleft) (gright ∘* fright) := 58 | begin 59 | fapply psquare_of_phomotopy, 60 | refine (passoc gright fright ftop) ⬝* _ ⬝* (passoc gbot gleft fleft), 61 | refine (pwhisker_left gright psq_top) ⬝* _, 62 | refine (passoc gright fbot fleft)⁻¹* ⬝* _, 63 | exact pwhisker_right fleft psq_bot, 64 | end 65 | 66 | definition psquare_of_pconst_top_bot {A B C D : Type*} (fleft : A →* C) (fright : B →* D) : psquare (pconst A B) (pconst C D) fleft fright := 67 | begin 68 | fapply psquare_of_phomotopy, 69 | refine (pcompose_pconst fright) ⬝* _, 70 | exact (pconst_pcompose fleft)⁻¹*, 71 | end 72 | 73 | definition psquare_of_pconst_left_right {A B C D : Type*} (ftop : A →* B) (fbot : C →* D) : psquare ftop fbot (pconst A C) (pconst B D) := 74 | begin 75 | fapply psquare_of_phomotopy, 76 | refine (pconst_pcompose ftop) ⬝* _, 77 | exact (pcompose_pconst fbot)⁻¹* 78 | end 79 | 80 | definition psquare_of_pconst_top_left {A B C D : Type*} (fbot : C →* D) (fright : B →* D) : psquare (pconst A B) fbot (pconst A C) fright := 81 | begin 82 | fapply psquare_of_phomotopy, 83 | refine (pcompose_pconst fright) ⬝* _, 84 | exact (pcompose_pconst fbot)⁻¹*, 85 | end 86 | 87 | definition psquare_of_pconst_bot_right {A B C D : Type*} (ftop : A →* B) (fleft : A →* C) : psquare ftop (pconst C D) fleft (pconst B D) := 88 | begin 89 | fapply psquare_of_phomotopy, 90 | refine (pconst_pcompose ftop) ⬝* _, 91 | exact (pconst_pcompose fleft)⁻¹*, 92 | end 93 | 94 | definition phsquare_of_phomotopy {A B : Type*} {f g h i : A →* B} {phtpy_top : f ~* g} 95 | {phtpy_bot : h ~* i} {phtpy_left : f ~* h} {phtpy_right : g ~* i} 96 | (H : phtpy_top ⬝* phtpy_right ~* phtpy_left ⬝* phtpy_bot) : 97 | phsquare phtpy_top phtpy_bot phtpy_left phtpy_right := 98 | eq_of_phomotopy H 99 | 100 | definition ptube_v {A B C D : Type*} {ftop ftop' : A →* B} (phtpy_top : ftop ~* ftop') 101 | {fbot fbot' : C →* D} (phtpy_bot : fbot ~* fbot') {fleft : A →* C} {fright : B →* D} 102 | (psq_back : psquare ftop fbot fleft fright) (psq_front : psquare ftop' fbot' fleft fright) : 103 | Type := 104 | phsquare (pwhisker_left fright phtpy_top) (pwhisker_right fleft phtpy_bot) psq_back psq_front 105 | 106 | definition ptube_h {A B C D : Type*} {ftop : A →* B} {fbot : C →* D} {fleft fleft' : A →* C} 107 | (phtpy_left : fleft ~* fleft') {fright fright' : B →* D} (phtpy_right : fright ~* fright') 108 | (psq_back : psquare ftop fbot fleft fright) (psq_front : psquare ftop fbot fleft' fright') : 109 | Type := 110 | phsquare (pwhisker_right ftop phtpy_right) (pwhisker_left fbot phtpy_left) psq_back psq_front 111 | 112 | --print pinv_right_phomotopy_of_phomotopy 113 | 114 | definition psquare_inv_top_bot {A B C D : Type*} {ftop : A ≃* B} {fbot : C ≃* D} {fleft : A →* C} {fright : B →* D} (psq : psquare ftop fbot fleft fright) : psquare ftop⁻¹ᵉ* fbot⁻¹ᵉ* fright fleft := 115 | begin 116 | fapply psquare_of_phomotopy, 117 | refine (pinv_right_phomotopy_of_phomotopy _), 118 | refine _ ⬝* (passoc fbot⁻¹ᵉ* fright ftop)⁻¹*, 119 | refine (pinv_left_phomotopy_of_phomotopy _)⁻¹*, 120 | exact psq, 121 | end 122 | 123 | definition p2homotopy_ty_respect_pt {A B : Type*} {f g : A →* B} {H K : f ~* g} (htpy : H ~ K) : Type := 124 | begin 125 | induction H with H p, exact p 126 | end = whisker_right (respect_pt g) (htpy pt) ⬝ 127 | begin 128 | induction K with K q, exact q 129 | end 130 | 131 | --print p2homotopy_ty_respect_pt 132 | 133 | structure p2homotopy {A B : Type*} {f g : A →* B} (H K : f ~* g) : Type := 134 | ( to_2htpy : H ~ K) 135 | ( respect_pt : p2homotopy_ty_respect_pt to_2htpy) 136 | 137 | definition ptube_v_phtpy_bot {A B C D : Type*} 138 | {ftop ftop' : A →* B} {phtpy_top : ftop ~* ftop'} 139 | {fbot fbot' : C →* D} {phtpy_bot phtpy_bot' : fbot ~* fbot'} (ppi_htpy_bot : phtpy_bot ~* phtpy_bot') 140 | {fleft : A →* C} {fright : B →* D} 141 | {psq_back : psquare ftop fbot fleft fright} 142 | {psq_front : psquare ftop' fbot' fleft fright} 143 | (ptb : ptube_v phtpy_top phtpy_bot psq_back psq_front) 144 | : ptube_v phtpy_top phtpy_bot' psq_back psq_front 145 | := 146 | begin 147 | induction ppi_htpy_bot using phomotopy_rec_idp, 148 | exact ptb, 149 | end 150 | 151 | definition ptube_v_eq_bot {A B C D : Type*} {ftop ftop' : A →* B} (htpy_top : ftop ~* ftop') {fbot fbot' : C →* D} {htpy_bot htpy_bot' : fbot ~* fbot'} (p : htpy_bot = htpy_bot') {fleft : A →* C} {fright : B →* D} (psq_back : psquare ftop fbot fleft fright) (psq_front : psquare ftop' fbot' fleft fright) : 152 | ptube_v htpy_top htpy_bot psq_back psq_front → ptube_v htpy_top htpy_bot' psq_back psq_front := 153 | begin 154 | induction p, 155 | exact id, 156 | end 157 | 158 | definition ptube_v_left_inv {A B C D : Type*} {ftop : A ≃* B} {fbot : C ≃* D} {fleft : A →* C} {fright : B →* D} 159 | (psq : psquare ftop fbot fleft fright) : 160 | ptube_v 161 | (pleft_inv ftop) 162 | (pleft_inv fbot) 163 | (psquare_hcompose psq (psquare_inv_top_bot psq)) 164 | (psquare_of_pid_top_bot phomotopy.rfl) := 165 | begin 166 | refine ptube_v_phtpy_bot _ _, 167 | exact pleft_inv fbot, 168 | exact phomotopy.rfl, 169 | fapply phsquare_of_phomotopy, repeat exact sorry, 170 | end 171 | -------------------------------------------------------------------------------- /pyoneda.hlean: -------------------------------------------------------------------------------- 1 | /- 2 | In this file we give a consequence of the Yoneda lemma for pointed types which we can state 3 | internally. If we have a pointed equivalence α : A ≃* B, we can turn it into an equivalence 4 | γ : (B →* X) ≃* (A →* X), natural in X. Naturality means that if we have f : X → X' then we 5 | can fill the following square (using a pointed homotopy) 6 | (B →* X) --> (A →* X) 7 | | | 8 | v v 9 | (B →* X') --> (B →* X') 10 | such that if f is the constant map, then this square is equal to the canonical filler of that 11 | square (where the fact that f is constant is used). 12 | 13 | Conversely, if we have such a γ natural in X, we can obtain an equivalence A ≃* B. 14 | Moreover, these operations are equivalences in the sense that going from α to γ to α is the 15 | same as doing nothing, and going from γ to α to γ is the same as doing nothing. However, we 16 | need higher coherences for γ to show that the proof of naturality is the same, which we didn't do. 17 | 18 | Author: Floris van Doorn (informal proofs in collaboration with Stefano Piceghello) 19 | -/ 20 | 21 | import .pointed 22 | 23 | open equiv is_equiv eq 24 | namespace pointed 25 | 26 | universe variable u 27 | 28 | definition ppcompose_right_ppcompose_left {A A' B B' : Type*} (f : A →* A') (g : B →* B'): 29 | psquare (ppcompose_right f) (ppcompose_right f) (ppcompose_left g) (ppcompose_left g) := 30 | ptranspose !ppcompose_left_ppcompose_right 31 | 32 | -- definition pyoneda₂ {A B : pType.{u}} (γ : Π(X : pType.{u}), ppmap B X ≃* ppmap A X) 33 | -- (p : Π(X X' : Type*), _ ∘* pppcompose B X X' ~* (_ : ppmap _ _)) 34 | -- : A ≃* B := 35 | -- begin 36 | -- fapply pequiv.MK, 37 | -- { exact γ B (pid B) }, 38 | -- { exact (γ A)⁻¹ᵉ* (pid A) }, 39 | -- { refine phomotopy_of_eq (p _ _) ⬝* _, 40 | -- exact pap (γ A) !pcompose_pid ⬝* phomotopy_of_eq (to_right_inv (γ A) _) }, 41 | -- { refine phomotopy_of_eq ((p _)⁻¹ʰ* _) ⬝* _, 42 | -- exact pap (γ B)⁻¹ᵉ* !pcompose_pid ⬝* phomotopy_of_eq (to_left_inv (γ B) _) } 43 | -- end 44 | 45 | -- print ⁻¹ʰᵗʸʰ 46 | -- print eq.hhinverse 47 | definition pyoneda_weak {A B : pType.{u}} (γ : Π(X : pType.{u}), ppmap B X ≃* ppmap A X) 48 | (p : Π⦃X X' : Type*⦄ (f : X →* X') (g : B →* X), f ∘* γ X g ~* γ X' (f ∘* g)) : A ≃* B := 49 | begin 50 | fapply pequiv.MK, 51 | { exact γ B (pid B) }, 52 | { exact (γ A)⁻¹ᵉ* (pid A) }, 53 | { refine p _ _ ⬝* _, 54 | exact pap (γ A) !pcompose_pid ⬝* phomotopy_of_eq (to_right_inv (γ A) _) }, 55 | { -- refine (p _)⁻¹ʰᵗʸʰ _ ⬝* _, 56 | -- exact pap (γ B)⁻¹ᵉ* !pcompose_pid ⬝* phomotopy_of_eq (to_left_inv (γ B) _) 57 | exact sorry 58 | } 59 | end 60 | 61 | definition pyoneda {A B : pType.{u}} (γ : Π(X : pType.{u}), ppmap B X ≃* ppmap A X) 62 | (p : Π⦃X X' : Type*⦄ (f : X →* X'), psquare (γ X) (γ X') (ppcompose_left f) (ppcompose_left f)) 63 | : A ≃* B := 64 | -- pyoneda_weak γ p 65 | begin 66 | fapply pequiv.MK, 67 | { exact γ B (pid B) }, 68 | { exact (γ A)⁻¹ᵉ* (pid A) }, 69 | { refine phomotopy_of_eq (p _ _) ⬝* _, 70 | exact pap (γ A) !pcompose_pid ⬝* phomotopy_of_eq (to_right_inv (γ A) _) }, 71 | { refine phomotopy_of_eq ((p _)⁻¹ʰ* _) ⬝* _, 72 | exact pap (γ B)⁻¹ᵉ* !pcompose_pid ⬝* phomotopy_of_eq (to_left_inv (γ B) _) } 73 | end 74 | 75 | definition pyoneda_right_inv {A B : pType.{u}} (α : A ≃* B) : 76 | pyoneda (λX, ppmap_pequiv_ppmap_left α) (λX X' f, proof !ppcompose_right_ppcompose_left qed) ~* 77 | α := 78 | phomotopy.mk homotopy.rfl idp 79 | 80 | definition pyoneda_left_inv {A B : pType.{u}} (γ : Π(X : pType.{u}), ppmap B X ≃* ppmap A X) 81 | (p : Π⦃X X' : Type*⦄ (f : X →* X'), psquare (γ X) (γ X') (ppcompose_left f) (ppcompose_left f)) 82 | (H : Π⦃X⦄ (X' : Type*) (g : B →* X), phomotopy_of_eq (p (pconst X X') g) = 83 | !pconst_pcompose ⬝* (pap (γ X') !pconst_pcompose ⬝* phomotopy_of_eq (respect_pt (γ X')))⁻¹*) 84 | (X : Type*) : ppcompose_right (pyoneda γ p) ~* γ X := 85 | begin 86 | fapply phomotopy_mk_ppmap, 87 | { intro f, refine phomotopy_of_eq (p _ _) ⬝* _, exact pap (γ X) !pcompose_pid }, 88 | { refine _ ⬝ !phomotopy_of_eq_of_phomotopy⁻¹, 89 | refine !trans_assoc ⬝ _, 90 | refine H X (pid B) ◾** idp ⬝ !trans_assoc ⬝ idp ◾** _ ⬝ !trans_refl, 91 | apply trans_left_inv } 92 | end 93 | 94 | definition pyoneda_weak_left_inv {A B : pType.{u}} (γ : Π(X : pType.{u}), ppmap B X ≃* ppmap A X) 95 | (p : Π⦃X : Type*⦄ (X' : Type*) (g : B →* X), ppcompose_right (γ X g) ~* γ X' ∘* ppcompose_right g) 96 | (X : Type*) : ppcompose_right (pyoneda_weak γ (λX X' f g, phomotopy_of_eq (p X' g f))) ~* γ X := 97 | begin 98 | fapply phomotopy_mk_ppmap, 99 | { intro f, refine phomotopy_of_eq (p _ _ _) ⬝* _, exact pap (γ X) !pcompose_pid }, 100 | { refine _ ⬝ !phomotopy_of_eq_of_phomotopy⁻¹, 101 | refine !trans_assoc ⬝ _, 102 | refine (ap phomotopy_of_eq (eq_con_inv_of_con_eq (to_homotopy_pt (p X (pid B)))) ⬝ 103 | !phomotopy_of_eq_con ⬝ !phomotopy_of_eq_of_phomotopy ◾** 104 | (!phomotopy_of_eq_inv ⬝ (!phomotopy_of_eq_con ⬝ (!phomotopy_of_eq_ap ⬝ 105 | ap (pap' _) !phomotopy_of_eq_of_phomotopy) ◾** idp)⁻²**)) ◾** idp ⬝ _, 106 | refine !trans_assoc ⬝ idp ◾** _ ⬝ !trans_refl, 107 | apply trans_left_inv } 108 | end 109 | 110 | 111 | end pointed 112 | -------------------------------------------------------------------------------- /spectrum/smash.hlean: -------------------------------------------------------------------------------- 1 | import .spectrification ..homotopy.smash_adjoint 2 | 3 | open pointed is_equiv equiv eq susp succ_str smash int 4 | namespace spectrum 5 | 6 | /- Smash product of a prespectrum and a type -/ 7 | 8 | definition smash_prespectrum (X : Type*) (Y : prespectrum) : prespectrum := 9 | prespectrum.mk (λ z, X ∧ Y z) begin 10 | intro n, refine loop_susp_pintro (X ∧ Y n) (X ∧ Y (n + 1)) _, 11 | refine _ ∘* (smash_susp X (Y n))⁻¹ᵉ*, 12 | refine smash_functor !pid _, 13 | refine susp_pelim (Y n) (Y (n + 1)) _, 14 | exact !glue 15 | end 16 | 17 | definition smash_prespectrum_fun {X X' : Type*} {Y Y' : prespectrum} (f : X →* X') (g : Y →ₛ Y') : 18 | smash_prespectrum X Y →ₛ smash_prespectrum X' Y' := 19 | smap.mk (λn, smash_functor f (g n)) begin 20 | intro n, 21 | refine susp_to_loop_psquare _ _ _ _ _, 22 | refine pvconcat (ptranspose (phinverse (smash_susp_natural f (g n)))) _, 23 | refine vconcat_phomotopy _ (smash_functor_split f (g (S n))), 24 | refine phomotopy_vconcat (smash_functor_split f (susp_functor (g n))) _, 25 | refine phconcat _ _, 26 | let glue_adjoint := susp_pelim (Y' n) (Y' (S n)) (glue Y' n), 27 | exact pid X ∧→ glue_adjoint, 28 | refine smash_functor_psquare (phrefl (pid X)) _, 29 | refine loop_to_susp_square _ _ _ _ _, 30 | exact smap.glue_square g n, 31 | exact smash_functor_psquare (pvrefl f) (phrefl glue_adjoint) 32 | end 33 | 34 | /- smash of a spectrum and a type -/ 35 | definition smash_spectrum (X : Type*) (Y : spectrum) : spectrum := 36 | spectrify (smash_prespectrum X Y) 37 | 38 | definition smash_spectrum_fun {X X' : Type*} {Y Y' : spectrum} (f : X →* X') (g : Y →ₛ Y') : smash_spectrum X Y →ₛ smash_spectrum X' Y' := 39 | spectrify_fun (smash_prespectrum_fun f g) 40 | 41 | 42 | end spectrum 43 | --------------------------------------------------------------------------------