fix compile error

closes #11

.gitignore

@@ -24,3 +24,4 @@ doc/html
 make.deps
 src/emacs/dependencies
 compile_commands.json
+.cache

README.md

@@ -18,13 +18,9 @@ Requirements
 - [GMP (GNU multiprecision library)](http://gmplib.org/)
 - [MPFR (GNU MPFR Library)](http://www.mpfr.org/)
 - [Lua 5.2 or 5.1](http://www.lua.org), or [LuaJIT 2.0](http://luajit.org)
-- (optional) [gperftools](https://code.google.com/p/gperftools/)
-- (optional) [Boost](http://www.boost.org) (version >= 1.54), we can
-  build Lean using boost::thread instead of std::thread. When using
-  Boost, Lean can modify the thread stack size.
 
-Installing required packages at
---------------------------------
+Installing
+----------
 
 _Windows_
 
@@ -32,8 +28,8 @@ _Windows_
 
 _Linux_
 
-- [Ubuntu 12.04 or newer](doc/make/ubuntu-12.04.md)
 - [Ubuntu 12.04 or newer (detailed)](doc/make/ubuntu-12.04-detailed.md)
+- [Ubuntu 12.04 or newer (brief)](doc/make/ubuntu-12.04.md)
 - [Fedora 19](doc/make/fedora-19.md)
 
 _OS X_

doc/make/ubuntu-12.04-detailed.md

@@ -3,12 +3,9 @@ Preparing working environment on Ubuntu 12.04
 
 ### Install basic packages
 
-    sudo apt-get install git
-    sudo apt-get install libgmp-dev
-    sudo apt-get install libmpfr-dev
+    sudo apt-get install git libgmp-dev libmpfr-dev emacs -y
     sudo add-apt-repository ppa:kalakris/cmake -y
-    sudo apt-get install cmake
-    sudo apt-get install liblua5.2.0 lua5.2-0 lua5.2-dev
+    sudo apt-get install cmake liblua5.2.0 lua5.2-0 lua5.2-dev -y
 
     sudo add-apt-repository ppa:ubuntu-toolchain-r/test -y
     sudo update-alternatives --remove-all gcc
@@ -19,14 +16,10 @@ Preparing working environment on Ubuntu 12.04
 
 ### Optional packages
 
-    sudo apt-get install gitg
-    sudo apt-get install valgrind
-    sudo apt-get install doxygen
-    sudo apt-get install kcachegrind
+    sudo apt-get install gitg ninja-build valgrind doxygen kcachegrind
 
     sudo add-apt-repository --yes ppa:boost-latest/ppa
-    sudo apt-get install libboost1.54-dev
-    sudo apt-get install libboost-thread1.54-dev
+    sudo apt-get install libboost1.54-dev libboost-thread1.54-dev
 
 ### Fork Lean on github : https://github.com/leanprover/lean2
 
@@ -48,44 +41,20 @@ Preparing working environment on Ubuntu 12.04
     cmake -D CMAKE_BUILD_TYPE=Release ../src
     make
 
-### Alternatively, build Lean using Boost
+### Alternative ways to build
+Using Ninja (to speed up build)
+
+    cmake -DCMAKE_BUILD_TYPE=RELEASE -G Ninja ../src
+    ninja
+
+Using Boost (to speed up build)
 
-    cd lean2
-    mkdir -p build
-    cd build
     cmake -D CMAKE_BUILD_TYPE=Release -D BOOST=ON ../src
     make
 
-### If you are using Emacs, here are some basic configurations
+Build in debug mode
 
-    (custom-set-variables
-      '(c-basic-offset 4)
-      '(global-font-lock-mode t nil (font-lock))
-      '(show-paren-mode t nil (paren))
-      '(transient-mark-mode t))
+    cmake -DCMAKE_BUILD_TYPE=DEBUG ../src
+    make
  
-
-    (tool-bar-mode -1)
-    (setq visible-bell t)
-    (setq-default indent-tabs-mode nil)
-    (setq visible-bell t)
-    (column-number-mode 1)
-
-    ;; Coding Style
-    (setq auto-mode-alist (cons '("\\.h$" . c++-mode) auto-mode-alist))
-    (defconst my-cc-style
-      '("cc-mode"
-       (c-offsets-alist . ((innamespace . [0])))))
-    (c-add-style "my-cc-mode" my-cc-style)
-    (add-hook 'c++-mode-hook '(lambda ()
-                                 (c-set-style "my-cc-mode")
-                                 (gtags-mode 1)
-                                ))
-
-    ;; C++ 11 new keywords
-    (font-lock-add-keywords 'c++-mode
-       '(("\\<\\(thread_local\\)\\>" . font-lock-warning-face)
-        ("\\<\\(constexpr\\)\\>" . font-lock-keyword-face)
-        ))
-
-You need to also set up the [Emacs Mode](../../src/emacs/README.md).
+### You need to also set up the [Emacs Mode](../../src/emacs/README.md).

hott/algebra/algebra.md

@@ -15,13 +15,17 @@ The following files are [ported](../port.md) from the standard library. If anyth
 * [field](field.hlean)
 * [ordered_field](ordered_field.hlean)
 * [bundled](bundled.hlean) : bundled versions of the algebraic structures
+* [homomorphism](homomorphism.hlean)
+* [group_power](group_power.hlean) (depends on files in [nat](../types/nat/nat.md) and [int](../types/int/int.md))
 
 Files which are not ported from the standard library:
 
+* [inf_group](inf_group.hlean) : algebraic structures which are not assumes to be sets. No higher coherences are assumed. Truncated algebraic structures extend these structures with the assumption that they are sets.
+* [inf_group_theory](inf_group_theory.hlean) : Some very basic group theory using InfGroups
 * [group_theory](group_theory.hlean) : Basic theorems about group homomorphisms and isomorphisms
 * [trunc_group](trunc_group.hlean) : truncate an infinity-group to a group
 * [homotopy_group](homotopy_group.hlean) : homotopy groups of a pointed type
-* [e_closure](e_closure.hlean) : the type of words formed by a relation
+* [e_closure](e_closure.hlean) : the type of words formed by a relation, or paths in a graph.
 * [graph](graph.hlean) : definition and operations on paths in a graph.
 
 Subfolders (not ported):

hott/algebra/bundled.hlean

@@ -5,7 +5,7 @@ Authors: Jeremy Avigad
 
 Bundled structures
 -/
-import algebra.group homotopy.interval
+import algebra.ring
 open algebra pointed is_trunc
 
 namespace algebra
@@ -34,64 +34,82 @@ attribute CommMonoid.carrier [coercion]
 attribute CommMonoid.struct [instance]
 
 structure Group :=
-(carrier : Type) (struct : group carrier)
+(carrier : Type) (struct' : group carrier)
 
-attribute Group.carrier [coercion]
-attribute Group.struct [instance]
+attribute Group.struct' [instance]
 
 section
-  local attribute Group.struct [instance]
+local attribute Group.carrier [coercion]
 definition pSet_of_Group [constructor] [reducible] [coercion] (G : Group) : Set* :=
-  ptrunctype.mk G !semigroup.is_set_carrier 1
+ptrunctype.mk (Group.carrier G) !semigroup.is_set_carrier 1
 end
 
+definition Group.struct [instance] [priority 2000] (G : Group) : group G :=
+Group.struct' G
+
 attribute algebra._trans_of_pSet_of_Group [unfold 1]
 attribute algebra._trans_of_pSet_of_Group_1 algebra._trans_of_pSet_of_Group_2 [constructor]
 
-definition pType_of_Group [reducible] [constructor] : Group → Type* :=
-algebra._trans_of_pSet_of_Group_1
-definition Set_of_Group [reducible] [constructor] : Group → Set :=
-algebra._trans_of_pSet_of_Group_2
+definition pType_of_Group [reducible] [constructor] (G : Group) : Type* :=
+G
+definition Set_of_Group [reducible] [constructor] (G : Group) : Set :=
+G
 
 definition AddGroup : Type := Group
 
+definition pSet_of_AddGroup [constructor] [reducible] [coercion] (G : AddGroup) : Set* :=
+pSet_of_Group G
+
 definition AddGroup.mk [constructor] [reducible] (G : Type) (H : add_group G) : AddGroup :=
 Group.mk G H
 
-definition AddGroup.struct [reducible] (G : AddGroup) : add_group G :=
+definition AddGroup.struct [reducible] [instance] [priority 2000] (G : AddGroup) : add_group G :=
 Group.struct G
 
-attribute AddGroup.struct Group.struct [instance] [priority 2000]
+attribute algebra._trans_of_pSet_of_AddGroup [unfold 1]
+attribute algebra._trans_of_pSet_of_AddGroup_1 algebra._trans_of_pSet_of_AddGroup_2 [constructor]
+
+definition pType_of_AddGroup [reducible] [constructor] : AddGroup → Type* :=
+algebra._trans_of_pSet_of_AddGroup_1
+definition Set_of_AddGroup [reducible] [constructor] : AddGroup → Set :=
+algebra._trans_of_pSet_of_AddGroup_2
 
 structure AbGroup :=
-(carrier : Type) (struct : ab_group carrier)
+(carrier : Type) (struct' : ab_group carrier)
 
-attribute AbGroup.carrier [coercion]
-
-definition AddAbGroup : Type := AbGroup
-
-definition AddAbGroup.mk [constructor] [reducible] (G : Type) (H : add_ab_group G) :
-  AddAbGroup :=
-AbGroup.mk G H
-
-definition AddAbGroup.struct [reducible] (G : AddAbGroup) : add_ab_group G :=
-AbGroup.struct G
-
-attribute AddAbGroup.struct AbGroup.struct [instance] [priority 2000]
+attribute AbGroup.struct' [instance]
 
+section
+local attribute AbGroup.carrier [coercion]
 definition Group_of_AbGroup [coercion] [constructor] (G : AbGroup) : Group :=
 Group.mk G _
+end
+
+definition AbGroup.struct [instance] [priority 2000] (G : AbGroup) : ab_group G :=
+AbGroup.struct' G
 
 attribute algebra._trans_of_Group_of_AbGroup_1
           algebra._trans_of_Group_of_AbGroup
           algebra._trans_of_Group_of_AbGroup_3 [constructor]
 attribute algebra._trans_of_Group_of_AbGroup_2 [unfold 1]
 
-definition ab_group_AbGroup [instance] (G : AbGroup) : ab_group G :=
+definition AddAbGroup : Type := AbGroup
+
+definition AddGroup_of_AddAbGroup [coercion] [constructor] (G : AddAbGroup) : AddGroup :=
+Group_of_AbGroup G
+
+definition AddAbGroup.struct [reducible] [instance] [priority 2000] (G : AddAbGroup) :
+  add_ab_group G :=
 AbGroup.struct G
 
-definition add_ab_group_AddAbGroup [instance] (G : AddAbGroup) : add_ab_group G :=
-AbGroup.struct G
+definition AddAbGroup.mk [constructor] [reducible] (G : Type) (H : add_ab_group G) :
+  AddAbGroup :=
+AbGroup.mk G H
+
+attribute algebra._trans_of_AddGroup_of_AddAbGroup_1
+          algebra._trans_of_AddGroup_of_AddAbGroup
+          algebra._trans_of_AddGroup_of_AddAbGroup_3 [constructor]
+attribute algebra._trans_of_AddGroup_of_AddAbGroup_2 [unfold 1]
 
 -- structure AddSemigroup :=
 -- (carrier : Type) (struct : add_semigroup carrier)
@@ -132,21 +150,26 @@ AbGroup.struct G
 
 -- some bundled infinity-structures
 structure InfGroup :=
-(carrier : Type) (struct : inf_group carrier)
+(carrier : Type) (struct' : inf_group carrier)
 
-attribute InfGroup.carrier [coercion]
-attribute InfGroup.struct [instance]
+attribute InfGroup.struct' [instance]
 
 section
-  local attribute InfGroup.struct [instance]
+  local attribute InfGroup.carrier [coercion]
   definition pType_of_InfGroup [constructor] [reducible] [coercion] (G : InfGroup) : Type* :=
   pType.mk G 1
 end
 
 attribute algebra._trans_of_pType_of_InfGroup [unfold 1]
 
+definition InfGroup.struct [instance] [priority 2000] (G : InfGroup) : inf_group G :=
+InfGroup.struct' G
+
 definition AddInfGroup : Type := InfGroup
 
+definition pType_of_AddInfGroup [constructor] [reducible] [coercion] (G : AddInfGroup) : Type* :=
+pType_of_InfGroup G
+
 definition AddInfGroup.mk [constructor] [reducible] (G : Type) (H : add_inf_group G) :
   AddInfGroup :=
 InfGroup.mk G H
@@ -154,29 +177,40 @@ InfGroup.mk G H
 definition AddInfGroup.struct [reducible] (G : AddInfGroup) : add_inf_group G :=
 InfGroup.struct G
 
-attribute AddInfGroup.struct InfGroup.struct [instance] [priority 2000]
+attribute algebra._trans_of_pType_of_AddInfGroup [unfold 1]
 
 structure AbInfGroup :=
-(carrier : Type) (struct : ab_inf_group carrier)
+(carrier : Type) (struct' : ab_inf_group carrier)
 
-attribute AbInfGroup.carrier [coercion]
+attribute AbInfGroup.struct' [instance]
+
+section
+local attribute AbInfGroup.carrier [coercion]
+definition InfGroup_of_AbInfGroup [coercion] [constructor] (G : AbInfGroup) : InfGroup :=
+InfGroup.mk G _
+end
+
+definition AbInfGroup.struct [instance] [priority 2000] (G : AbInfGroup) : ab_inf_group G :=
+AbInfGroup.struct' G
+
+attribute algebra._trans_of_InfGroup_of_AbInfGroup_1 [constructor]
+attribute algebra._trans_of_InfGroup_of_AbInfGroup [unfold 1]
 
 definition AddAbInfGroup : Type := AbInfGroup
 
+definition AddInfGroup_of_AddAbInfGroup [coercion] [constructor] (G : AddAbInfGroup) : AddInfGroup :=
+InfGroup_of_AbInfGroup G
+
+definition AddAbInfGroup.struct [reducible] [instance] [priority 2000] (G : AddAbInfGroup) :
+  add_ab_inf_group G :=
+AbInfGroup.struct G
+
 definition AddAbInfGroup.mk [constructor] [reducible] (G : Type) (H : add_ab_inf_group G) :
   AddAbInfGroup :=
 AbInfGroup.mk G H
 
-definition AddAbInfGroup.struct [reducible] (G : AddAbInfGroup) : add_ab_inf_group G :=
-AbInfGroup.struct G
-
-attribute AddAbInfGroup.struct AbInfGroup.struct [instance] [priority 2000]
-
-definition InfGroup_of_AbInfGroup [coercion] [constructor] (G : AbInfGroup) : InfGroup :=
-InfGroup.mk G _
-
-attribute algebra._trans_of_InfGroup_of_AbInfGroup_1 [constructor]
-attribute algebra._trans_of_InfGroup_of_AbInfGroup [unfold 1]
+attribute algebra._trans_of_AddInfGroup_of_AddAbInfGroup_1 [constructor]
+attribute algebra._trans_of_AddInfGroup_of_AddAbInfGroup [unfold 1]
 
 definition InfGroup_of_Group [constructor] (G : Group) : InfGroup :=
 InfGroup.mk G _
@@ -190,4 +224,17 @@ AbInfGroup.mk G _
 definition AddAbInfGroup_of_AddAbGroup [constructor] (G : AddAbGroup) : AddAbInfGroup :=
 AddAbInfGroup.mk G _
 
+/- rings -/
+structure Ring :=
+(carrier : Type) (struct : ring carrier)
+
+attribute Ring.carrier [coercion]
+attribute Ring.struct [instance]
+
 end algebra
+open algebra
+
+namespace infgroup
+attribute [coercion] InfGroup_of_Group
+attribute [coercion] AbInfGroup_of_AbGroup
+end infgroup

hott/algebra/category/category.hlean

@@ -78,9 +78,7 @@ namespace category
   definition is_trunc_1_ob : is_trunc 1 ob :=
   begin
     apply is_trunc_succ_intro, intro a b,
-    fapply is_trunc_is_equiv_closed,
-          exact (@eq_of_iso _ _ a b),
-        apply is_equiv_inv,
+    exact is_trunc_equiv_closed_rev _ (eq_equiv_iso a b) _
   end
   end basic
 
@@ -120,7 +118,7 @@ namespace category
     (q : Πa b c g f, cast p (@comp ob C a b c g f) = @comp ob D a b c (cast p g) (cast p f))
       : C = D :=
   begin
-    apply eq_of_fn_eq_fn !category.sigma_char,
+    apply inj !category.sigma_char,
     fapply sigma_eq,
     { induction C, induction D, esimp, exact precategory_eq @p q},
     { unfold is_univalent, apply is_prop.elimo},

hott/algebra/category/constructions/comma.hlean

@@ -1,7 +1,6 @@
 /-
 Copyright (c) 2015 Floris van Doorn. All rights reserved.
 Released under Apache 2.0 license as described in the file LICENSE.
-
 Authors: Floris van Doorn
 
 Comma category
@@ -34,7 +33,7 @@ namespace category
 
   theorem is_trunc_comma_object (n : trunc_index) [HA : is_trunc n A]
     [HB : is_trunc n B] [H : Π(s d : C), is_trunc n (hom s d)] : is_trunc n (comma_object S T) :=
-  by apply is_trunc_equiv_closed;apply comma_object_sigma_char
+  is_trunc_equiv_closed n !comma_object_sigma_char _
 
   variables {S T}
   definition comma_object_eq' {x y : comma_object S T} (p : ob1 x = ob1 y) (q : ob2 x = ob2 y)
@@ -105,7 +104,7 @@ namespace category
   theorem is_trunc_comma_morphism (n : trunc_index) [H1 : is_trunc n (ob1 x ⟶ ob1 y)]
     [H2 : is_trunc n (ob2 x ⟶ ob2 y)] [Hp : Πm1 m2, is_trunc n (T m2 ∘ mor x = mor y ∘ S m1)]
     : is_trunc n (comma_morphism x y) :=
-  by apply is_trunc_equiv_closed; apply comma_morphism_sigma_char
+  is_trunc_equiv_closed n !comma_morphism_sigma_char _
 
   variables {x y z w}
   definition comma_morphism_eq {f f' : comma_morphism x y}

hott/algebra/category/constructions/constructions.md

@@ -14,6 +14,7 @@ Common categories and constructions on categories. The following files are in th
   Pushout of categories, pushout of groupoids.
 * [fundamental_groupoid](fundamental_groupoid.hlean) : The fundamental groupoid of a type
 * [rezk](rezk.hlean) : Rezk completion
+* [pullback](pullback.hlean) : Pulling back the structure of a precategory along a map between types. This is not about pullbacks in a 1-category.
 
 Discrete, indiscrete or finite categories:
 

hott/algebra/category/constructions/default.hlean

@@ -5,4 +5,4 @@ Authors: Floris van Doorn
 -/
 
 import .functor .set .opposite .product .comma .sum .discrete .indiscrete .terminal .initial .order
-       .pushout .fundamental_groupoid
+       .pushout .fundamental_groupoid .pullback

hott/algebra/category/constructions/functor.hlean

@@ -739,7 +739,7 @@ namespace functor
       apply concat, apply assoc,
       apply concat, apply ap (λ x, x ∘ _), apply X_phi_hom_of_eq, esimp[XF],
       refine !respect_comp⁻¹ ⬝ ap (to_fun_hom F) _ ⬝ !respect_comp,
-      apply eq_of_fn_eq_fn' (to_fun_hom H),
+      apply inj' (to_fun_hom H),
       refine !respect_comp ⬝ _ ⬝ !respect_comp⁻¹,
       apply concat, apply ap (λ x, x ∘ _) !(right_inv (to_fun_hom H)),
       apply concat, rotate 1, apply ap (λ x, _ ∘ x) !(right_inv (to_fun_hom H))⁻¹,

hott/algebra/category/constructions/pullback.hlean

@@ -0,0 +1,62 @@
+/-
+Copyright (c) 2018 Floris van Doorn. All rights reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+Authors: Floris van Doorn
+
+We pull back the structure of a category B along a map between the types A and (ob B).
+We shorten the word "pullback" to "pb" to keep names relatively short.
+-/
+
+
+import ..functor.equivalence
+
+open category eq is_trunc is_equiv sigma function equiv prod
+
+namespace category
+  open functor
+
+  definition pb_precategory [constructor] {A B : Type} (f : A → B) (C : precategory B) :
+    precategory A :=
+  precategory.mk (λa a', hom (f a) (f a')) (λa a' a'' h g, h ∘ g) (λa, ID (f a))
+    (λa a' a'' a''' k h g, assoc k h g) (λa a' g, id_left g) (λa a' g, id_right g)
+
+  definition pb_Precategory [constructor] {A : Type} (C : Precategory) (f : A → C) :
+    Precategory :=
+  Precategory.mk A (pb_precategory f C)
+
+  definition pb_Precategory_functor [constructor] {A : Type} (C : Precategory) (f : A → C) :
+    pb_Precategory C f ⇒ C :=
+  functor.mk f (λa a' g, g) proof (λa, idp) qed proof (λa a' a'' h g, idp) qed
+
+  definition fully_faithful_pb_Precategory_functor {A : Type} (C : Precategory)
+    (f : A → C) : fully_faithful (pb_Precategory_functor C f) :=
+  begin intro a a', apply is_equiv_id end
+
+  definition split_essentially_surjective_pb_Precategory_functor {A : Type} (C : Precategory)
+    (f : A → C) (H : is_split_surjective f) :
+    split_essentially_surjective (pb_Precategory_functor C f) :=
+  begin intro c, cases H c with a p, exact ⟨a, iso.iso_of_eq p⟩ end
+
+  definition is_equivalence_pb_Precategory_functor {A : Type} (C : Precategory)
+    (f : A → C) (H : is_split_surjective f) : is_equivalence (pb_Precategory_functor C f) :=
+  @(is_equivalence_of_fully_faithful_of_split_essentially_surjective _)
+    (fully_faithful_pb_Precategory_functor C f)
+    (split_essentially_surjective_pb_Precategory_functor C f H)
+
+  definition pb_Precategory_equivalence [constructor] {A : Type} (C : Precategory) (f : A → C)
+    (H : is_split_surjective f) : pb_Precategory C f ≃c C :=
+  equivalence.mk _ (is_equivalence_pb_Precategory_functor C f H)
+
+  definition pb_Precategory_equivalence_of_equiv [constructor] {A : Type} (C : Precategory)
+    (f : A ≃ C) : pb_Precategory C f ≃c C :=
+  pb_Precategory_equivalence C f (is_split_surjective_of_is_retraction f)
+
+  definition is_isomorphism_pb_Precategory_functor [constructor] {A : Type} (C : Precategory)
+    (f : A ≃ C) : is_isomorphism (pb_Precategory_functor C f) :=
+  (fully_faithful_pb_Precategory_functor C f, to_is_equiv f)
+
+  definition pb_Precategory_isomorphism [constructor] {A : Type} (C : Precategory) (f : A ≃ C) :
+    pb_Precategory C f ≅c C :=
+  isomorphism.mk _ (is_isomorphism_pb_Precategory_functor C f)
+
+end category

hott/algebra/category/constructions/pushout.hlean

@@ -418,7 +418,7 @@ namespace category
         { exact Cpushout_functor_inl η},
         { exact Cpushout_functor_inr η}},
         esimp, apply iso_pathover, apply hom_pathover,
-        rewrite [ap_compose' _ pr₁, ap_compose' _ pr₂, prod_eq_pr1, prod_eq_pr2],
+        rewrite [-ap_compose' _ pr₁, -ap_compose' _ pr₂, prod_eq_pr1, prod_eq_pr2],
         rewrite [-+respect_hom_of_eq (precomposition_functor _ _), +hom_of_eq_eq_of_iso],
         apply nat_trans_eq, intro c, esimp [category.to_precategory],
         rewrite [+id_left, +id_right, Cpushout_functor_list_singleton] end end},

hott/algebra/category/constructions/rezk.hlean

@@ -7,7 +7,7 @@ Authors: Jakob von Raumer
 The Rezk completion
 -/
 
-import algebra.category hit.two_quotient types.trunc types.arrow algebra.category.functor.attributes
+import hit.two_quotient types.trunc types.arrow algebra.category.functor.exponential_laws
 
 open eq category equiv trunc_two_quotient is_trunc iso e_closure function pi trunctype
 
@@ -114,7 +114,7 @@ namespace rezk
     transport (elim_set Pe Pp Pcomp) (pth f) = Pp f :=
   begin
     rewrite [tr_eq_cast_ap_fn, ↑elim_set, ▸*],
-    rewrite [ap_compose' trunctype.carrier, elim_pth], apply tcast_tua_fn
+    rewrite [-ap_compose' trunctype.carrier, elim_pth], apply tcast_tua_fn
   end
 
   end
@@ -157,7 +157,7 @@ namespace rezk
     --induction b using rezk.rec with b' b' b g, --why does this not work if it works below?
     refine @rezk.rec _ _ _ (rezk_hom_left_pth_1_trunc a a' f) _ _ _ b,
     intro b, apply equiv_precompose (to_hom f⁻¹ⁱ), --how do i unfold properly at this point?
-    { intro b b' g, apply equiv_pathover, intro g' g'' H, 
+    { intro b b' g, apply equiv_pathover2, intro g' g'' H,
       refine !pathover_rezk_hom_left_pt ⬝op _,
       refine !assoc ⬝ ap (λ x, x ∘ _) _,  refine eq_of_parallel_po_right _ H,
       apply pathover_rezk_hom_left_pt },

hott/algebra/category/constructions/set.hlean

@@ -48,10 +48,10 @@ namespace category
 
     local attribute is_equiv_iso_of_equiv [instance]
 
-    definition iso_of_eq_eq_compose (A B : Set) : @iso_of_eq _ _ A B =
+    definition iso_of_eq_eq_compose (A B : Set) : @iso_of_eq _ _ A B ~
       @iso_of_equiv A B ∘ @equiv_of_eq A B ∘ subtype_eq_inv _ _ ∘
       @ap _ _ (to_fun (trunctype.sigma_char 0)) A B :=
-    eq_of_homotopy (λp, eq.rec_on p idp)
+    λp, eq.rec_on p idp
 
     definition equiv_equiv_iso (A B : set) : (A ≃ B) ≃ (A ≅ B) :=
     equiv.MK (λf, iso_of_equiv f)
@@ -68,18 +68,15 @@ namespace category
     definition is_univalent_Set (A B : set) : is_equiv (iso_of_eq : A = B → A ≅ B) :=
     have H₁ : is_equiv (@iso_of_equiv A B ∘ @equiv_of_eq A B ∘ subtype_eq_inv _ _ ∘
               @ap _ _ (to_fun (trunctype.sigma_char 0)) A B), from
-      @is_equiv_compose _ _ _ _ _
-      (@is_equiv_compose _ _ _ _ _
-         (@is_equiv_compose _ _ _ _ _
+      is_equiv_compose _ _
+      (is_equiv_compose _ _
+         (is_equiv_compose _ _
            _
            (@is_equiv_subtype_eq_inv _ _ _ _ _))
          !univalence)
        !is_equiv_iso_of_equiv,
-    let H₂ := (iso_of_eq_eq_compose A B)⁻¹ in
-    begin
-      rewrite H₂ at H₁,
-      assumption
-    end
+    is_equiv.homotopy_closed _ (iso_of_eq_eq_compose A B)⁻¹ʰᵗʸ _
+
   end set
 
   definition category_Set [instance] [constructor] : category Set :=

hott/algebra/category/functor/adjoint.hlean

@@ -43,6 +43,34 @@ namespace category
   abbreviation counit_unit_eq [unfold 4] := @is_left_adjoint.H
   abbreviation unit_counit_eq [unfold 4] := @is_left_adjoint.K
 
+  section
+
+  variables {C D : Precategory} {F : C ⇒ D} {G : D ⇒ C}
+
+  definition is_left_adjoint_of_adjoint [unfold 5] (H : F ⊣ G) : is_left_adjoint F :=
+  begin
+    induction H with η ε H K, exact is_left_adjoint.mk G η ε H K
+  end
+
+  definition adjoint_opposite [constructor] (H : F ⊣ G) : Gᵒᵖᶠ ⊣ Fᵒᵖᶠ :=
+  begin
+    fconstructor,
+    { rexact opposite_nat_trans (to_counit H)},
+    { rexact opposite_nat_trans (to_unit H)},
+    { rexact to_unit_counit_eq H},
+    { rexact to_counit_unit_eq H}
+  end
+
+  definition adjoint_of_opposite [constructor] (H : Fᵒᵖᶠ ⊣ Gᵒᵖᶠ) : G ⊣ F :=
+  begin
+    fconstructor,
+    { rexact opposite_rev_nat_trans (to_counit H)},
+    { rexact opposite_rev_nat_trans (to_unit H)},
+    { rexact to_unit_counit_eq H},
+    { rexact to_counit_unit_eq H}
+  end
+
+
   theorem is_prop_is_left_adjoint [instance] {C : Category} {D : Precategory} (F : C ⇒ D)
     : is_prop (is_left_adjoint F) :=
   begin
@@ -119,8 +147,10 @@ namespace category
      rewrite [assoc,nf_fn_eq_fn_nf_pt ε' ε d,-assoc,▸*,H (G' d),id_right]}
    end
 
+  end
+
   section
-  universe variables u v w
+  universe variables u v w z
   parameters {C : Precategory.{u v}} {D : Precategory.{w v}} {F : C ⇒ D} {G : D ⇒ C}
           (θ : hom_functor D ∘f prod_functor_prod Fᵒᵖᶠ 1 ≅ hom_functor C ∘f prod_functor_prod 1 G)
   include θ
@@ -183,92 +213,42 @@ namespace category
   end
 
   end
-/- TODO (below): generalize above definitions to arbitrary categories
+
+
   section
-  universe variables u₁ u₂ v₁ v₂
-  parameters {C : Precategory.{u₁ v₁}} {D : Precategory.{u₂ v₂}} {F : C ⇒ D} {G : D ⇒ C}
-          (θ : functor_lift.{v₂ v₁} ∘f hom_functor D ∘f prod_functor_prod Fᵒᵖᶠ 1 ≅
-               functor_lift.{v₁ v₂} ∘f hom_functor C ∘f prod_functor_prod 1 G)
-  include θ
-  open lift
-  definition adj_unit [constructor] : 1 ⟹ G ∘f F :=
-  begin
-    fapply nat_trans.mk: esimp,
-    { intro c, exact down (natural_map (to_hom θ) (c, F c) (up id))},
-    { intro c c' f,
-      let H := naturality (to_hom θ) (ID c, F f),
-      let K := ap10 H (up id),
-      rewrite [▸* at K, id_right at K, ▸*, K, respect_id, +id_right],
-      clear H K,
-      let H := naturality (to_hom θ) (f, ID (F c')),
-      let K := ap10 H id,
-      rewrite [▸* at K, respect_id at K,+id_left at K, K]}
-  end
+  universe variables u v
+  parameters {C D : Precategory.{u v}} (F : C ⇒ D) (U : D → C)
+  (ε : Πd, F (U d) ⟶ d) (θ : Π{c : C} {d : D} (g : F c ⟶ d), c ⟶ U d)
+  (θ_coh : Π{c : C} {d : D} (g : F c ⟶ d), ε d ∘ F (θ g) = g)
+  (θ_unique : Π{c : C} {d : D} {g : F c ⟶ d} {f : c ⟶ U d}, ε d ∘ F f = g → θ g = f)
 
-  definition adj_counit [constructor] : F ∘f G ⟹ 1 :=
-  begin
-    fapply nat_trans.mk: esimp,
-    { intro d, exact natural_map (to_inv θ) (G d, d) id, },
-    { intro d d' g,
-      let H := naturality (to_inv θ) (Gᵒᵖᶠ g, ID d'),
-      let K := ap10 H id,
-      rewrite [▸* at K, id_left at K, ▸*, K, respect_id, +id_left],
-      clear H K,
-      let H := naturality (to_inv θ) (ID (G d), g),
-      let K := ap10 H id,
-      rewrite [▸* at K, respect_id at K,+id_right at K, K]}
-  end
-
-  theorem adj_eq_unit (c : C) (d : D) (f : F c ⟶ d)
-    : natural_map (to_hom θ) (c, d) (up f) = G f ∘ adj_unit c :=
-  begin
-    esimp,
-    let H := naturality (to_hom θ) (ID c, f),
-    let K := ap10 H id,
-    rewrite [▸* at K, id_right at K, K, respect_id, +id_right],
-  end
-
-  theorem adj_eq_counit (c : C) (d : D) (g : c ⟶ G d)
-    : natural_map (to_inv θ) (c, d) (up g) = adj_counit d ∘ F g :=
-  begin
-    esimp,
-    let H := naturality (to_inv θ) (g, ID d),
-    let K := ap10 H id,
-    rewrite [▸* at K, id_left at K, K, respect_id, +id_left],
-  end
-
-  definition adjoint.mk' [constructor] : F ⊣ G :=
-  begin
-    fapply adjoint.mk,
-    { exact adj_unit},
-    { exact adj_counit},
-    { intro c, esimp, refine (adj_eq_counit c (F c) (adj_unit c))⁻¹ ⬝ _,
-      apply ap10 (to_left_inverse (componentwise_iso θ (c, F c)))},
-    { intro d, esimp, refine (adj_eq_unit (G d) d (adj_counit d))⁻¹ ⬝ _,
-      apply ap10 (to_right_inverse (componentwise_iso θ (G d, d)))},
-  end
-
-  end
--/
-
-  variables {C D : Precategory} {F : C ⇒ D} {G : D ⇒ C}
-
-  definition adjoint_opposite [constructor] (H : F ⊣ G) : Gᵒᵖᶠ ⊣ Fᵒᵖᶠ :=
+  include θ_coh θ_unique
+  definition right_adjoint_simple [constructor] : D ⇒ C :=
   begin
     fconstructor,
-    { rexact opposite_nat_trans (to_counit H)},
-    { rexact opposite_nat_trans (to_unit H)},
-    { rexact to_unit_counit_eq H},
-    { rexact to_counit_unit_eq H}
+    { exact U },
+    { intro d d' g, exact θ (g ∘ ε d) },
+    { intro d, apply θ_unique, refine idp ∘2 !respect_id ⬝ !id_right ⬝ !id_left⁻¹ },
+    { intro d₁ d₂ d₃ g' g, apply θ_unique, refine idp ∘2 !respect_comp ⬝ !assoc ⬝ _,
+      refine !θ_coh ∘2 idp ⬝ !assoc' ⬝ idp ∘2 !θ_coh ⬝ !assoc, }
   end
 
-  definition adjoint_of_opposite [constructor] (H : Fᵒᵖᶠ ⊣ Gᵒᵖᶠ) : G ⊣ F :=
+  definition bijection_simple : hom_functor D ∘f prod_functor_prod Fᵒᵖᶠ 1 ≅
+    hom_functor C ∘f prod_functor_prod 1 right_adjoint_simple :=
   begin
-    fconstructor,
-    { rexact opposite_rev_nat_trans (to_counit H)},
-    { rexact opposite_rev_nat_trans (to_unit H)},
-    { rexact to_unit_counit_eq H},
-    { rexact to_counit_unit_eq H}
+    fapply natural_iso.MK,
+    { intro x f, exact θ f },
+    { esimp, intro x x' f, apply eq_of_homotopy, intro g, symmetry, apply θ_unique,
+      refine idp ∘2 !respect_comp ⬝ !assoc ⬝ _, refine !θ_coh ∘2 idp ⬝ !assoc' ⬝ idp ∘2 _,
+      refine idp ∘2 !respect_comp ⬝ !assoc ⬝ !θ_coh ∘2 idp },
+    { esimp, intro x f, exact ε _ ∘ F f },
+    { esimp, intro x, apply eq_of_homotopy, intro g, exact θ_coh g },
+    { esimp, intro x, apply eq_of_homotopy, intro g, exact θ_unique idp }
+  end
+
+  definition is_left_adjoint.mk_simple [constructor] : is_left_adjoint F :=
+  is_left_adjoint_of_adjoint (adjoint.mk' bijection_simple)
+
   end
 
 end category

hott/algebra/category/functor/adjoint2.hlean

@@ -1,10 +1,11 @@
 
 import .equivalence
 
-open eq functor nat_trans
+open eq functor nat_trans prod prod.ops
 
 namespace category
 
+
   variables {C D E : Precategory} (F : C ⇒ D) (G : D ⇒ C) (H : D ≅c E)
 /-
   definition adjoint_compose [constructor] (K : F ⊣ G)

hott/algebra/category/functor/attributes.hlean

@@ -43,14 +43,14 @@ namespace category
   definition hom_inv_respect_id (F : C ⇒ D) [H : fully_faithful F] (c : C) :
     hom_inv F (ID (F c)) = id :=
   begin
-    apply eq_of_fn_eq_fn' (to_fun_hom F),
+    apply inj' (to_fun_hom F),
     exact !(right_inv (to_fun_hom F)) ⬝ !respect_id⁻¹,
   end
 
   definition hom_inv_respect_comp (F : C ⇒ D) [H : fully_faithful F] {a b c : C}
     (g : F b ⟶ F c) (f : F a ⟶ F b) : hom_inv F (g ∘ f) = hom_inv F g ∘ hom_inv F f :=
   begin
-    apply eq_of_fn_eq_fn' (to_fun_hom F),
+    apply inj' (to_fun_hom F),
     refine !(right_inv (to_fun_hom F)) ⬝ _ ⬝ !respect_comp⁻¹,
     rewrite [right_inv (to_fun_hom F), right_inv (to_fun_hom F)],
   end
@@ -60,9 +60,9 @@ namespace category
   begin
     fconstructor,
     { exact (to_fun_hom F)⁻¹ᶠ (F f)⁻¹},
-    { apply eq_of_fn_eq_fn' (to_fun_hom F),
+    { apply inj' (to_fun_hom F),
       rewrite [respect_comp,right_inv (to_fun_hom F),respect_id,left_inverse]},
-    { apply eq_of_fn_eq_fn' (to_fun_hom F),
+    { apply inj' (to_fun_hom F),
       rewrite [respect_comp,right_inv (to_fun_hom F),respect_id,right_inverse]},
   end
 
@@ -143,7 +143,7 @@ namespace category
 
   definition fully_faithful_equiv (F : C ⇒ D) : fully_faithful F ≃ (faithful F × full F) :=
   equiv_of_is_prop (λH, (faithful_of_fully_faithful F, full_of_fully_faithful F))
-                    (λH, fully_faithful_of_full_of_faithful (pr1 H) (pr2 H))
+                    (λH, fully_faithful_of_full_of_faithful (pr1 H) (pr2 H)) _ _
 
 /- alternative proof using direct calculation with equivalences
 
@@ -165,7 +165,7 @@ namespace category
 
   definition fully_faithful_compose (G : D ⇒ E) (F : C ⇒ D) [fully_faithful G] [fully_faithful F] :
     fully_faithful (G ∘f F) :=
-  λc c', is_equiv_compose (to_fun_hom G) (to_fun_hom F)
+  λc c', is_equiv_compose (to_fun_hom G) (to_fun_hom F) _ _
 
   definition full_compose (G : D ⇒ E) (F : C ⇒ D) [full G] [full F] : full (G ∘f F) :=
   λc c', is_surjective_compose (to_fun_hom G) (to_fun_hom F) _ _

hott/algebra/category/functor/basic.hlean

@@ -185,7 +185,7 @@ namespace functor
     local attribute trunctype.struct [instance] [priority 1] -- remove after #842 is closed
     protected theorem is_set_functor [instance]
       [HD : is_set D] : is_set (functor C D) :=
-    by apply is_trunc_equiv_closed; apply functor.sigma_char
+    is_trunc_equiv_closed 0 !functor.sigma_char _
   end
 
   /- higher equalities in the functor type -/

hott/algebra/category/functor/equivalence.hlean

@@ -161,7 +161,7 @@ namespace category
     { exact inverse_of_fully_faithful_of_split_essentially_surjective},
     { fapply natural_iso.mk',
       { intro c, esimp, apply reflect_iso F, exact (H₂ (F c)).2},
-      intro c c' f, esimp, apply eq_of_fn_eq_fn' (to_fun_hom F),
+      intro c c' f, esimp, apply inj' (to_fun_hom F),
       rewrite [+respect_comp, +right_inv (to_fun_hom F), comp_inverse_cancel_left]},
     { fapply natural_iso.mk',
       { intro c, esimp, exact (H₂ c).2},
@@ -283,7 +283,7 @@ namespace category
       { intro H, induction H with H1 H2, induction H1, induction H2, reflexivity},
       { intro H, induction H, reflexivity}
     end,
-    apply is_trunc_equiv_closed_rev, exact f,
+    exact is_trunc_equiv_closed_rev -1 f _
   end
 
   theorem is_prop_is_isomorphism [instance] (F : C ⇒ D) : is_prop (is_isomorphism F) :=

hott/algebra/category/iso.hlean

@@ -201,10 +201,7 @@ namespace iso
 
   -- The type of isomorphisms between two objects is a set
   definition is_set_iso [instance] : is_set (a ≅ b) :=
-  begin
-    apply is_trunc_is_equiv_closed,
-      apply equiv.to_is_equiv (!iso.sigma_char),
-  end
+  is_trunc_equiv_closed _ !iso.sigma_char _
 
   definition iso_of_eq [unfold 5] (p : a = b) : a ≅ b :=
   eq.rec_on p (iso.refl a)

hott/algebra/category/nat_trans.hlean

@@ -93,7 +93,7 @@ namespace nat_trans
   end
 
   definition is_set_nat_trans [instance] : is_set (F ⟹ G) :=
-  by apply is_trunc_is_equiv_closed; apply (equiv.to_is_equiv !nat_trans.sigma_char)
+  is_trunc_equiv_closed _ !nat_trans.sigma_char _
 
   definition change_natural_map [constructor] (η : F ⟹ G) (f : Π (a : C), F a ⟶ G a)
     (p : Πa, η a = f a) : F ⟹ G :=

hott/algebra/category/precategory.hlean

@@ -65,7 +65,7 @@ namespace category
 
   section basic_lemmas
     variables {ob : Type} [C : precategory ob]
-    variables {a b c d : ob} {h : c ⟶ d} {g : hom b c} {f f' : hom a b} {i : a ⟶ a}
+    variables {a b c d : ob} {h : c ⟶ d} {g g' : hom b c} {f f' : hom a b} {i : a ⟶ a}
     include C
 
     definition id [reducible] [unfold 2] := ID a
@@ -93,6 +93,10 @@ namespace category
     definition homset [reducible] [constructor] (x y : ob) : Set :=
     Set.mk (hom x y) _
 
+    definition comp2 (p : g = g') (q : f = f') : g ∘ f = g' ∘ f' :=
+    ap011 (λg f, comp g f) p q
+
+    infix ` ∘2 `:79 := comp2
   end basic_lemmas
   section squares
     parameters {ob : Type} [C : precategory ob]
@@ -144,6 +148,7 @@ namespace category
       (H : wc ∘ xg = yg ∘ wb) (yh : yc ⟶ yd) (xf : xa ⟶ xb)
         : (yh ∘ wc) ∘ (xg ∘ xf) = (yh ∘ yg) ∘ (wb ∘ xf)  :=
     square_precompose (square_postcompose H yh) xf
+
   end squares
 
   structure Precategory : Type :=
@@ -176,17 +181,17 @@ namespace category
     (q : Πa b c g f, cast p (@comp ob C a b c g f) = @comp ob D a b c (cast p g) (cast p f))
       : C = D :=
   begin
-    induction C with hom1 comp1 ID1 a b il ir, induction D with hom2 comp2 ID2 a' b' il' ir',
+    induction C with hom1 c1 ID1 a b il ir, induction D with hom2 c2 ID2 a' b' il' ir',
     esimp at *,
     revert q, eapply homotopy2.rec_on @p, esimp, clear p, intro p q, induction p,
     esimp at *,
-    have H : comp1 = comp2,
+    have H : c1 = c2,
     begin apply eq_of_homotopy3, intros, apply eq_of_homotopy2, intros, apply q end,
     induction H,
     have K : ID1 = ID2,
     begin apply eq_of_homotopy, intro a, exact !ir'⁻¹ ⬝ !il end,
     induction K,
-    apply ap0111111 (precategory.mk' hom1 comp1 ID1): apply is_prop.elim
+    apply ap0111111 (precategory.mk' hom1 c1 ID1): apply is_prop.elim
   end
 
 

hott/algebra/default.hlean

@@ -4,4 +4,4 @@ Released under Apache 2.0 license as described in the file LICENSE.
 Authors: Floris van Doorn
 -/
 
-import .homotopy_group .ordered_field
+import .homotopy_group .ordered_field .lattice .group_power

hott/algebra/field.hlean

@@ -6,7 +6,7 @@ Authors: Robert Lewis
 Structures with multiplicative and additive components, including division rings and fields.
 The development is modeled after Isabelle's library.
 -/
-import algebra.binary algebra.group algebra.ring
+import algebra.ring
 open eq eq.ops algebra
 set_option class.force_new true
 

hott/algebra/graph.hlean

@@ -326,5 +326,23 @@ namespace paths
     { exact v_0 ⬝ v_1}
   end
 
+  inductive all (T : Π⦃a₁ a₂ : A⦄, R a₁ a₂ → Type) : Π⦃a₁ a₂ : A⦄, paths R a₁ a₂ → Type :=
+  | nil {} : Π{a : A}, all T (@nil A R a)
+  | cons   : Π{a₁ a₂ a₃ : A} {r : R a₂ a₃} {p : paths R a₁ a₂}, T r → all T p → all T (cons r p)
+
+  inductive Exists (T : Π⦃a₁ a₂ : A⦄, R a₁ a₂ → Type) : Π⦃a₁ a₂ : A⦄, paths R a₁ a₂ → Type :=
+  | base : Π{a₁ a₂ a₃ : A} {r : R a₂ a₃} (p : paths R a₁ a₂), T r → Exists T (cons r p)
+  | cons : Π{a₁ a₂ a₃ : A} (r : R a₂ a₃) {p : paths R a₁ a₂}, Exists T p → Exists T (cons r p)
+
+  inductive mem (l : R a₃ a₄) : Π⦃a₁ a₂ : A⦄, paths R a₁ a₂ → Type :=
+  | base : Π{a₂ : A} (p : paths R a₂ a₃), mem l (cons l p)
+  | cons : Π{a₁ a₂ a₃ : A} (r : R a₂ a₃) {p : paths R a₁ a₂}, mem l p → mem l (cons r p)
+
+  definition len (p : paths R a₁ a₂) : ℕ :=
+  begin
+    induction p with a a₁ a₂ a₃ r p IH,
+    { exact 0 },
+    { exact nat.succ IH }
+  end
 
 end paths

hott/algebra/group.hlean

@@ -1,7 +1,7 @@
 /-
 Copyright (c) 2014 Jeremy Avigad. All rights reserved.
 Released under Apache 2.0 license as described in the file LICENSE.
-Authors: Jeremy Avigad, Leonardo de Moura
+Authors: Jeremy Avigad, Leonardo de Moura, Floris van Doorn
 
 Various multiplicative and additive structures. Partially modeled on Isabelle's library.
 -/

hott/algebra/group_power.hlean

@@ -0,0 +1,357 @@
+/-
+Copyright (c) 2015 Jeremy Avigad. All rights reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+Author: Jeremy Avigad
+
+The power operation on monoids prod groups. We separate this from group, because it depends on
+nat, which in turn depends on other parts of algebra.
+
+We have "pow a n" for natural number powers, prod "gpow a i" for integer powers. The notation
+a^n is used for the first, but users can locally redefine it to gpow when needed.
+
+Note: power adopts the convention that 0^0=1.
+-/
+import types.nat.basic types.int.basic .homomorphism .group_theory
+open algebra eq
+
+namespace algebra
+variables {A B : Type}
+
+structure has_pow_nat [class] (A : Type) :=
+(pow_nat : A → nat → A)
+
+definition pow_nat {A : Type} [s : has_pow_nat A] : A → nat → A :=
+has_pow_nat.pow_nat
+
+infix ` ^ ` := pow_nat
+
+structure has_pow_int [class] (A : Type) :=
+(pow_int : A → int → A)
+
+definition pow_int {A : Type} [s : has_pow_int A] : A → int → A :=
+has_pow_int.pow_int
+
+ /- monoid -/
+section monoid
+open nat
+
+variable [s : monoid A]
+include s
+
+definition monoid.pow (a : A) : ℕ → A
+| 0     := 1
+| (n+1) := a * monoid.pow n
+
+definition monoid_has_pow_nat [instance] : has_pow_nat A :=
+has_pow_nat.mk monoid.pow
+
+theorem pow_zero (a : A) : a^0 = 1 := rfl
+theorem pow_succ (a : A) (n : ℕ) : a^(succ n) = a * a^n := rfl
+
+theorem pow_one (a : A) : a^1 = a := !mul_one
+theorem pow_two (a : A) : a^2 = a * a :=
+calc
+  a^2 = a * (a * 1) : rfl
+  ... = a * a       : mul_one
+theorem pow_three (a : A) : a^3 = a * (a * a) :=
+calc
+  a^3 = a * (a * (a * 1)) : rfl
+  ... = a * (a * a)       : mul_one
+theorem pow_four (a : A) : a^4 = a * (a * (a * a))  :=
+calc
+  a^4 = a * a^3           : rfl
+  ... = a * (a * (a * a)) : pow_three
+
+theorem pow_succ' (a : A) : Πn, a^(succ n) = a^n * a
+| 0        := by rewrite [pow_succ, *pow_zero, one_mul, mul_one]
+| (succ n) := by rewrite [pow_succ, pow_succ' at {1}, pow_succ, mul.assoc]
+
+theorem one_pow : Π n : ℕ, 1^n = (1:A)
+| 0        := rfl
+| (succ n) := by rewrite [pow_succ, one_mul, one_pow]
+
+theorem pow_add (a : A) (m n : ℕ) : a^(m + n) = a^m * a^n :=
+begin
+  induction n with n ih,
+    {krewrite [nat.add_zero, pow_zero, mul_one]},
+  rewrite [add_succ, *pow_succ', ih, mul.assoc]
+end
+
+theorem pow_mul (a : A) (m : ℕ) : Π n, a^(m * n) = (a^m)^n
+| 0        := by rewrite [nat.mul_zero, pow_zero]
+| (succ n) := by rewrite [nat.mul_succ, pow_add, pow_succ', pow_mul]
+
+theorem pow_comm (a : A) (m n : ℕ)  : a^m * a^n = a^n * a^m :=
+by rewrite [-*pow_add, add.comm]
+
+end monoid
+
+/- commutative monoid -/
+
+section comm_monoid
+open nat
+variable [s : comm_monoid A]
+include s
+
+theorem mul_pow (a b : A) : Π n, (a * b)^n = a^n * b^n
+| 0        := by rewrite [*pow_zero, mul_one]
+| (succ n) := by rewrite [*pow_succ', mul_pow, *mul.assoc, mul.left_comm a]
+
+end comm_monoid
+
+section group
+variable [s : group A]
+include s
+
+section nat
+open nat
+theorem inv_pow (a : A) : Πn, (a⁻¹)^n = (a^n)⁻¹
+| 0        := by rewrite [*pow_zero, one_inv]
+| (succ n) := by rewrite [pow_succ, pow_succ', inv_pow, mul_inv]
+theorem pow_sub (a : A) {m n : ℕ} (H : m ≥ n) : a^(m - n) = a^m * (a^n)⁻¹ :=
+have H1 : m - n + n = m, from nat.sub_add_cancel H,
+have H2 : a^(m - n) * a^n = a^m, by rewrite [-pow_add, H1],
+eq_mul_inv_of_mul_eq H2
+
+theorem pow_inv_comm (a : A) : Πm n, (a⁻¹)^m * a^n = a^n * (a⁻¹)^m
+| 0 n               := by rewrite [*pow_zero, one_mul, mul_one]
+| m 0               := by rewrite [*pow_zero, one_mul, mul_one]
+| (succ m) (succ n) := by rewrite [pow_succ' at {1}, pow_succ at {1}, pow_succ', pow_succ,
+                            *mul.assoc, inv_mul_cancel_left, mul_inv_cancel_left, pow_inv_comm]
+
+lemma respect_pow [group B] (f : A → B) [is_mul_hom f] (a : A) : Πn, f (a ^ n) = (f a) ^ n
+| 0        := respect_one f
+| (succ n) := by rewrite [pow_succ, respect_mul, respect_pow]
+
+end nat
+
+open int
+
+definition gpow (a : A) : ℤ → A
+| (of_nat n) := a^n
+| -[1+n]     := (a^(nat.succ n))⁻¹
+
+open nat
+
+lemma gpow_zero (a : A) : gpow a 0 = 1 := rfl
+lemma gpow_one (a : A) : gpow a 1 = a := pow_one a
+lemma gpow_eq_pow (a : A) (n : ℕ) : gpow a n = a^n := by reflexivity
+
+private lemma gpow_add_aux (a : A) (m n : ℕ) :
+  gpow a ((of_nat m) + -[1+n]) = gpow a (of_nat m) * gpow a (-[1+n]) :=
+sum.elim (nat.lt_sum_ge m (nat.succ n))
+  (assume H : (m < nat.succ n),
+    have H1 : (#nat nat.succ n - m > nat.zero), from nat.sub_pos_of_lt H,
+    calc
+      gpow a ((of_nat m) + -[1+n]) = gpow a (sub_nat_nat m (nat.succ n))  : rfl
+        ... = gpow a (-[1+ nat.pred (nat.sub (nat.succ n) m)])            : {sub_nat_nat_of_lt H}
+        ... = (a ^ (nat.succ (nat.pred (nat.sub (nat.succ n) m))))⁻¹    : rfl
+        ... = (a ^ (nat.succ n) * (a ^ m)⁻¹)⁻¹                        :
+                by krewrite [succ_pred_of_pos H1, pow_sub a (nat.le_of_lt H)]
+        ... = a ^ m * (a ^ (nat.succ n))⁻¹                            :
+                by rewrite [mul_inv, inv_inv]
+        ... = gpow a (of_nat m) * gpow a (-[1+n])                         : rfl)
+  (assume H : (m ≥ nat.succ n),
+    calc
+      gpow a ((of_nat m) + -[1+n]) = gpow a (sub_nat_nat m (nat.succ n))  : rfl
+        ... = gpow a (#nat m - nat.succ n)                                : {sub_nat_nat_of_ge H}
+        ... = a ^ m * (a ^ (nat.succ n))⁻¹                                : pow_sub a H
+        ... = gpow a (of_nat m) * gpow a (-[1+n])                         : rfl)
+
+theorem gpow_add (a : A) : Πi j : int, gpow a (i + j) = gpow a i * gpow a j
+| (of_nat m) (of_nat n) := !pow_add
+| (of_nat m) -[1+n]     := !gpow_add_aux
+| -[1+m]     (of_nat n) := by rewrite [add.comm, gpow_add_aux, ↑gpow, -*inv_pow, pow_inv_comm]
+| -[1+m]     -[1+n]     :=
+  calc
+    gpow a (-[1+m] + -[1+n]) = (a^(#nat nat.succ m + nat.succ n))⁻¹ : rfl
+      ... = (a^(nat.succ m))⁻¹ * (a^(nat.succ n))⁻¹ : by rewrite [pow_add, pow_comm, mul_inv]
+      ... = gpow a (-[1+m]) * gpow a (-[1+n])       : rfl
+
+theorem gpow_comm (a : A) (i j : ℤ) : gpow a i * gpow a j = gpow a j * gpow a i :=
+by rewrite [-*gpow_add, add.comm]
+
+lemma gpow_neg (a : A) : Π(n : ℤ), gpow a (-n) = (gpow a n)⁻¹
+| (of_nat n) := begin cases n with n, exact !one_inv⁻¹, reflexivity end
+| -[1+n]     := by rewrite [↑gpow at {2}, inv_inv]
+
+lemma inv_gpow (a : A) : Π(n : ℤ), gpow a⁻¹ n = (gpow a n)⁻¹
+| (of_nat n) := !inv_pow
+| -[1+n]     := by rewrite [↑gpow, inv_pow]
+
+private lemma gpow_mul_aux (a : A) (m n : ℕ) :
+  gpow a ((of_nat m) * -[1+n]) = gpow (gpow a (of_nat m)) (-[1+n]) :=
+by rewrite [↑gpow at {2,3}, -pow_mul, -gpow_eq_pow, -gpow_neg]
+
+theorem gpow_mul (a : A) : Π n m, gpow a (n * m) = gpow (gpow a n) m
+| (of_nat m) (of_nat n) := !pow_mul
+| (of_nat m) -[1+n]     := by rewrite [↑gpow at {2,3}, -pow_mul, -gpow_eq_pow, -gpow_neg]
+| -[1+m]     (of_nat n) := by rewrite [↑gpow at {2,3}, inv_pow, -pow_mul, -gpow_eq_pow, -gpow_neg]
+| -[1+m]     -[1+n]     := by rewrite [↑gpow at {2,3}, inv_pow, inv_inv, -pow_mul]
+
+lemma respect_gpow [group B] (f : A → B) [is_mul_hom f] (a : A) : Πn, f (gpow a n) = gpow (f a) n
+| (of_nat n) := !respect_pow
+| -[1+n]     := by rewrite [↑gpow, respect_inv, respect_pow]
+
+end group
+
+section comm_monoid
+open int
+variable [ab_group A]
+
+theorem mul_gpow (a b : A) : Πi, gpow (a * b) i = gpow a i * gpow b i
+| (of_nat n) := !mul_pow
+| -[1+n]     := by rewrite [↑gpow,-mul_inv,mul.comm,mul_pow]
+
+end comm_monoid
+
+section ordered_ring
+open nat
+variable [s : linear_ordered_ring A]
+include s
+
+theorem pow_pos {a : A} (H : a > 0) (n : ℕ) : a ^ n > 0 :=
+  begin
+    induction n,
+    krewrite pow_zero,
+    apply zero_lt_one,
+    rewrite pow_succ',
+    apply mul_pos,
+    apply v_0, apply H
+  end
+
+theorem pow_ge_one_of_ge_one {a : A} (H : a ≥ 1) (n : ℕ) : a ^ n ≥ 1 :=
+  begin
+    induction n,
+    krewrite pow_zero,
+    apply le.refl,
+    rewrite [pow_succ', -mul_one 1],
+    apply mul_le_mul v_0 H zero_le_one,
+    apply le_of_lt,
+    apply pow_pos,
+    apply gt_of_ge_of_gt H zero_lt_one
+  end
+
+theorem pow_two_add (n : ℕ) : (2:A)^n + 2^n = 2^(succ n) :=
+  by rewrite [pow_succ', -one_add_one_eq_two, left_distrib, *mul_one]
+
+end ordered_ring
+
+section bundled
+open group
+lemma to_respect_pow {A B : Group} (f : A →g B) (a : A) (n : ℕ) : f (a ^ n) = (f a) ^ n :=
+respect_pow f a n
+
+lemma to_respect_gpow {A B : Group} (f : A →g B) (a : A) (n : ℤ) : f (gpow a n) = gpow (f a) n :=
+respect_gpow f a n
+end bundled
+
+/- additive monoid -/
+
+section add_monoid
+variable [s : add_monoid A]
+include s
+local attribute add_monoid.to_monoid [trans_instance]
+open nat
+
+definition nmul : ℕ → A → A := λ n a, a^n
+
+local infix [priority algebra.prio] `⬝` := nmul
+
+theorem zero_nmul (a : A) : (0:ℕ) ⬝ a = 0 := pow_zero a
+theorem succ_nmul (n : ℕ) (a : A) : nmul (succ n) a = a + (nmul n a) := pow_succ a n
+
+theorem succ_nmul' (n : ℕ) (a : A) : succ n ⬝ a = nmul n a + a := pow_succ' a n
+
+theorem nmul_zero (n : ℕ) : n ⬝ 0 = (0:A) := one_pow n
+
+theorem one_nmul (a : A) : 1 ⬝ a = a := pow_one a
+
+theorem add_nmul (m n : ℕ) (a : A) : (m + n) ⬝ a = (m ⬝ a) + (n ⬝ a) := pow_add a m n
+
+theorem mul_nmul (m n : ℕ) (a : A) : (m * n) ⬝ a = m ⬝ (n ⬝ a) :=
+eq.subst (mul.comm n m) (pow_mul a n m)
+
+theorem nmul_comm (m n : ℕ) (a : A) : (m ⬝ a) + (n ⬝ a) = (n ⬝ a) + (m ⬝ a) := pow_comm a m n
+
+end add_monoid
+
+namespace ops
+infix [priority algebra.prio] `⬝` := nmul
+end ops
+open algebra.ops
+/- additive commutative monoid -/
+
+section add_comm_monoid
+open nat
+variable [s : add_comm_monoid A]
+include s
+local attribute add_comm_monoid.to_comm_monoid [trans_instance]
+
+theorem nmul_add (n : ℕ) (a b : A) : n ⬝ (a + b) = (n ⬝ a) + (n ⬝ b) := mul_pow a b n
+
+end add_comm_monoid
+
+section add_group
+variable [s : add_group A]
+include s
+local attribute add_group.to_group [trans_instance]
+
+section nat
+open nat
+theorem nmul_neg (n : ℕ) (a : A) : n ⬝ (-a) = -(n ⬝ a) := inv_pow a n
+
+theorem sub_nmul {m n : ℕ} (a : A) (H : m ≥ n) : (m - n) ⬝ a = (m ⬝ a) + -(n ⬝ a) := pow_sub a H
+
+theorem nmul_neg_comm (m n : ℕ) (a : A) : (m ⬝ (-a)) + (n ⬝ a) = (n ⬝ a) + (m ⬝ (-a)) :=
+pow_inv_comm a m n
+
+lemma respect_nmul [add_group B] (f : A → B) [H : is_add_hom f] (n : ℕ) (a : A) :
+  f (nmul n a) = nmul n (f a) :=
+to_respect_pow (group.homomorphism.mk f H) a n
+
+end nat
+
+open int
+
+definition imul : ℤ → A → A := λ i a, gpow a i
+
+theorem add_imul (i j : ℤ) (a : A) : imul (i + j) a = imul i a + imul j a :=
+  gpow_add a i j
+
+theorem imul_comm (i j : ℤ) (a : A) : imul i a + imul j a = imul j a + imul i a := gpow_comm a i j
+
+end add_group
+
+section add_ab_group
+open int
+variable [add_ab_group A]
+local attribute add_ab_group.to_ab_group [trans_instance]
+
+theorem imul_add (i : ℤ) (a b : A) : imul i (a + b) = imul i a + imul i b :=
+mul_gpow a b i
+
+theorem mul_imul (i j : ℤ) (a : A) : imul (i * j) a = imul i (imul j a) :=
+by rewrite [mul.comm]; apply gpow_mul
+
+lemma one_imul (a : A) : imul 1 a = a :=
+gpow_one a
+
+lemma respect_imul [add_group B] (f : A → B) [H : is_add_hom f] (n : ℤ) (a : A) :
+  f (imul n a) = imul n (f a) :=
+to_respect_gpow (group.homomorphism.mk f H) a n
+
+end add_ab_group
+
+section bundled
+open group
+
+lemma to_respect_nmul {A B : AddGroup} (f : A →g B) (n : ℕ) (a : A) : f (nmul n a) = nmul n (f a) :=
+to_respect_pow f a n
+
+lemma to_respect_imul {A B : AddGroup} (f : A →g B) (n : ℤ) (a : A) : f (imul n a) = imul n (f a) :=
+to_respect_gpow f a n
+
+end bundled
+
+end algebra

hott/algebra/group_theory.hlean

@@ -6,9 +6,10 @@ Authors: Floris van Doorn
 Basic group theory
 -/
 
-import algebra.category.category algebra.bundled .homomorphism
+import algebra.category.category algebra.inf_group_theory .homomorphism types.pointed2
+       algebra.trunc_group
 
-open eq algebra pointed function is_trunc pi equiv is_equiv
+open eq algebra pointed function is_trunc pi equiv is_equiv sigma sigma.ops trunc
 set_option class.force_new true
 
 namespace group
@@ -18,10 +19,6 @@ namespace group
   definition Group.struct' [instance] [reducible] (G : Group) : group G :=
   Group.struct G
 
-  definition ab_group_Group_of_AbGroup [instance] [constructor] [priority 900]
-    (G : AbGroup) : ab_group (Group_of_AbGroup G) :=
-  begin esimp, exact _ end
-
   definition ab_group_pSet_of_Group [instance] (G : AbGroup) : ab_group (pSet_of_Group G) :=
   AbGroup.struct G
 
@@ -29,81 +26,28 @@ namespace group
     group (pSet_of_Group G) :=
   Group.struct G
 
-  /- group homomorphisms -/
-/-
-  definition is_homomorphism [class] [reducible]
-    {G₁ G₂ : Type} [has_mul G₁] [has_mul G₂] (φ : G₁ → G₂) : Type :=
-  Π(g h : G₁), φ (g * h) = φ g * φ h
+  /- left and right actions -/
+  definition is_equiv_mul_right [constructor] {A : Group} (a : A) : is_equiv (λb, b * a) :=
+  adjointify _ (λb : A, b * a⁻¹) (λb, !inv_mul_cancel_right) (λb, !mul_inv_cancel_right)
 
-  section
-  variables {G G₁ G₂ G₃ : Type} {g h : G₁} (ψ : G₂ → G₃) {φ₁ φ₂ : G₁ → G₂} (φ : G₁ → G₂)
-            [group G] [group G₁] [group G₂] [group G₃]
-            [is_homomorphism ψ] [is_homomorphism φ₁] [is_homomorphism φ₂] [is_homomorphism φ]
+  definition right_action [constructor] {A : Group} (a : A) : A ≃ A :=
+  equiv.mk _ (is_equiv_mul_right a)
 
-  definition respect_mul {G₁ G₂ : Type} [has_mul G₁] [has_mul G₂] (φ : G₁ → G₂)
-    [is_homomorphism φ] : Π(g h : G₁), φ (g * h) = φ g * φ h :=
-  by assumption
+  definition is_equiv_add_right [constructor] {A : AddGroup} (a : A) : is_equiv (λb, b + a) :=
+  adjointify _ (λb : A, b - a) (λb, !neg_add_cancel_right) (λb, !add_neg_cancel_right)
 
-  theorem respect_one /- φ -/ : φ 1 = 1 :=
-  mul.right_cancel
-    (calc
-      φ 1 * φ 1 = φ (1 * 1) : respect_mul φ
-            ... = φ 1 : ap φ !one_mul
-            ... = 1 * φ 1 : one_mul)
+  definition add_right_action [constructor] {A : AddGroup} (a : A) : A ≃ A :=
+  equiv.mk _ (is_equiv_add_right a)
 
-  theorem respect_inv /- φ -/ (g : G₁) : φ g⁻¹ = (φ g)⁻¹ :=
-  eq_inv_of_mul_eq_one (!respect_mul⁻¹ ⬝ ap φ !mul.left_inv ⬝ !respect_one)
+  /- homomorphisms -/
 
-  definition is_embedding_homomorphism /- φ -/ (H : Π{g}, φ g = 1 → g = 1) : is_embedding φ :=
-  begin
-    apply function.is_embedding_of_is_injective,
-    intro g g' p,
-    apply eq_of_mul_inv_eq_one,
-    apply H,
-    refine !respect_mul ⬝ _,
-    rewrite [respect_inv φ, p],
-    apply mul.right_inv
-  end
-
-  definition is_homomorphism_compose {ψ : G₂ → G₃} {φ : G₁ → G₂}
-    (H1 : is_homomorphism ψ) (H2 : is_homomorphism φ) : is_homomorphism (ψ ∘ φ) :=
-  λg h, ap ψ !respect_mul ⬝ !respect_mul
-
-  definition is_homomorphism_id (G : Type) [group G] : is_homomorphism (@id G) :=
-  λg h, idp
-
-  end
-
-  section additive
-
-  definition is_add_homomorphism [class] [reducible] {G₁ G₂ : Type} [has_add G₁] [has_add G₂]
-    (φ : G₁ → G₂) : Type :=
-  Π(g h : G₁), φ (g + h) = φ g + φ h
-
-  variables {G₁ G₂ : Type} (φ : G₁ → G₂) [add_group G₁] [add_group G₂] [is_add_homomorphism φ]
-
-  definition respect_add /- φ -/ : Π(g h : G₁), φ (g + h) = φ g + φ h :=
-  by assumption
-
-  theorem respect_zero /- φ -/ : φ 0 = 0 :=
-  add.right_cancel
-    (calc
-      φ 0 + φ 0 = φ (0 + 0) : respect_add φ
-            ... = φ 0 : ap φ !zero_add
-            ... = 0 + φ 0 : zero_add)
-
-  theorem respect_neg /- φ -/ (g : G₁) : φ (-g) = -(φ g) :=
-  eq_neg_of_add_eq_zero (!respect_add⁻¹ ⬝ ap φ !add.left_inv ⬝ !respect_zero)
-
-  end additive
--/
   structure homomorphism (G₁ G₂ : Group) : Type :=
     (φ : G₁ → G₂)
     (p : is_mul_hom φ)
 
   infix ` →g `:55 := homomorphism
 
-  definition group_fun [unfold 3] [coercion] := @homomorphism.φ
+  abbreviation group_fun [unfold 3] [coercion] [reducible] := @homomorphism.φ
   definition homomorphism.struct [unfold 3] [instance] [priority 900] {G₁ G₂ : Group}
     (φ : G₁ →g G₂) : is_mul_hom φ :=
   homomorphism.p φ
@@ -141,7 +85,7 @@ namespace group
       { intro v, induction v, reflexivity},
       { intro φ, induction φ, reflexivity}
     end,
-    apply is_trunc_equiv_closed_rev, exact H
+    exact is_trunc_equiv_closed_rev 0 H _
   end
 
   variables {G₁ G₂}
@@ -153,7 +97,7 @@ namespace group
   homomorphism.mk f
     (λg h, (p (g * h))⁻¹ ⬝ to_respect_mul φ g h ⬝ ap011 mul (p g) (p h))
 
-  definition homomorphism_eq (p : group_fun φ₁ ~ group_fun φ₂) : φ₁ = φ₂ :=
+  definition homomorphism_eq (p : φ₁ ~ φ₂) : φ₁ = φ₂ :=
   begin
     induction φ₁ with φ₁ q₁, induction φ₂ with φ₂ q₂, esimp at p, induction p,
     exact ap (homomorphism.mk φ₁) !is_prop.elim
@@ -200,7 +144,7 @@ namespace group
 
   /- categorical structure of groups + homomorphisms -/
 
-  definition homomorphism_compose [constructor] [trans] (ψ : G₂ →g G₃) (φ : G₁ →g G₂) : G₁ →g G₃ :=
+  definition homomorphism_compose [constructor] [trans] [reducible] (ψ : G₂ →g G₃) (φ : G₁ →g G₂) : G₁ →g G₃ :=
   homomorphism.mk (ψ ∘ φ) (is_mul_hom_compose _ _)
 
   variable (G)
@@ -212,6 +156,10 @@ namespace group
   infixr ` ∘g `:75 := homomorphism_compose
   notation 1       := homomorphism_id _
 
+  definition homomorphism_compose_eq (ψ : G₂ →g G₃) (φ : G₁ →g G₂) (g : G₁) :
+    (ψ ∘g φ) g = ψ (φ g) :=
+  by reflexivity
+
   structure isomorphism (A B : Group) :=
     (to_hom : A →g B)
     (is_equiv_to_hom : is_equiv to_hom)
@@ -232,27 +180,24 @@ namespace group
     (p : Πg₁ g₂, φ (g₁ * g₂) = φ g₁ * φ g₂) : G₁ ≃g G₂ :=
   isomorphism.mk (homomorphism.mk φ p) !to_is_equiv
 
-  definition isomorphism_of_eq [constructor] {G₁ G₂ : Group} (φ : G₁ = G₂) : G₁ ≃g G₂ :=
-  isomorphism_of_equiv (equiv_of_eq (ap Group.carrier φ))
-    begin intros, induction φ, reflexivity end
-
-  definition pequiv_of_isomorphism_of_eq {G₁ G₂ : Group} (p : G₁ = G₂) :
-    pequiv_of_isomorphism (isomorphism_of_eq p) = pequiv_of_eq (ap pType_of_Group p) :=
-  begin
-    induction p,
-    apply pequiv_eq,
-    fapply pmap_eq,
-    { intro g, reflexivity},
-    { apply is_prop.elim}
-  end
+  definition isomorphism.MK [constructor] (φ : G₁ →g G₂) (ψ : G₂ →g G₁)
+    (p : φ ∘g ψ ~ gid G₂) (q : ψ ∘g φ ~ gid G₁) : G₁ ≃g G₂ :=
+  isomorphism.mk φ (adjointify φ ψ p q)
 
   definition to_ginv [constructor] (φ : G₁ ≃g G₂) : G₂ →g G₁ :=
   homomorphism.mk φ⁻¹
     abstract begin
-    intro g₁ g₂, apply eq_of_fn_eq_fn' φ,
+    intro g₁ g₂, apply inj' φ,
     rewrite [respect_mul φ, +right_inv φ]
     end end
 
+  definition isomorphism_of_eq [constructor] {G₁ G₂ : Group} (φ : G₁ = G₂) : G₁ ≃g G₂ :=
+  isomorphism_of_equiv (equiv_of_eq (ap Group.carrier φ))
+    begin intros, induction φ, reflexivity end
+
+  definition isomorphism_ap {A : Type} (F : A → Group) {a b : A} (p : a = b) : F a ≃g F b :=
+  isomorphism_of_eq (ap F p)
+
   variable (G)
   definition isomorphism.refl [refl] [constructor] : G ≃g G :=
   isomorphism.mk 1 !is_equiv_id
@@ -262,7 +207,7 @@ namespace group
   isomorphism.mk (to_ginv φ) !is_equiv_inv
 
   definition isomorphism.trans [trans] [constructor] (φ : G₁ ≃g G₂) (ψ : G₂ ≃g G₃) : G₁ ≃g G₃ :=
-  isomorphism.mk (ψ ∘g φ) !is_equiv_compose
+  isomorphism.mk (ψ ∘g φ) (is_equiv_compose ψ φ _ _)
 
   definition isomorphism.eq_trans [trans] [constructor]
      {G₁ G₂ : Group} {G₃ : Group} (φ : G₁ = G₂) (ψ : G₂ ≃g G₃) : G₁ ≃g G₃ :=
@@ -277,33 +222,187 @@ namespace group
   infixl ` ⬝gp `:75 := isomorphism.trans_eq
   infixl ` ⬝pg `:75 := isomorphism.eq_trans
 
-  definition pmap_of_isomorphism [constructor] (φ : G₁ ≃g G₂) :
-    G₁ →* G₂ :=
+  definition pmap_of_isomorphism [constructor] (φ : G₁ ≃g G₂) : G₁ →* G₂ :=
   pequiv_of_isomorphism φ
 
-  /- category of groups -/
+  definition to_fun_isomorphism_trans {G H K : Group} (φ : G ≃g H) (ψ : H ≃g K) :
+    φ ⬝g ψ ~ ψ ∘ φ :=
+  by reflexivity
 
-  section
-  open category
-  definition precategory_group [constructor] : precategory Group :=
-  precategory.mk homomorphism
-                 @homomorphism_compose
-                 @homomorphism_id
-                 (λG₁ G₂ G₃ G₄ φ₃ φ₂ φ₁, homomorphism_eq (λg, idp))
-                 (λG₁ G₂ φ, homomorphism_eq (λg, idp))
-                 (λG₁ G₂ φ, homomorphism_eq (λg, idp))
+  definition add_homomorphism (G H : AddGroup) : Type := homomorphism G H
+  infix ` →a `:55 := add_homomorphism
+
+  abbreviation agroup_fun [coercion] [unfold 3] [reducible] {G H : AddGroup} (φ : G →a H) : G → H :=
+  φ
+
+  definition add_homomorphism.struct [instance] {G H : AddGroup} (φ : G →a H) : is_add_hom φ :=
+  homomorphism.addstruct φ
+
+  definition add_homomorphism.mk [constructor] {G H : AddGroup} (φ : G → H) (h : is_add_hom φ) : G →g H :=
+  homomorphism.mk φ h
+
+  definition add_homomorphism_compose [constructor] [trans] [reducible] {G₁ G₂ G₃ : AddGroup}
+    (ψ : G₂ →a G₃) (φ : G₁ →a G₂) : G₁ →a G₃ :=
+  add_homomorphism.mk (ψ ∘ φ) (is_add_hom_compose _ _)
+
+  definition add_homomorphism_id [constructor] [refl] (G : AddGroup) : G →a G :=
+  add_homomorphism.mk (@id G) (is_add_hom_id G)
+
+  abbreviation aid [constructor] := @add_homomorphism_id
+  infixr ` ∘a `:75 := add_homomorphism_compose
+
+  definition to_respect_add' {H₁ H₂ : AddGroup} (χ : H₁ →a H₂) (g h : H₁) : χ (g + h) = χ g + χ h :=
+  respect_add χ g h
+
+  theorem to_respect_zero' {H₁ H₂ : AddGroup} (χ : H₁ →a H₂) : χ 0 = 0 :=
+  respect_zero χ
+
+  theorem to_respect_neg' {H₁ H₂ : AddGroup} (χ : H₁ →a H₂) (g : H₁) : χ (-g) = -(χ g) :=
+  respect_neg χ g
+
+  definition pmap_of_homomorphism_gid (G : Group) : pmap_of_homomorphism (gid G) ~* pid G :=
+  begin
+    fapply phomotopy_of_homotopy, reflexivity
   end
 
-  -- TODO
-  -- definition category_group : category Group :=
-  -- category.mk precategory_group
-  -- begin
-  --   intro G₁ G₂,
-  --   fapply adjointify,
-  --   { intro φ, fapply Group_eq, },
-  --   { },
-  --   { }
-  -- end
+  definition pmap_of_homomorphism_gcompose {G H K : Group} (ψ : H →g K) (φ : G →g H)
+    : pmap_of_homomorphism (ψ ∘g φ) ~* pmap_of_homomorphism ψ ∘* pmap_of_homomorphism φ :=
+  begin
+    fapply phomotopy_of_homotopy, reflexivity
+  end
+
+  definition pmap_of_homomorphism_phomotopy {G H : Group} {φ ψ : G →g H} (H : φ ~ ψ)
+    : pmap_of_homomorphism φ ~* pmap_of_homomorphism ψ :=
+  begin
+    fapply phomotopy_of_homotopy, exact H
+  end
+
+  definition pequiv_of_isomorphism_trans {G₁ G₂ G₃ : Group} (φ : G₁ ≃g G₂) (ψ : G₂ ≃g G₂) :
+    pequiv_of_isomorphism (φ ⬝g ψ) ~* pequiv_of_isomorphism ψ ∘* pequiv_of_isomorphism φ :=
+  begin
+    apply phomotopy_of_homotopy, reflexivity
+  end
+
+  protected definition homomorphism.sigma_char [constructor]
+    (A B : Group) : (A →g B) ≃ Σ(f : A → B), is_mul_hom f :=
+  begin
+    fapply equiv.MK,
+      {intro F, exact ⟨F, _⟩ },
+      {intro p, cases p with f H, exact (homomorphism.mk f H) },
+      {intro p, cases p, reflexivity },
+      {intro F, cases F, reflexivity },
+  end
+
+  definition homomorphism_pathover {A : Type} {a a' : A} (p : a = a')
+    {B : A → Group} {C : A → Group} (f : B a →g C a) (g : B a' →g C a')
+    (r : homomorphism.φ f =[p] homomorphism.φ g) : f =[p] g :=
+  begin
+    fapply pathover_of_fn_pathover_fn,
+    { intro a, apply homomorphism.sigma_char },
+    { fapply sigma_pathover, exact r, apply is_prop.elimo }
+  end
+
+  protected definition isomorphism.sigma_char [constructor]
+    (A B : Group) : (A ≃g B) ≃ Σ(f : A →g B), is_equiv f :=
+  begin
+    fapply equiv.MK,
+      {intro F, exact ⟨F, _⟩ },
+      {intro p, exact (isomorphism.mk p.1 p.2) },
+      {intro p, cases p, reflexivity },
+      {intro F, cases F, reflexivity },
+  end
+
+  definition isomorphism_pathover {A : Type} {a a' : A} (p : a = a')
+    {B : A → Group} {C : A → Group} (f : B a ≃g C a) (g : B a' ≃g C a')
+    (r : pathover (λa, B a → C a) f p g) : f =[p] g :=
+  begin
+    fapply pathover_of_fn_pathover_fn,
+    { intro a, apply isomorphism.sigma_char },
+    { fapply sigma_pathover, apply homomorphism_pathover, exact r, apply is_prop.elimo }
+  end
+
+
+  definition isomorphism_eq {G H : Group} {φ ψ : G ≃g H} (p : φ ~ ψ) : φ = ψ :=
+  begin
+    induction φ with φ φe, induction ψ with ψ ψe,
+    exact apd011 isomorphism.mk (homomorphism_eq p) !is_prop.elimo
+  end
+
+  definition is_set_isomorphism [instance] (G H : Group) : is_set (G ≃g H) :=
+  begin
+    have H : G ≃g H ≃ Σ(f : G →g H), is_equiv f,
+    begin
+      fapply equiv.MK,
+      { intro φ, induction φ, constructor, assumption },
+      { intro v, induction v, constructor, assumption },
+      { intro v, induction v, reflexivity },
+      { intro φ, induction φ, reflexivity }
+    end,
+    exact is_trunc_equiv_closed_rev _ H _
+  end
+
+  definition trivial_homomorphism (A B : Group) : A →g B :=
+  homomorphism.mk (λa, 1) (λa a', (mul_one 1)⁻¹)
+
+  definition trivial_add_homomorphism (A B : AddGroup) : A →a B :=
+  homomorphism.mk (λa, 0) (λa a', (add_zero 0)⁻¹)
+
+  /- the group structure on homomorphisms between two abelian groups -/
+
+  definition homomorphism_add [constructor] {G H : AddAbGroup} (φ ψ : G →a H) : G →a H :=
+  add_homomorphism.mk (λg, φ g + ψ g)
+    abstract begin
+      intro g g', refine ap011 add !to_respect_add' !to_respect_add' ⬝ _,
+      refine !add.assoc ⬝ ap (add _) (!add.assoc⁻¹ ⬝ ap (λx, x + _) !add.comm ⬝ !add.assoc) ⬝
+        !add.assoc⁻¹
+    end end
+
+  definition homomorphism_mul [constructor] {G H : AbGroup} (φ ψ : G →g H) : G →g H :=
+  homomorphism.mk (λg, φ g * ψ g) (to_respect_add (homomorphism_add φ ψ))
+
+  definition homomorphism_inv [constructor] {G H : AbGroup} (φ : G →g H) : G →g H :=
+  begin
+    apply homomorphism.mk (λg, (φ g)⁻¹),
+    intro g h,
+    refine ap (λx, x⁻¹) (to_respect_mul φ g h) ⬝ !mul_inv ⬝ !mul.comm,
+  end
+
+  definition ab_group_homomorphism [constructor] (G H : AbGroup) : ab_group (G →g H) :=
+  begin
+    refine ab_group.mk _ homomorphism_mul _ (trivial_homomorphism G H) _ _ homomorphism_inv _ _,
+    { intros φ₁ φ₂ φ₃, apply homomorphism_eq, intro g, apply mul.assoc },
+    { intro φ, apply homomorphism_eq, intro g, apply one_mul },
+    { intro φ, apply homomorphism_eq, intro g, apply mul_one },
+    { intro φ, apply homomorphism_eq, intro g, apply mul.left_inv },
+    { intro φ ψ, apply homomorphism_eq, intro g, apply mul.comm }
+  end
+
+  definition aghomomorphism [constructor] (G H : AbGroup) : AbGroup :=
+  AbGroup.mk (G →g H) (ab_group_homomorphism G H)
+
+  infixr ` →gg `:56 := aghomomorphism
+
+  /- some properties of binary homomorphisms -/
+  definition pmap_of_homomorphism2 [constructor] {G H K : AbGroup} (φ : G →g H →gg K) :
+    G →* H →** K :=
+  pmap.mk (λg, pmap_of_homomorphism (φ g))
+    (eq_of_phomotopy (phomotopy_of_homotopy (ap010 group_fun (to_respect_one φ))))
+
+  definition homomorphism_apply [constructor] (G H : AbGroup) (g : G) :
+    (G →gg H) →g H :=
+  begin
+    fapply homomorphism.mk,
+    { intro φ, exact φ g },
+    { intros φ φ', reflexivity }
+  end
+
+  definition homomorphism_swap [constructor] {G H K : AbGroup} (φ : G →g H →gg K) :
+    H →g G →gg K :=
+  begin
+    fapply homomorphism.mk,
+    { intro h, exact homomorphism_apply H K h ∘g φ },
+    { intro h h', apply homomorphism_eq, intro g, exact to_respect_mul (φ g) h h' }
+  end
 
   /- given an equivalence A ≃ B we can transport a group structure on A to a group structure on B -/
 
@@ -334,7 +433,7 @@ namespace group
     by rewrite [↑group_equiv_mul, ↑group_equiv_one, ↑group_equiv_inv,
                 +left_inv f, mul.left_inv]
 
-    definition group_equiv_closed : group B :=
+    definition group_equiv_closed [constructor] : group B :=
     ⦃group,
       mul          := group_equiv_mul,
       mul_assoc    := group_equiv_mul_assoc,
@@ -343,29 +442,85 @@ namespace group
       mul_one      := group_equiv_mul_one,
       inv          := group_equiv_inv,
       mul_left_inv := group_equiv_mul_left_inv,
-    is_set_carrier := is_trunc_equiv_closed 0 f⦄
+    is_set_carrier := is_trunc_equiv_closed 0 f _ ⦄
 
   end
 
+  section
+    variables {A B : Type} (f : A ≃ B) [ab_group A]
+    definition group_equiv_mul_comm (b b' : B) : group_equiv_mul f b b' = group_equiv_mul f b' b :=
+    by rewrite [↑group_equiv_mul, mul.comm]
+
+    definition ab_group_equiv_closed [constructor] : ab_group B :=
+    ⦃ab_group, group_equiv_closed f,
+      mul_comm := group_equiv_mul_comm f⦄
+  end
+
   variable (G)
 
   /- the trivial group -/
   open unit
-  definition trivial_group [constructor] : group unit :=
+  definition group_unit [constructor] : group unit :=
   group.mk _ (λx y, star) (λx y z, idp) star (unit.rec idp) (unit.rec idp) (λx, star) (λx, idp)
 
-  definition Trivial_group [constructor] : Group :=
-  Group.mk _ trivial_group
+  definition ab_group_unit [constructor] : ab_group unit :=
+  ⦃ab_group, group_unit, mul_comm := λx y, idp⦄
 
-  abbreviation G0 := Trivial_group
+  definition trivial_group [constructor] : Group :=
+  Group.mk _ group_unit
 
-  definition trivial_group_of_is_contr [H : is_contr G] : G ≃g G0 :=
+  abbreviation G0 := trivial_group
+
+  definition AbGroup_of_Group.{u} (G : Group.{u}) (H : Π x y : G, x * y = y * x) : AbGroup.{u} :=
+  begin
+    induction G,
+    fapply AbGroup.mk,
+    assumption,
+    exact ⦃ab_group, struct', mul_comm := H⦄
+  end
+
+  definition trivial_ab_group : AbGroup.{0} :=
+  begin
+    fapply AbGroup_of_Group trivial_group, intro x y, reflexivity
+  end
+
+  definition trivial_group_of_is_contr (H : is_contr G) : G ≃g G0 :=
   begin
     fapply isomorphism_of_equiv,
-    { apply equiv_unit_of_is_contr},
+    { exact equiv_unit_of_is_contr _ _ },
     { intros, reflexivity }
   end
 
+  definition isomorphism_of_is_contr {G H : Group} (hG : is_contr G) (hH : is_contr H) : G ≃g H :=
+  trivial_group_of_is_contr G _ ⬝g (trivial_group_of_is_contr H _)⁻¹ᵍ
+
+  definition ab_group_of_is_contr (A : Type) (H : is_contr A) : ab_group A :=
+  have ab_group unit, from ab_group_unit,
+  ab_group_equiv_closed (equiv_unit_of_is_contr A _)⁻¹ᵉ
+
+  definition group_of_is_contr (A : Type) (H : is_contr A) : group A :=
+  have ab_group A, from ab_group_of_is_contr A H, by apply _
+
+  definition ab_group_lift_unit : ab_group (lift unit) :=
+  ab_group_of_is_contr (lift unit) _
+
+  definition trivial_ab_group_lift : AbGroup :=
+  AbGroup.mk _ ab_group_lift_unit
+
+  definition from_trivial_ab_group (A : AbGroup) : trivial_ab_group →g A :=
+  trivial_homomorphism trivial_ab_group A
+
+  definition is_embedding_from_trivial_ab_group (A : AbGroup) :
+    is_embedding (from_trivial_ab_group A) :=
+  begin
+    fapply is_embedding_of_is_injective,
+    intro x y p,
+    induction x, induction y, reflexivity
+  end
+
+  definition to_trivial_ab_group (A : AbGroup) : A →g trivial_ab_group :=
+  trivial_homomorphism A trivial_ab_group
+
   variable {G}
 
   /-
@@ -395,6 +550,9 @@ namespace group
             mul_left_inv_pt := mul.left_inv⦄
   end
 
+  definition pgroup_of_Group (X : Group) : pgroup X :=
+  pgroup_of_group _ idp
+
   definition Group_of_pgroup (G : Type*) [pgroup G] : Group :=
   Group.mk G _
 
@@ -404,39 +562,6 @@ namespace group
     mul_pt := mul_one,
     mul_left_inv_pt := mul.left_inv ⦄
 
-  -- infinity pgroups
-
-  structure inf_pgroup [class] (X : Type*) extends inf_semigroup X, has_inv X :=
-    (pt_mul : Πa, mul pt a = a)
-    (mul_pt : Πa, mul a pt = a)
-    (mul_left_inv_pt : Πa, mul (inv a) a = pt)
-
-  definition inf_group_of_inf_pgroup [reducible] [instance] (X : Type*) [H : inf_pgroup X]
-    : inf_group X :=
-  ⦃inf_group, H,
-          one := pt,
-          one_mul := inf_pgroup.pt_mul ,
-          mul_one := inf_pgroup.mul_pt,
-          mul_left_inv := inf_pgroup.mul_left_inv_pt⦄
-
-  definition inf_pgroup_of_inf_group (X : Type*) [H : inf_group X] (p : one = pt :> X) : inf_pgroup X :=
-  begin
-    cases X with X x, esimp at *, induction p,
-    exact ⦃inf_pgroup, H,
-            pt_mul := one_mul,
-            mul_pt := mul_one,
-            mul_left_inv_pt := mul.left_inv⦄
-  end
-
-  definition inf_Group_of_inf_pgroup (G : Type*) [inf_pgroup G] : InfGroup :=
-  InfGroup.mk G _
-
-  definition inf_pgroup_InfGroup [instance] (G : InfGroup) : inf_pgroup G :=
-  ⦃ inf_pgroup, InfGroup.struct G,
-    pt_mul := one_mul,
-    mul_pt := mul_one,
-    mul_left_inv_pt := mul.left_inv ⦄
-
   /- equality of groups and abelian groups -/
 
   definition group.to_has_mul {A : Type} (H : group A) : has_mul A := _
@@ -533,7 +658,50 @@ namespace group
   end
 
   definition trivial_group_of_is_contr' (G : Group) [H : is_contr G] : G = G0 :=
-  eq_of_isomorphism (trivial_group_of_is_contr G)
+  eq_of_isomorphism (trivial_group_of_is_contr G _)
 
+  definition pequiv_of_isomorphism_of_eq {G₁ G₂ : Group} (p : G₁ = G₂) :
+    pequiv_of_isomorphism (isomorphism_of_eq p) = pequiv_of_eq (ap pType_of_Group p) :=
+  begin
+    induction p,
+    apply pequiv_eq,
+    fapply phomotopy.mk,
+    { intro g, reflexivity },
+    { apply is_prop.elim }
+  end
+
+  /- relation with infgroups -/
+  -- todo: define homomorphism in terms of inf_homomorphism and similar for isomorphism?
+  open infgroup
+
+  definition homomorphism_of_inf_homomorphism [constructor] {G H : Group} (φ : G →∞g H) : G →g H :=
+  homomorphism.mk φ (inf_homomorphism.struct φ)
+
+  definition inf_homomorphism_of_homomorphism [constructor] {G H : Group} (φ : G →g H) : G →∞g H :=
+  inf_homomorphism.mk φ (homomorphism.struct φ)
+
+  definition isomorphism_of_inf_isomorphism [constructor] {G H : Group} (φ : G ≃∞g H) : G ≃g H :=
+  isomorphism.mk (homomorphism_of_inf_homomorphism φ) (inf_isomorphism.is_equiv_to_hom φ)
+
+  definition inf_isomorphism_of_isomorphism [constructor] {G H : Group} (φ : G ≃g H) : G ≃∞g H :=
+  inf_isomorphism.mk (inf_homomorphism_of_homomorphism φ) (isomorphism.is_equiv_to_hom φ)
+
+  definition gtrunc_functor {A B : InfGroup} (f : A →∞g B) : gtrunc A →g gtrunc B :=
+  begin
+    apply homomorphism.mk (trunc_functor 0 f),
+    intros x x', induction x with a, induction x' with a', apply ap tr, exact respect_mul f a a'
+  end
+
+  definition gtrunc_isomorphism_gtrunc {A B : InfGroup} (f : A ≃∞g B) : gtrunc A ≃g gtrunc B :=
+  isomorphism_of_equiv (trunc_equiv_trunc 0 (equiv_of_inf_isomorphism f))
+                       (to_respect_mul (gtrunc_functor f))
+
+  definition gtr [constructor] (X : InfGroup) : X →∞g gtrunc X :=
+  inf_homomorphism.mk tr homotopy2.rfl
+
+  definition gtrunc_isomorphism [constructor] (X : InfGroup) [H : is_set X] : gtrunc X ≃∞g X :=
+  (inf_isomorphism_of_equiv (trunc_equiv 0 X)⁻¹ᵉ homotopy2.rfl)⁻¹ᵍ⁸
+
+  definition is_set_group_inf [instance] (G : Group) : group G := Group.struct G
 
 end group

hott/algebra/homomorphism.hlean

@@ -5,7 +5,7 @@ Author: Jeremy Avigad
 
 Homomorphisms between structures.
 -/
-import algebra.ring algebra.category.category
+import algebra.ring function
 open eq function is_trunc
 
 namespace algebra
@@ -49,8 +49,7 @@ section add_group_A_B
   by rewrite [*sub_eq_add_neg, *(respect_add f), (respect_neg f)]
 
   definition is_embedding_of_is_add_hom [add_group B] (f : A → B) [is_add_hom f]
-      (H : ∀ x, f x = 0 → x = 0) :
-    is_embedding f :=
+      (H : ∀ x, f x = 0 → x = 0) : is_embedding f :=
   is_embedding_of_is_injective
     (take x₁ x₂,
       suppose f x₁ = f x₂,
@@ -58,11 +57,17 @@ section add_group_A_B
       have x₁ - x₂ = 0, from H _ this,
       eq_of_sub_eq_zero this)
 
-  definition eq_zero_of_is_add_hom [add_group B] {f : A → B} [is_add_hom f]
+  definition eq_zero_of_is_add_hom {f : A → B} [is_add_hom f]
       [is_embedding f] {a : A} (fa0 : f a = 0) :
     a = 0 :=
   have f a = f 0, by rewrite [fa0, respect_zero f],
   show a = 0, from is_injective_of_is_embedding this
+
+  theorem eq_zero_of_eq_zero_of_is_embedding {f : A → B} [is_add_hom f] [is_embedding f]
+    {a : A} (h : f a = 0) : a = 0 :=
+  have f a = f 0, by rewrite [h, respect_zero],
+  show a = 0, from is_injective_of_is_embedding this
+
 end add_group_A_B
 
 /- multiplicative structures -/
@@ -97,7 +102,7 @@ section group_A_B
   have f (a⁻¹) * f a = 1, by rewrite [-respect_mul f, mul.left_inv, respect_one f],
   eq_inv_of_mul_eq_one this
 
-  definition is_embedding_of_is_mul_hom [group B] (f : A → B) [is_mul_hom f]
+  definition is_embedding_of_is_mul_hom (f : A → B) [is_mul_hom f]
       (H : ∀ x, f x = 1 → x = 1) :
     is_embedding f :=
   is_embedding_of_is_injective
@@ -107,7 +112,7 @@ section group_A_B
       have x₁ * x₂⁻¹ = 1, from H _ this,
       eq_of_mul_inv_eq_one this)
 
-  definition eq_one_of_is_mul_hom [add_group B] {f : A → B} [is_mul_hom f]
+  definition eq_one_of_is_mul_hom {f : A → B} [is_mul_hom f]
       [is_embedding f] {a : A} (fa1 : f a = 1) :
     a = 1 :=
   have f a = f 1, by rewrite [fa1, respect_one f],

hott/algebra/homotopy_group.hlean

@@ -10,55 +10,47 @@ import .trunc_group types.trunc .group_theory types.nat.hott
 
 open nat eq pointed trunc is_trunc algebra group function equiv unit is_equiv nat
 
--- TODO: consistently make n an argument before A
--- TODO: rename cghomotopy_group to aghomotopy_group
--- TODO: rename homotopy_group_functor_compose to homotopy_group_functor_pcompose
+/- todo: prove more properties of homotopy groups using gtrunc and agtrunc -/
+
 namespace eq
 
-  definition inf_pgroup_loop [constructor] [instance] (A : Type*) : inf_pgroup (Ω A) :=
-  inf_pgroup.mk concat con.assoc inverse idp_con con_idp con.left_inv
-
-  definition inf_group_loop [constructor] (A : Type*) : inf_group (Ω A) := _
-
-  definition ab_inf_group_loop [constructor] [instance] (A : Type*) : ab_inf_group (Ω (Ω A)) :=
-  ⦃ab_inf_group, inf_group_loop _, mul_comm := eckmann_hilton⦄
-
-  definition gloop [constructor] (A : Type*) : InfGroup :=
-  InfGroup.mk (Ω A) (inf_group_loop A)
-
   definition homotopy_group [reducible] [constructor] (n : ℕ) (A : Type*) : Set* :=
   ptrunc 0 (Ω[n] A)
 
   notation `π[`:95  n:0 `]`:0 := homotopy_group n
 
-  definition group_homotopy_group [instance] [constructor] [reducible] (n : ℕ) (A : Type*)
-    : group (π[succ n] A) :=
-  trunc_group (Ω[succ n] A)
+  section
+  local attribute inf_group_loopn [instance]
+  definition group_homotopy_group [instance] [constructor] [reducible] (n : ℕ) [is_succ n]
+    (A : Type*) : group (π[n] A) :=
+  group_trunc (Ω[n] A)
+  end
 
   definition group_homotopy_group2 [instance] (k : ℕ) (A : Type*) :
     group (carrier (ptrunctype.to_pType (π[k + 1] A))) :=
-  group_homotopy_group k A
+  group_homotopy_group (k+1) A
 
-  definition ab_group_homotopy_group [constructor] [reducible] (n : ℕ) (A : Type*)
-    : ab_group (π[succ (succ n)] A) :=
-  trunc_ab_group (Ω[succ (succ n)] A)
+  section
+  local attribute ab_inf_group_loopn [instance]
+  definition ab_group_homotopy_group [constructor] [reducible] (n : ℕ) [is_at_least_two n]
+    (A : Type*) : ab_group (π[n] A) :=
+  ab_group_trunc (Ω[n] A)
+  end
 
   local attribute ab_group_homotopy_group [instance]
 
-  definition ghomotopy_group [constructor] : Π(n : ℕ) [is_succ n] (A : Type*), Group
-  | (succ n) x A := Group.mk (π[succ n] A) _
+  definition ghomotopy_group [constructor] (n : ℕ) [is_succ n] (A : Type*) : Group :=
+  gtrunc (Ωg[n] A)
 
-  definition cghomotopy_group [constructor] :
-    Π(n : ℕ) [is_at_least_two n] (A : Type*), AbGroup
-  | (succ (succ n)) x A := AbGroup.mk (π[succ (succ n)] A) _
-
-  definition fundamental_group [constructor] (A : Type*) : Group :=
-  ghomotopy_group 1 A
+  definition aghomotopy_group [constructor] (n : ℕ) [is_at_least_two n] (A : Type*) : AbGroup :=
+  agtrunc (Ωag[n] A)
 
   notation `πg[`:95  n:0 `]`:0 := ghomotopy_group n
-  notation `πag[`:95 n:0 `]`:0 := cghomotopy_group n
+  notation `πag[`:95 n:0 `]`:0 := aghomotopy_group n
 
-  notation `π₁` := fundamental_group -- should this be notation for the group or pointed type?
+  definition fundamental_group [constructor] (A : Type*) : Group := πg[1] A
+
+  notation `π₁` := fundamental_group
 
   definition tr_mul_tr {n : ℕ} {A : Type*} (p q : Ω[n + 1] A) :
     tr p *[πg[n+1] A] tr q = tr (p ⬝ q) :=
@@ -93,37 +85,44 @@ namespace eq
     π[k] (ptrunc k A) ≃* π[k] A :=
   homotopy_group_ptrunc_of_le (le.refl k) A
 
-  theorem trivial_homotopy_of_is_set (A : Type*) [H : is_set A] (n : ℕ) : πg[n+1] A ≃g G0 :=
+  theorem trivial_homotopy_of_is_set (n : ℕ) (A : Type*) [H : is_set A] : πg[n+1] A ≃g G0 :=
   begin
     apply trivial_group_of_is_contr,
     apply is_trunc_trunc_of_is_trunc,
-    apply is_contr_loop_of_is_trunc,
-    apply is_trunc_succ_succ_of_is_set
+    apply is_contr_loop_of_is_trunc (n+1),
+    exact is_trunc_succ_succ_of_is_set _ _ _
   end
 
-  definition homotopy_group_succ_out (A : Type*) (n : ℕ) : π[n + 1] A = π₁ (Ω[n] A) := idp
+  definition homotopy_group_succ_out (n : ℕ) (A : Type*) : π[n + 1] A = π₁ (Ω[n] A) := idp
 
-  definition homotopy_group_succ_in (A : Type*) (n : ℕ) : π[n + 1] A ≃* π[n] (Ω A) :=
-  ptrunc_pequiv_ptrunc 0 (loopn_succ_in A n)
+  definition homotopy_group_succ_in (n : ℕ) (A : Type*) : π[n + 1] A ≃* π[n] (Ω A) :=
+  ptrunc_pequiv_ptrunc 0 (loopn_succ_in n A)
 
-  definition ghomotopy_group_succ_out (A : Type*) (n : ℕ) : πg[n + 1] A = π₁ (Ω[n] A) := idp
+  definition ghomotopy_group_succ_out (n : ℕ) (A : Type*) : πg[n + 1] A = π₁ (Ω[n] A) := idp
 
-  definition homotopy_group_succ_in_con {A : Type*} {n : ℕ} (g h : πg[n + 2] A) :
-    homotopy_group_succ_in A (succ n) (g * h) =
-    homotopy_group_succ_in A (succ n) g * homotopy_group_succ_in A (succ n) h :=
+  definition homotopy_group_succ_in_con {n : ℕ} {A : Type*} (g h : πg[n + 2] A) :
+    homotopy_group_succ_in (succ n) A (g * h) =
+    homotopy_group_succ_in (succ n) A g * homotopy_group_succ_in (succ n) A h :=
   begin
     induction g with p, induction h with q, esimp,
     apply ap tr, apply loopn_succ_in_con
   end
 
-  definition ghomotopy_group_succ_in [constructor] (A : Type*) (n : ℕ) :
+  definition ghomotopy_group_succ_in [constructor] (n : ℕ) (A : Type*) :
     πg[n + 2] A ≃g πg[n + 1] (Ω A) :=
   begin
     fapply isomorphism_of_equiv,
-    { exact homotopy_group_succ_in A (succ n)},
+    { exact homotopy_group_succ_in (succ n) A },
     { exact homotopy_group_succ_in_con },
   end
 
+  definition is_contr_homotopy_group_of_is_contr (n : ℕ) (A : Type*) [is_contr A] : is_contr (π[n] A) :=
+  begin
+    apply is_trunc_trunc_of_is_trunc,
+    apply is_contr_loop_of_is_trunc,
+    exact is_trunc_of_is_contr _ _ _
+  end
+
   definition homotopy_group_functor [constructor] (n : ℕ) {A B : Type*} (f : A →* B)
     : π[n] A →* π[n] B :=
   ptrunc_functor 0 (apn n f)
@@ -137,32 +136,34 @@ namespace eq
   definition homotopy_group_functor_pid (n : ℕ) (A : Type*) : π→[n] (pid A) ~* pid (π[n] A) :=
   ptrunc_functor_phomotopy 0 !apn_pid ⬝* !ptrunc_functor_pid
 
-  definition homotopy_group_functor_compose [constructor] (n : ℕ) {A B C : Type*} (g : B →* C)
+  definition homotopy_group_functor_pcompose [constructor] (n : ℕ) {A B C : Type*} (g : B →* C)
     (f : A →* B) : π→[n] (g ∘* f) ~* π→[n] g ∘* π→[n] f :=
   ptrunc_functor_phomotopy 0 !apn_pcompose ⬝* !ptrunc_functor_pcompose
 
   definition is_equiv_homotopy_group_functor [constructor] (n : ℕ) {A B : Type*} (f : A →* B)
-    [is_equiv f] : is_equiv (π→[n] f) :=
-  @(is_equiv_trunc_functor 0 _) !is_equiv_apn
+    (H : is_equiv f) : is_equiv (π→[n] f) :=
+  @(is_equiv_trunc_functor 0 _) (is_equiv_apn n f H)
 
-  definition homotopy_group_functor_succ_phomotopy_in (n : ℕ) {A B : Type*} (f : A →* B) :
-    homotopy_group_succ_in B n ∘* π→[n + 1] f ~*
-    π→[n] (Ω→ f) ∘* homotopy_group_succ_in A n :=
+  definition homotopy_group_succ_in_natural (n : ℕ) {A B : Type*} (f : A →* B) :
+    psquare (homotopy_group_succ_in n A) (homotopy_group_succ_in n B)
+            (π→[n + 1] f) (π→[n] (Ω→ f)) :=
   begin
-    refine !ptrunc_functor_pcompose⁻¹* ⬝* _ ⬝* !ptrunc_functor_pcompose,
-    exact ptrunc_functor_phomotopy 0 (apn_succ_phomotopy_in n f)
+    exact ptrunc_functor_psquare 0 (loopn_succ_in_natural n f),
   end
 
+  definition homotopy_group_succ_in_natural_unpointed (n : ℕ) {A B : Type*} (f : A →* B) :
+    hsquare (homotopy_group_succ_in n A) (homotopy_group_succ_in n B) (π→[n+1] f) (π→[n] (Ω→ f)) :=
+  homotopy_group_succ_in_natural n f
+
   definition is_equiv_homotopy_group_functor_ap1 (n : ℕ) {A B : Type*} (f : A →* B)
     [is_equiv (π→[n + 1] f)] : is_equiv (π→[n] (Ω→ f)) :=
-  have is_equiv (homotopy_group_succ_in B n ∘* π→[n + 1] f),
-  from is_equiv_compose _ (π→[n + 1] f),
-  have is_equiv (π→[n] (Ω→ f) ∘ homotopy_group_succ_in A n),
-  from is_equiv.homotopy_closed _ (homotopy_group_functor_succ_phomotopy_in n f),
-  is_equiv.cancel_right (homotopy_group_succ_in A n) _
+  have is_equiv (π→[n] (Ω→ f) ∘ homotopy_group_succ_in n A),
+  from is_equiv_of_equiv_of_homotopy (equiv.mk (π→[n+1] f) _ ⬝e homotopy_group_succ_in n B)
+                                     (homotopy_group_succ_in_natural n f)⁻¹*,
+  is_equiv.cancel_right (homotopy_group_succ_in n A) _
 
   definition tinverse [constructor] {X : Type*} : π[1] X →* π[1] X :=
-  ptrunc_functor 0 pinverse
+  ptrunc_functor 0 (pinverse X)
 
   definition is_equiv_tinverse [constructor] (A : Type*) : is_equiv (@tinverse A) :=
   by apply @is_equiv_trunc_functor; apply is_equiv_eq_inverse
@@ -175,6 +176,11 @@ namespace eq
     { reflexivity}
   end
 
+  /- maybe rename: ghomotopy_group_functor -/
+  definition homotopy_group_homomorphism [constructor] (n : ℕ) [H : is_succ n] {A B : Type*}
+    (f : A →* B) : πg[n] A →g πg[n] B :=
+  gtrunc_functor (Ωg→[n] f)
+
   definition homotopy_group_functor_mul [constructor] (n : ℕ) {A B : Type*} (g : A →* B)
     (p q : πg[n+1] A) :
     (π→[n + 1] g) (p *[πg[n+1] A] q) = (π→[n+1] g) p *[πg[n+1] B] (π→[n + 1] g) q :=
@@ -185,22 +191,19 @@ namespace eq
     apply ap tr, apply apn_con
   end
 
-  definition homotopy_group_homomorphism [constructor] (n : ℕ) [H : is_succ n] {A B : Type*}
-    (f : A →* B) : πg[n] A →g πg[n] B :=
-  begin
-    induction H with n, fconstructor,
-    { exact homotopy_group_functor (n+1) f},
-    { apply homotopy_group_functor_mul}
-  end
-
+  /- todo: rename πg→ -/
   notation `π→g[`:95 n:0 `]`:0 := homotopy_group_homomorphism n
 
+  definition homotopy_group_homomorphism_pcompose (n : ℕ) [H : is_succ n] {A B C : Type*} (g : B →* C)
+    (f : A →* B) : π→g[n] (g ∘* f) ~ π→g[n] g ∘ π→g[n] f :=
+  begin
+    induction H with n, exact to_homotopy (homotopy_group_functor_pcompose (succ n) g f)
+  end
+
+  /- todo: use is_succ -/
   definition homotopy_group_isomorphism_of_pequiv [constructor] (n : ℕ) {A B : Type*} (f : A ≃* B)
     : πg[n+1] A ≃g πg[n+1] B :=
-  begin
-    apply isomorphism.mk (homotopy_group_homomorphism (succ n) f),
-    esimp, apply is_equiv_trunc_functor, apply is_equiv_apn,
-  end
+  gtrunc_isomorphism_gtrunc (gloopn_isomorphism_gloopn (n+1) f)
 
   definition homotopy_group_add (A : Type*) (n m : ℕ) :
     πg[n+m+1] A ≃g πg[n+1] (Ω[m] A) :=
@@ -212,11 +215,11 @@ namespace eq
       exact !loopn_succ_in⁻¹ᵉ*}
   end
 
-  theorem trivial_homotopy_add_of_is_set_loopn {A : Type*} {n : ℕ} (m : ℕ)
+  theorem trivial_homotopy_add_of_is_set_loopn {n : ℕ} (m : ℕ) {A : Type*}
     (H : is_set (Ω[n] A)) : πg[m+n+1] A ≃g G0 :=
   !homotopy_group_add ⬝g !trivial_homotopy_of_is_set
 
-  theorem trivial_homotopy_le_of_is_set_loopn {A : Type*} {n : ℕ} (m : ℕ) (H1 : n ≤ m)
+  theorem trivial_homotopy_le_of_is_set_loopn {n : ℕ} (m : ℕ) (H1 : n ≤ m) {A : Type*}
     (H2 : is_set (Ω[n] A)) : πg[m+1] A ≃g G0 :=
   obtain (k : ℕ) (p : n + k = m), from le.elim H1,
   isomorphism_of_eq (ap (λx, πg[x+1] A) (p⁻¹ ⬝ add.comm n k)) ⬝g
@@ -239,12 +242,12 @@ namespace eq
   inv_preserve_binary (homotopy_group_pequiv_loop_ptrunc (succ k) A) mul concat
     (@homotopy_group_pequiv_loop_ptrunc_con k A) p q
 
-  definition ghomotopy_group_ptrunc [constructor] (k : ℕ) (A : Type*) :
-    πg[k+1] (ptrunc (k+1) A) ≃g πg[k+1] A :=
+  definition ghomotopy_group_ptrunc_of_le [constructor] {k n : ℕ} (H : k ≤ n) [Hk : is_succ k] (A : Type*) :
+    πg[k] (ptrunc n A) ≃g πg[k] A :=
   begin
     fapply isomorphism_of_equiv,
-    { exact homotopy_group_ptrunc (k+1) A},
-    { intro g₁ g₂,
+    { exact homotopy_group_ptrunc_of_le H A},
+    { intro g₁ g₂, induction Hk with k,
       refine _ ⬝ !homotopy_group_pequiv_loop_ptrunc_inv_con,
       apply ap ((homotopy_group_pequiv_loop_ptrunc (k+1) A)⁻¹ᵉ*),
       refine _ ⬝ !loopn_pequiv_loopn_con ,
@@ -252,9 +255,42 @@ namespace eq
       apply homotopy_group_pequiv_loop_ptrunc_con}
   end
 
+  lemma ghomotopy_group_isomorphism_of_ptrunc_pequiv {A B : Type*}
+    (n k : ℕ) (H : n+1 ≤[ℕ] k) (f : ptrunc k A ≃* ptrunc k B) : πg[n+1] A ≃g πg[n+1] B :=
+  (ghomotopy_group_ptrunc_of_le H A)⁻¹ᵍ ⬝g
+  homotopy_group_isomorphism_of_pequiv n f ⬝g
+  ghomotopy_group_ptrunc_of_le H B
+
+  definition fundamental_group_isomorphism {X : Type*} {G : Group}
+    (e : Ω X ≃ G) (hom_e : Πp q, e (p ⬝ q) = e p * e q) : π₁ X ≃g G :=
+  isomorphism_of_equiv (trunc_equiv_trunc 0 e ⬝e (trunc_equiv 0 G))
+    begin intro p q, induction p with p, induction q with q, exact hom_e p q end
+
+  definition ghomotopy_group_ptrunc [constructor] (k : ℕ) [is_succ k] (A : Type*) :
+    πg[k] (ptrunc k A) ≃g πg[k] A :=
+  ghomotopy_group_ptrunc_of_le (le.refl k) A
+
+  section psquare
+  variables {A₀₀ A₂₀ A₀₂ A₂₂ : Type*}
+            {f₁₀ : A₀₀ →* A₂₀} {f₁₂ : A₀₂ →* A₂₂}
+            {f₀₁ : A₀₀ →* A₀₂} {f₂₁ : A₂₀ →* A₂₂}
+
+  definition homotopy_group_functor_psquare (n : ℕ) (p : psquare f₁₀ f₁₂ f₀₁ f₂₁) :
+        psquare (π→[n] f₁₀) (π→[n] f₁₂) (π→[n] f₀₁) (π→[n] f₂₁) :=
+  !homotopy_group_functor_pcompose⁻¹* ⬝* homotopy_group_functor_phomotopy n p ⬝*
+  !homotopy_group_functor_pcompose
+
+  definition homotopy_group_homomorphism_psquare (n : ℕ) [H : is_succ n]
+    (p : psquare f₁₀ f₁₂ f₀₁ f₂₁) : hsquare (π→g[n] f₁₀) (π→g[n] f₁₂) (π→g[n] f₀₁) (π→g[n] f₂₁) :=
+  begin
+    induction H with n, exact to_homotopy (ptrunc_functor_psquare 0 (apn_psquare (succ n) p))
+  end
+
+  end psquare
+
   /- some homomorphisms -/
 
-  -- definition is_homomorphism_cast_loopn_succ_eq_in {A : Type*} (n : ℕ) :
+  -- definition is_homomorphism_cast_loopn_succ_eq_in (n : ℕ) {A : Type*} :
   --   is_homomorphism (loopn_succ_in A (succ n) : πg[n+1+1] A → πg[n+1] (Ω A)) :=
   -- begin
   --   intro g h, induction g with g, induction h with h,
@@ -262,7 +298,7 @@ namespace eq
   --             loopn_succ_eq_in_concat, - + tr_compose],
   -- end
 
-  definition is_mul_hom_inverse (A : Type*) (n : ℕ)
+  definition is_mul_hom_inverse (n : ℕ) (A : Type*)
     : is_mul_hom (λp, p⁻¹ : (πag[n+2] A) → (πag[n+2] A)) :=
   begin
     intro g h, exact ap inv (mul.comm g h) ⬝ mul_inv h g,

hott/algebra/inf_group.hlean

@@ -1,8 +1,7 @@
 /-
 Copyright (c) 2014 Jeremy Avigad. All rights reserved.
 Released under Apache 2.0 license as described in the file LICENSE.
-Authors: Jeremy Avigad, Leonardo de Moura
-
+Authors: Jeremy Avigad, Leonardo de Moura, Floris van Doorn
 -/
 
 import algebra.binary algebra.priority
@@ -141,17 +140,6 @@ definition add_comm_inf_semigroup_of_add_comm_inf_monoid [reducible] [trans_inst
   [H : add_comm_inf_monoid A] : add_comm_inf_semigroup A :=
 @comm_inf_monoid.to_comm_inf_semigroup A H
 
-section add_comm_inf_monoid
-  variables [s : add_comm_inf_monoid A]
-  include s
-
-  theorem add_comm_three  (a b c : A) : a + b + c = c + b + a :=
-    by rewrite [{a + _}add.comm, {_ + c}add.comm, -*add.assoc]
-
-  theorem add.comm4 : Π (n m k l : A), n + m + (k + l) = n + k + (m + l) :=
-  comm4 add.comm add.assoc
-end add_comm_inf_monoid
-
 /- group -/
 
 structure inf_group [class] (A : Type) extends inf_monoid A, has_inv A :=
@@ -331,10 +319,16 @@ section inf_group
   ⦃ right_cancel_inf_semigroup, s,
     mul_right_cancel := @mul_right_cancel A s ⦄
 
+  definition one_unique {a : A} (H : Πb, a * b = b) : a = 1 :=
+  !mul_one⁻¹ ⬝ H 1
+
 end inf_group
 
 structure ab_inf_group [class] (A : Type) extends inf_group A, comm_inf_monoid A
 
+theorem mul.comm4 [s : ab_inf_group A] (a b c d : A) : (a * b) * (c * d) = (a * c) * (b * d) :=
+binary.comm4 mul.comm mul.assoc a b c d
+
 /- additive inf_group -/
 
 definition add_inf_group [class] : Type → Type := inf_group
@@ -533,6 +527,9 @@ section add_inf_group
   theorem add_eq_of_eq_sub {a b c : A} (H : a = c - b) : a + b = c :=
   add_eq_of_eq_add_neg H
 
+  definition zero_unique {a : A} (H : Πb, a + b = b) : a = 0 :=
+  !add_zero⁻¹ ⬝ H 0
+
 end add_inf_group
 
 definition add_ab_inf_group [class] : Type → Type := ab_inf_group
@@ -587,6 +584,10 @@ section add_ab_inf_group
 
   theorem neg_neg_sub_neg (a b : A) : - (-a - -b) = a - b :=
     by rewrite [neg_sub, sub_neg_eq_add, neg_add_eq_sub]
+
+  definition add_sub_cancel_middle (a b : A) : a + (b - a) = b :=
+  !add.comm ⬝ !sub_add_cancel
+
 end add_ab_inf_group
 
 definition inf_group_of_add_inf_group (A : Type) [G : add_inf_group A] : inf_group A :=
@@ -599,12 +600,18 @@ definition inf_group_of_add_inf_group (A : Type) [G : add_inf_group A] : inf_gro
   inv             := has_neg.neg,
   mul_left_inv    := add.left_inv ⦄
 
-namespace norm_num
+theorem add.comm4 [s : add_comm_inf_semigroup A] :
+  Π (n m k l : A), n + m + (k + l) = n + k + (m + l) :=
+comm4 add.comm add.assoc
 
 definition add1 [s : has_add A] [s' : has_one A] (a : A) : A := add a one
 
-theorem add_comm_four [s : add_comm_inf_semigroup A] (a b : A) : a + a + (b + b) = (a + b) + (a + b) :=
-  by rewrite [-add.assoc at {1}, add.comm, {a + b}add.comm at {1}, *add.assoc]
+theorem add_comm_three [s : add_comm_inf_semigroup A] (a b c : A) : a + b + c = c + b + a :=
+  by rewrite [{a + _}add.comm, {_ + c}add.comm, -*add.assoc]
+
+theorem add_comm_four [s : add_comm_inf_semigroup A] (a b : A) :
+  a + a + (b + b) = (a + b) + (a + b) :=
+!add.comm4
 
 theorem add_comm_middle [s : add_comm_inf_semigroup A] (a b c : A) : a + b + c = a + c + b :=
   by rewrite [add.assoc, add.comm b, -add.assoc]
@@ -703,20 +710,5 @@ theorem subst_into_sum [s : has_add A] (l r tl tr t : A) (prl : l = tl) (prr : r
 theorem neg_zero_helper [s : add_inf_group A] (a : A) (H : a = 0) : - a = 0 :=
   by rewrite [H, neg_zero]
 
-end norm_num
 
 end algebra
-open algebra
-
-attribute [simp]
-  zero_add add_zero one_mul mul_one
-  at simplifier.unit
-
-attribute [simp]
-  neg_neg sub_eq_add_neg
-  at simplifier.neg
-
-attribute [simp]
-  add.assoc add.comm add.left_comm
-  mul.left_comm mul.comm mul.assoc
-  at simplifier.ac

hott/algebra/inf_group_theory.hlean

@@ -0,0 +1,398 @@
+/-
+Copyright (c) 2018 Floris van Doorn. All rights reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+Authors: Floris van Doorn
+-/
+
+import .bundled .homomorphism types.nat.hott
+
+open algebra eq is_equiv equiv pointed function is_trunc nat
+
+universe variable u
+
+namespace group
+
+  /- left and right actions -/
+  definition is_equiv_mul_right_inf [constructor] {A : InfGroup} (a : A) : is_equiv (λb, b * a) :=
+  adjointify _ (λb : A, b * a⁻¹) (λb, !inv_mul_cancel_right) (λb, !mul_inv_cancel_right)
+
+  definition right_action_inf [constructor] {A : InfGroup} (a : A) : A ≃ A :=
+  equiv.mk _ (is_equiv_mul_right_inf a)
+
+  /- homomorphisms -/
+
+  structure inf_homomorphism (G₁ G₂ : InfGroup) : Type :=
+    (φ : G₁ → G₂)
+    (p : is_mul_hom φ)
+
+  infix ` →∞g `:55 := inf_homomorphism
+
+  abbreviation inf_group_fun [unfold 3] [coercion] [reducible] := @inf_homomorphism.φ
+  definition inf_homomorphism.struct [unfold 3] [instance] [priority 900] {G₁ G₂ : InfGroup}
+    (φ : G₁ →∞g G₂) : is_mul_hom φ :=
+  inf_homomorphism.p φ
+
+  variables {G G₁ G₂ G₃ : InfGroup} {g h : G₁} {ψ : G₂ →∞g G₃} {φ₁ φ₂ : G₁ →∞g G₂} (φ : G₁ →∞g G₂)
+
+  definition to_respect_mul_inf /- φ -/ (g h : G₁) : φ (g * h) = φ g * φ h :=
+  respect_mul φ g h
+
+  theorem to_respect_one_inf /- φ -/ : φ 1 = 1 :=
+  have φ 1 * φ 1 = φ 1 * 1, by rewrite [-to_respect_mul_inf φ, +mul_one],
+  eq_of_mul_eq_mul_left' this
+
+  theorem to_respect_inv_inf /- φ -/ (g : G₁) : φ g⁻¹ = (φ g)⁻¹ :=
+  have φ (g⁻¹) * φ g = 1, by rewrite [-to_respect_mul_inf φ, mul.left_inv, to_respect_one_inf φ],
+  eq_inv_of_mul_eq_one this
+
+  definition pmap_of_inf_homomorphism [constructor] /- φ -/ : G₁ →* G₂ :=
+  pmap.mk φ begin exact to_respect_one_inf φ end
+
+  definition inf_homomorphism_change_fun [constructor] {G₁ G₂ : InfGroup}
+    (φ : G₁ →∞g G₂) (f : G₁ → G₂) (p : φ ~ f) : G₁ →∞g G₂ :=
+  inf_homomorphism.mk f
+    (λg h, (p (g * h))⁻¹ ⬝ to_respect_mul_inf φ g h ⬝ ap011 mul (p g) (p h))
+
+  /- categorical structure of groups + homomorphisms -/
+
+  definition inf_homomorphism_compose [constructor] [trans] [reducible]
+    (ψ : G₂ →∞g G₃) (φ : G₁ →∞g G₂) : G₁ →∞g G₃ :=
+  inf_homomorphism.mk (ψ ∘ φ) (is_mul_hom_compose _ _)
+
+  variable (G)
+  definition inf_homomorphism_id [constructor] [refl] : G →∞g G :=
+  inf_homomorphism.mk (@id G) (is_mul_hom_id G)
+  variable {G}
+
+  abbreviation inf_gid [constructor] := @inf_homomorphism_id
+  infixr ` ∘∞g `:75 := inf_homomorphism_compose
+
+  structure inf_isomorphism (A B : InfGroup) :=
+    (to_hom : A →∞g B)
+    (is_equiv_to_hom : is_equiv to_hom)
+
+  infix ` ≃∞g `:25 := inf_isomorphism
+  attribute inf_isomorphism.to_hom [coercion]
+  attribute inf_isomorphism.is_equiv_to_hom [instance]
+  attribute inf_isomorphism._trans_of_to_hom [unfold 3]
+
+  definition equiv_of_inf_isomorphism [constructor] (φ : G₁ ≃∞g G₂) : G₁ ≃ G₂ :=
+  equiv.mk φ _
+
+  definition pequiv_of_inf_isomorphism [constructor] (φ : G₁ ≃∞g G₂) :
+    G₁ ≃* G₂ :=
+  pequiv.mk φ begin esimp, exact _ end begin esimp, exact to_respect_one_inf φ end
+
+  definition inf_isomorphism_of_equiv [constructor] (φ : G₁ ≃ G₂)
+    (p : Πg₁ g₂, φ (g₁ * g₂) = φ g₁ * φ g₂) : G₁ ≃∞g G₂ :=
+  inf_isomorphism.mk (inf_homomorphism.mk φ p) !to_is_equiv
+
+  definition inf_isomorphism_of_eq [constructor] {G₁ G₂ : InfGroup} (φ : G₁ = G₂) : G₁ ≃∞g G₂ :=
+  inf_isomorphism_of_equiv (equiv_of_eq (ap InfGroup.carrier φ))
+    begin intros, induction φ, reflexivity end
+
+  definition to_ginv_inf [constructor] (φ : G₁ ≃∞g G₂) : G₂ →∞g G₁ :=
+  inf_homomorphism.mk φ⁻¹
+    abstract begin
+    intro g₁ g₂, apply inj' φ,
+    rewrite [respect_mul φ, +right_inv φ]
+    end end
+
+  variable (G)
+  definition inf_isomorphism.refl [refl] [constructor] : G ≃∞g G :=
+  inf_isomorphism.mk !inf_gid !is_equiv_id
+  variable {G}
+
+  definition inf_isomorphism.symm [symm] [constructor] (φ : G₁ ≃∞g G₂) : G₂ ≃∞g G₁ :=
+  inf_isomorphism.mk (to_ginv_inf φ) !is_equiv_inv
+
+  definition inf_isomorphism.trans [trans] [constructor] (φ : G₁ ≃∞g G₂) (ψ : G₂ ≃∞g G₃) :
+    G₁ ≃∞g G₃ :=
+  inf_isomorphism.mk (ψ ∘∞g φ) (is_equiv_compose ψ φ _ _)
+
+  definition inf_isomorphism.eq_trans [trans] [constructor]
+     {G₁ G₂ : InfGroup} {G₃ : InfGroup} (φ : G₁ = G₂) (ψ : G₂ ≃∞g G₃) : G₁ ≃∞g G₃ :=
+  proof inf_isomorphism.trans (inf_isomorphism_of_eq φ) ψ qed
+
+  definition inf_isomorphism.trans_eq [trans] [constructor]
+    {G₁ : InfGroup} {G₂ G₃ : InfGroup} (φ : G₁ ≃∞g G₂) (ψ : G₂ = G₃) : G₁ ≃∞g G₃ :=
+  inf_isomorphism.trans φ (inf_isomorphism_of_eq ψ)
+
+  postfix `⁻¹ᵍ⁸`:(max + 1) := inf_isomorphism.symm
+  infixl ` ⬝∞g `:75 := inf_isomorphism.trans
+  infixl ` ⬝∞gp `:75 := inf_isomorphism.trans_eq
+  infixl ` ⬝∞pg `:75 := inf_isomorphism.eq_trans
+
+  definition pmap_of_inf_isomorphism [constructor] (φ : G₁ ≃∞g G₂) : G₁ →* G₂ :=
+  pequiv_of_inf_isomorphism φ
+
+  definition to_fun_inf_isomorphism_trans {G H K : InfGroup} (φ : G ≃∞g H) (ψ : H ≃∞g K) :
+    φ ⬝∞g ψ ~ ψ ∘ φ :=
+  by reflexivity
+
+  definition inf_homomorphism_mul [constructor] {G H : AbInfGroup} (φ ψ : G →∞g H) : G →∞g H :=
+  inf_homomorphism.mk (λg, φ g * ψ g)
+    abstract begin
+      intro g g', refine ap011 mul !to_respect_mul_inf !to_respect_mul_inf ⬝ _,
+      refine !mul.assoc ⬝ ap (mul _) (!mul.assoc⁻¹ ⬝ ap (λx, x * _) !mul.comm ⬝ !mul.assoc) ⬝
+             !mul.assoc⁻¹
+    end end
+
+  definition trivial_inf_homomorphism (A B : InfGroup) : A →∞g B :=
+  inf_homomorphism.mk (λa, 1) (λa a', (mul_one 1)⁻¹)
+
+  /- given an equivalence A ≃ B we can transport a group structure on A to a group structure on B -/
+
+  section
+
+    parameters {A B : Type} (f : A ≃ B) (H : inf_group A)
+    include H
+
+    definition inf_group_equiv_mul (b b' : B) : B := f (f⁻¹ᶠ b * f⁻¹ᶠ b')
+
+    definition inf_group_equiv_one : B := f one
+
+    definition inf_group_equiv_inv (b : B) : B := f (f⁻¹ᶠ b)⁻¹
+
+    local infix * := inf_group_equiv_mul
+    local postfix ^ := inf_group_equiv_inv
+    local notation 1 := inf_group_equiv_one
+
+    theorem inf_group_equiv_mul_assoc (b₁ b₂ b₃ : B) : (b₁ * b₂) * b₃ = b₁ * (b₂ * b₃) :=
+    by rewrite [↑inf_group_equiv_mul, +left_inv f, mul.assoc]
+
+    theorem inf_group_equiv_one_mul (b : B) : 1 * b = b :=
+    by rewrite [↑inf_group_equiv_mul, ↑inf_group_equiv_one, left_inv f, one_mul, right_inv f]
+
+    theorem inf_group_equiv_mul_one (b : B) : b * 1 = b :=
+    by rewrite [↑inf_group_equiv_mul, ↑inf_group_equiv_one, left_inv f, mul_one, right_inv f]
+
+    theorem inf_group_equiv_mul_left_inv (b : B) : b^ * b = 1 :=
+    by rewrite [↑inf_group_equiv_mul, ↑inf_group_equiv_one, ↑inf_group_equiv_inv,
+                +left_inv f, mul.left_inv]
+
+    definition inf_group_equiv_closed [constructor] : inf_group B :=
+    ⦃inf_group,
+      mul          := inf_group_equiv_mul,
+      mul_assoc    := inf_group_equiv_mul_assoc,
+      one          := inf_group_equiv_one,
+      one_mul      := inf_group_equiv_one_mul,
+      mul_one      := inf_group_equiv_mul_one,
+      inv          := inf_group_equiv_inv,
+      mul_left_inv := inf_group_equiv_mul_left_inv⦄
+
+  end
+
+  definition InfGroup_equiv_closed [constructor] (A : InfGroup) {B : Type} (f : A ≃ B) : InfGroup :=
+  InfGroup.mk B (inf_group_equiv_closed f _)
+
+  definition InfGroup_equiv_closed_isomorphism [constructor] (A : InfGroup) {B : Type} (f : A ≃ B) :
+    A ≃∞g InfGroup_equiv_closed A f :=
+  inf_isomorphism_of_equiv f (λa a', ap f (ap011 mul (to_left_inv f a) (to_left_inv f a'))⁻¹)
+
+  section
+    variables {A B : Type} (f : A ≃ B) (H : ab_inf_group A)
+    include H
+    definition inf_group_equiv_mul_comm (b b' : B) :
+      inf_group_equiv_mul f _ b b' = inf_group_equiv_mul f _ b' b :=
+    by rewrite [↑inf_group_equiv_mul, mul.comm]
+
+    definition ab_inf_group_equiv_closed : ab_inf_group B :=
+    ⦃ ab_inf_group, inf_group_equiv_closed f _, mul_comm := inf_group_equiv_mul_comm f H ⦄
+  end
+
+  variable (G)
+
+  /- the trivial ∞-group -/
+  open unit
+  definition inf_group_unit [constructor] : inf_group unit :=
+  inf_group.mk (λx y, star) (λx y z, idp) star (unit.rec idp) (unit.rec idp) (λx, star) (λx, idp)
+
+  definition ab_inf_group_unit [constructor] : ab_inf_group unit :=
+  ⦃ab_inf_group, inf_group_unit, mul_comm := λx y, idp⦄
+
+  definition trivial_inf_group [constructor] : InfGroup :=
+  InfGroup.mk _ inf_group_unit
+
+  definition AbInfGroup_of_InfGroup (G : InfGroup.{u}) (H : Π x y : G, x * y = y * x) :
+    AbInfGroup.{u} :=
+  begin
+    induction G,
+    fapply AbInfGroup.mk,
+    assumption,
+    exact ⦃ab_inf_group, struct', mul_comm := H⦄
+  end
+
+  definition trivial_ab_inf_group : AbInfGroup.{0} :=
+  begin
+    fapply AbInfGroup_of_InfGroup trivial_inf_group, intro x y, reflexivity
+  end
+
+  definition trivial_inf_group_of_is_contr [H : is_contr G] : G ≃∞g trivial_inf_group :=
+  begin
+    fapply inf_isomorphism_of_equiv,
+    { exact equiv_unit_of_is_contr _ _ },
+    { intros, reflexivity}
+  end
+
+  definition ab_inf_group_of_is_contr (A : Type) (H : is_contr A) : ab_inf_group A :=
+  have ab_inf_group unit, from ab_inf_group_unit,
+  ab_inf_group_equiv_closed (equiv_unit_of_is_contr A _)⁻¹ᵉ _
+
+  definition inf_group_of_is_contr (A : Type) (H : is_contr A) : inf_group A :=
+  have ab_inf_group A, from ab_inf_group_of_is_contr A H, by exact _
+
+  definition ab_inf_group_lift_unit : ab_inf_group (lift unit) :=
+  ab_inf_group_of_is_contr (lift unit) _
+
+  definition trivial_ab_inf_group_lift : AbInfGroup :=
+  AbInfGroup.mk _ ab_inf_group_lift_unit
+
+  definition from_trivial_ab_inf_group (A : AbInfGroup) : trivial_ab_inf_group →∞g A :=
+  trivial_inf_homomorphism trivial_ab_inf_group A
+
+  definition to_trivial_ab_inf_group (A : AbInfGroup) : A →∞g trivial_ab_inf_group :=
+  trivial_inf_homomorphism A trivial_ab_inf_group
+
+  /- infinity pgroups are infgroups where 1 is definitionally the point of X -/
+
+  structure inf_pgroup [class] (X : Type*) extends inf_semigroup X, has_inv X :=
+    (pt_mul : Πa, mul pt a = a)
+    (mul_pt : Πa, mul a pt = a)
+    (mul_left_inv_pt : Πa, mul (inv a) a = pt)
+
+  definition pt_mul (X : Type*) [inf_pgroup X] (x : X) : pt * x = x := inf_pgroup.pt_mul x
+  definition mul_pt (X : Type*) [inf_pgroup X] (x : X) : x * pt = x := inf_pgroup.mul_pt x
+  definition mul_left_inv_pt (X : Type*) [inf_pgroup X] (x : X) : x⁻¹ * x = pt :=
+  inf_pgroup.mul_left_inv_pt x
+
+  definition inf_group_of_inf_pgroup [reducible] [instance] (X : Type*) [H : inf_pgroup X]
+    : inf_group X :=
+  ⦃inf_group, H,
+          one := pt,
+          one_mul := inf_pgroup.pt_mul ,
+          mul_one := inf_pgroup.mul_pt,
+          mul_left_inv := inf_pgroup.mul_left_inv_pt⦄
+
+  definition inf_pgroup_of_inf_group (X : Type*) [H : inf_group X] (p : one = pt :> X) :
+    inf_pgroup X :=
+  begin
+    cases X with X x, esimp at *, induction p,
+    exact ⦃inf_pgroup, H,
+            pt_mul := one_mul,
+            mul_pt := mul_one,
+            mul_left_inv_pt := mul.left_inv⦄
+  end
+
+  definition inf_Group_of_inf_pgroup (G : Type*) [inf_pgroup G] : InfGroup :=
+  InfGroup.mk G _
+
+  definition inf_pgroup_InfGroup [instance] (G : InfGroup) : inf_pgroup G :=
+  ⦃ inf_pgroup, InfGroup.struct G,
+    pt_mul := one_mul,
+    mul_pt := mul_one,
+    mul_left_inv_pt := mul.left_inv ⦄
+
+  section
+
+    parameters {A B : Type*} (f : A ≃* B) (s : inf_pgroup A)
+    include s
+
+    definition inf_pgroup_pequiv_mul (b b' : B) : B := f (f⁻¹ᶠ b * f⁻¹ᶠ b')
+
+    definition inf_pgroup_pequiv_inv (b : B) : B := f (f⁻¹ᶠ b)⁻¹
+
+    local infix * := inf_pgroup_pequiv_mul
+    local postfix ^ := inf_pgroup_pequiv_inv
+
+    theorem inf_pgroup_pequiv_mul_assoc (b₁ b₂ b₃ : B) : (b₁ * b₂) * b₃ = b₁ * (b₂ * b₃) :=
+    begin
+      refine ap (λa, f (mul a _)) (left_inv f _) ⬝ _ ⬝ ap (λa, f (mul _ a)) (left_inv f _)⁻¹,
+      exact ap f !mul.assoc
+    end
+
+    theorem inf_pgroup_pequiv_pt_mul (b : B) : pt * b = b :=
+    by rewrite [↑inf_pgroup_pequiv_mul, respect_pt, pt_mul]; apply right_inv f
+
+    theorem inf_pgroup_pequiv_mul_pt (b : B) : b * pt = b :=
+    by rewrite [↑inf_pgroup_pequiv_mul, respect_pt, mul_pt]; apply right_inv f
+
+    theorem inf_pgroup_pequiv_mul_left_inv_pt (b : B) : b^ * b = pt :=
+    begin
+      refine ap (λa, f (mul a _)) (left_inv f _) ⬝ _,
+      exact ap f !mul_left_inv_pt ⬝ !respect_pt,
+    end
+
+    definition inf_pgroup_pequiv_closed : inf_pgroup B :=
+    ⦃inf_pgroup,
+      mul          := inf_pgroup_pequiv_mul,
+      mul_assoc    := inf_pgroup_pequiv_mul_assoc,
+      pt_mul       := inf_pgroup_pequiv_pt_mul,
+      mul_pt       := inf_pgroup_pequiv_mul_pt,
+      inv          := inf_pgroup_pequiv_inv,
+      mul_left_inv_pt := inf_pgroup_pequiv_mul_left_inv_pt⦄
+
+  end
+
+  /- infgroup from loop spaces -/
+
+  definition inf_pgroup_loop [constructor] [instance] (A : Type*) : inf_pgroup (Ω A) :=
+  inf_pgroup.mk concat con.assoc inverse idp_con con_idp con.left_inv
+
+  definition inf_group_loop [constructor] (A : Type*) : inf_group (Ω A) := _
+
+  definition ab_inf_group_loop [constructor] [instance] (A : Type*) : ab_inf_group (Ω (Ω A)) :=
+  ⦃ab_inf_group, inf_group_loop _, mul_comm := eckmann_hilton⦄
+
+  definition inf_group_loopn (n : ℕ) (A : Type*) [H : is_succ n] : inf_group (Ω[n] A) :=
+  by induction H; exact _
+
+  definition ab_inf_group_loopn (n : ℕ) (A : Type*) [H : is_at_least_two n] :
+    ab_inf_group (Ω[n] A) :=
+  by induction H; exact _
+
+  definition gloop [constructor] (A : Type*) : InfGroup :=
+  InfGroup.mk (Ω A) (inf_group_loop A)
+
+  definition gloopn (n : ℕ) [H : is_succ n] (A : Type*) : InfGroup :=
+  InfGroup.mk (Ω[n] A) (inf_group_loopn n A)
+
+  definition agloopn (n : ℕ) [H : is_at_least_two n] (A : Type*) : AbInfGroup :=
+  AbInfGroup.mk (Ω[n] A) (ab_inf_group_loopn n A)
+
+  definition gloopn' (n : ℕ) (A : InfGroup) : InfGroup :=
+  InfGroup.mk (Ω[n] A) (by cases n; exact InfGroup.struct A; apply inf_group_loopn)
+
+  notation `Ωg` := gloop
+  notation `Ωg[`:95 n:0 `]`:0 := gloopn n
+  notation `Ωag[`:95 n:0 `]`:0 := agloopn n
+  notation `Ωg'[`:95 n:0 `]`:0 := gloopn' n
+
+  definition gap1 {A B : Type*} (f : A →* B) : Ωg A →∞g Ωg B :=
+  inf_homomorphism.mk (Ω→ f) (ap1_con f)
+
+  definition gapn (n : ℕ) [H : is_succ n] {A B : Type*} (f : A →* B) : Ωg[n] A →∞g Ωg[n] B :=
+  inf_homomorphism.mk (Ω→[n] f) (by induction H with n; exact apn_con n f)
+
+  definition gapn' (n : ℕ) {A B : InfGroup} (f : A →∞g B) : Ωg'[n] A →∞g Ωg'[n] B :=
+  inf_homomorphism.mk (Ω→[n] (pmap_of_inf_homomorphism f))
+    (by cases n with n; exact inf_homomorphism.struct f; exact apn_con n (pmap_of_inf_homomorphism f))
+
+  notation `Ωg→` := gap1
+  notation `Ωg→[`:95 n:0 `]`:0 := gapn n
+  notation `Ωg'→[`:95 n:0 `]`:0 := gapn' n
+
+  definition gloop_isomorphism_gloop {A B : Type*} (f : A ≃* B) : Ωg A ≃∞g Ωg B :=
+  inf_isomorphism.mk (Ωg→ f) (to_is_equiv (loop_pequiv_loop f))
+
+  definition gloopn_isomorphism_gloopn (n : ℕ) [H : is_succ n] {A B : Type*} (f : A ≃* B) :
+    Ωg[n] A ≃∞g Ωg[n] B :=
+  inf_isomorphism.mk (Ωg→[n] f) (to_is_equiv (loopn_pequiv_loopn n f))
+
+  notation `Ωg≃` := gloop_isomorphism_gloop
+  notation `Ωg≃[`:95 n:0 `]`:0 := gloopn_isomorphism_gloopn
+
+  definition gloopn_succ_in (n : ℕ) [H : is_succ n] (A : Type*) : Ωg[succ n] A ≃∞g Ωg[n] (Ω A) :=
+  inf_isomorphism_of_equiv (loopn_succ_in n A) (by induction H with n; exact loopn_succ_in_con)
+
+end group

hott/algebra/order.hlean

@@ -5,7 +5,7 @@ Author: Jeremy Avigad
 
 Weak orders "≤", strict orders "<", and structures that include both.
 -/
-import algebra.binary algebra.priority
+import algebra.binary
 open eq eq.ops algebra
 -- set_option class.force_new true
 

hott/algebra/ordered_group.hlean

@@ -6,7 +6,7 @@ Authors: Jeremy Avigad
 Partially ordered additive groups, modeled on Isabelle's library. These classes can be refined
 if necessary.
 -/
-import algebra.binary algebra.group algebra.order
+import algebra.group algebra.order
 open eq eq.ops algebra   -- note: ⁻¹ will be overloaded
 set_option class.force_new true
 

hott/algebra/ring.hlean

@@ -1,13 +1,13 @@
 /-
 Copyright (c) 2014 Jeremy Avigad. All rights reserved.
 Released under Apache 2.0 license as described in the file LICENSE.
-Authors: Jeremy Avigad, Leonardo de Moura
+Authors: Jeremy Avigad, Leonardo de Moura, Floris van Doorn
 
 Structures with multiplicative and additive components, including semirings, rings, and fields.
 The development is modeled after Isabelle's library.
 -/
 
-import algebra.binary algebra.group
+import algebra.group
 open eq eq.ops algebra
 set_option class.force_new true
 

hott/algebra/trunc_group.hlean

@@ -64,7 +64,7 @@ namespace algebra
   end
 
   parameter (A)
-  definition trunc_inf_group [constructor] [instance] : inf_group (trunc n A) :=
+  definition inf_group_trunc [constructor] [instance] : inf_group (trunc n A) :=
   ⦃inf_group,
     mul          := algebra.trunc_mul          n,
     mul_assoc    := algebra.trunc_mul_assoc    n,
@@ -74,11 +74,17 @@ namespace algebra
     inv          := algebra.trunc_inv          n,
     mul_left_inv := algebra.trunc_mul_left_inv n⦄
 
-  definition trunc_group [constructor] : group (trunc 0 A) :=
+  definition group_trunc [constructor] : group (trunc 0 A) :=
   group_of_inf_group _
 
   end
 
+  definition igtrunc [constructor] (n : ℕ₋₂) (A : InfGroup) : InfGroup :=
+  InfGroup.mk (trunc n A) (inf_group_trunc n A)
+
+  definition gtrunc [constructor] (A : InfGroup) : Group :=
+  Group.mk (trunc 0 A) (group_trunc A)
+
   section
   variables (n : trunc_index) {A : Type} [ab_inf_group A]
 
@@ -90,12 +96,18 @@ namespace algebra
   end
 
   variable (A)
-  definition trunc_ab_inf_group [constructor] [instance] : ab_inf_group (trunc n A) :=
-  ⦃ab_inf_group, trunc_inf_group n A, mul_comm := algebra.trunc_mul_comm n⦄
+  definition ab_inf_group_trunc [constructor] [instance] : ab_inf_group (trunc n A) :=
+  ⦃ab_inf_group, inf_group_trunc n A, mul_comm := algebra.trunc_mul_comm n⦄
 
-  definition trunc_ab_group [constructor] : ab_group (trunc 0 A) :=
+  definition ab_group_trunc [constructor] : ab_group (trunc 0 A) :=
   ab_group_of_ab_inf_group _
 
+  definition aigtrunc [constructor] (n : ℕ₋₂) (A : AbInfGroup) : AbInfGroup :=
+  AbInfGroup.mk (trunc n A) (ab_inf_group_trunc n A)
+
+  definition agtrunc [constructor] (A : AbInfGroup) : AbGroup :=
+  AbGroup.mk (trunc 0 A) (ab_group_trunc A)
+
   end
 
 end algebra

hott/arity.hlean

@@ -51,6 +51,22 @@ namespace eq
   infix ` ~2 `:50 := homotopy2
   infix ` ~3 `:50 := homotopy3
 
+  definition homotopy2.refl {A} {B : A → Type} {C : Π⦃a⦄, B a → Type} (f : Πa (b : B a), C b) :
+    f ~2 f :=
+  λa b, idp
+
+  definition homotopy2.rfl [refl] {A} {B : A → Type} {C : Π⦃a⦄, B a → Type}
+    {f : Πa (b : B a), C b} : f ~2 f :=
+  λa b, idp
+
+  definition homotopy3.refl {A} {B : A → Type} {C : Πa, B a → Type}
+    {D : Π⦃a⦄ ⦃b : B a⦄, C a b → Type} (f : Πa b (c : C a b), D c) : f ~3 f :=
+  λa b c, idp
+
+  definition homotopy3.rfl {A} {B : A → Type} {C : Πa, B a → Type}
+    {D : Π⦃a⦄ ⦃b : B a⦄, C a b → Type} {f : Πa b (c : C a b), D c} : f ~3 f :=
+  λa b c, idp
+
   definition ap0111 (f : U → V → W → X) (Hu : u = u') (Hv : v = v') (Hw : w = w')
       : f u v w = f u' v' w' :=
   by cases Hu; congruence; repeat assumption
@@ -70,13 +86,13 @@ namespace eq
       : f u v w x y z = f u' v' w' x' y' z' :=
   by cases Hu; congruence; repeat assumption
 
-  definition ap010 (f : X → Πa, B a) (Hx : x = x') : f x ~ f x' :=
+  definition ap010 [unfold 7] (f : X → Πa, B a) (Hx : x = x') : f x ~ f x' :=
   by intros; cases Hx; reflexivity
 
-  definition ap0100 (f : X → Πa b, C a b) (Hx : x = x') : f x ~2 f x' :=
+  definition ap0100 [unfold 8] (f : X → Πa b, C a b) (Hx : x = x') : f x ~2 f x' :=
   by intros; cases Hx; reflexivity
 
-  definition ap01000 (f : X → Πa b c, D a b c) (Hx : x = x') : f x ~3 f x' :=
+  definition ap01000 [unfold 9] (f : X → Πa b c, D a b c) (Hx : x = x') : f x ~3 f x' :=
   by intros; cases Hx; reflexivity
 
   definition apdt011 (f : Πa, B a → Z) (Ha : a = a') (Hb : transport B Ha b = b')
@@ -137,6 +153,18 @@ namespace eq
     ap010 f (ap g p) a = ap010 (λy, f (g y)) p a :=
   eq.rec_on p idp
 
+  definition ap_eq_ap010 {A B C : Type} (f : A → B → C) {a a' : A} (p : a = a') (b : B) :
+    ap (λa, f a b) p = ap010 f p b :=
+  by reflexivity
+
+  definition ap011_idp {A B C : Type} (f : A → B → C) {a a' : A} (p : a = a') (b : B) :
+    ap011 f p idp = ap010 f p b :=
+  by reflexivity
+
+  definition ap011_flip {A B C : Type} (f : A → B → C) {a a' : A} {b b' : B} (p : a = a') (q : b = b') :
+    ap011 f p q = ap011 (λb a, f a b) q p :=
+  by induction q; induction p; reflexivity
+
   /- the following theorems are function extentionality for functions with multiple arguments -/
 
   definition eq_of_homotopy2 {f g : Πa b, C a b} (H : f ~2 g) : f = g :=
@@ -177,6 +205,13 @@ namespace eq
     : eq_of_homotopy3 (λa b c, H1 a b c ⬝ H2 a b c) = eq_of_homotopy3 H1 ⬝ eq_of_homotopy3 H2 :=
   ap eq_of_homotopy (eq_of_homotopy (λa, !eq_of_homotopy2_con)) ⬝ !eq_of_homotopy_con
 
+  definition ap_apd0111 {A₁ A₂ A₃ : Type} {B : A₁ → Type} {C : Π⦃a⦄, B a → Type} {a a₂ : A₁}
+    {b : B a} {b₂ : B a₂} {c : C b} {c₂ : C b₂}
+    (g : A₂ → A₃) (f : Πa b, C b → A₂) (Ha : a = a₂) (Hb : b =[Ha] b₂)
+      (Hc : c =[apd011 C Ha Hb] c₂) :
+    ap g (apd0111 f Ha Hb Hc) = apd0111 (λa b c, (g (f a b c))) Ha Hb Hc :=
+  by induction Hb; induction Hc using idp_rec_on; reflexivity
+
 end eq
 
 open eq equiv is_equiv

hott/book.md

@@ -152,7 +152,7 @@ Every file is in the folder [homotopy](homotopy/homotopy.md)
 - 8.5 (The Hopf fibration): [hit.pushout](hit/pushout.hlean) (Lemma 8.5.3), [hopf](homotopy/hopf.hlean) (The Hopf construction, Lemmas 8.5.5 and 8.5.7), [susp](homotopy/susp.hlean) (Definition 8.5.6), [circle](homotopy/circle.hlean) (multiplication on the circle, Lemma 8.5.8), [join](homotopy/join.hlean) (join is associative, Lemma 8.5.9), [complex_hopf](homotopy/complex_hopf.hlean) (the H-space structure on the circle and the complex Hopf fibration, i.e. Theorem 8.5.1), [sphere2](homotopy/sphere2.hlean) (Corollary 8.5.2)
 - 8.6 (The Freudenthal suspension theorem): [connectedness](homotopy/connectedness.hlean) (Lemma 8.6.1), [wedge](homotopy/wedge.hlean) (Wedge connectivity, Lemma 8.6.2). Corollary 8.6.14 is proven directly in [freudenthal](homotopy/freudenthal.hlean), however, we don't prove Theorem 8.6.4. Stability of iterated suspensions is also in [freudenthal](homotopy/freudenthal.hlean). The homotopy groups of spheres in this section are computed in [sphere2](homotopy/sphere2.hlean).
 - 8.7 (The van Kampen theorem): [vankampen](homotopy/vankampen.hlean) (the pushout of Groupoids is formalized in [algebra.category.constructions.pushout](algebra/category/constructions/pushout.hlean), including the universal property of this pushout. Some preliminary definitions for this pushout are in [algebra.graph](algebra/graph.hlean))
-- 8.8 (Whitehead’s theorem and Whitehead’s principle): 8.8.1 and 8.8.2 at the bottom of [types.trunc](types/trunc.hlean), 8.8.3 in [homotopy_group](homotopy/homotopy_group.hlean). [Rest to be moved]
+- 8.8 (Whitehead’s theorem and Whitehead’s principle): 8.8.1 and 8.8.2 at the bottom of [types.trunc](types/trunc.hlean), 8.8.3-5 in [homotopy_group](homotopy/homotopy_group.hlean). Some properties of infinity-connected maps are also in [homotopy_group](homotopy/homotopy_group.hlean). Infinity-truncated types are not yet defined.
 - 8.9 (A general statement of the encode-decode method): [types.eq](types/eq.hlean).
 - 8.10 (Additional Results): Theorem 8.10.3 is formalized in [homotopy.EM](homotopy/EM.hlean).
 

hott/choice.hlean

@@ -25,6 +25,7 @@ namespace choice
   equiv_of_is_prop
     (λ H X A P HX HA HP HI, trunc_functor _ (to_fun !sigma_pi_equiv_pi_sigma) (H X A P HX HA HP HI))
     (λ H X A P HX HA HP HI, trunc_functor _ (to_inv !sigma_pi_equiv_pi_sigma) (H X A P HX HA HP HI))
+    _ _
 
   -- AC_cart can be derived from AC' by setting P := λ _ _ , unit.
   definition AC_cart_of_AC' : AC'.{u} -> AC_cart.{u} :=
@@ -39,7 +40,7 @@ namespace choice
 
   -- Which is enough to show AC' ≃ AC_cart, since both are props.
   definition AC'_equiv_AC_cart : AC'.{u} ≃ AC_cart.{u} :=
-  equiv_of_is_prop AC_cart_of_AC'.{u} AC'_of_AC_cart.{u}
+  equiv_of_is_prop AC_cart_of_AC'.{u} AC'_of_AC_cart.{u} _ _
 
   -- 3.8.2. AC ≃ AC_cart follows by transitivity.
   definition AC_equiv_AC_cart : AC.{u} ≃ AC_cart.{u} :=
@@ -56,7 +57,7 @@ namespace choice
   begin
     intro H, apply not_is_prop_bool_eq_bool,
     apply @is_trunc_equiv_closed (x0 = x0),
-    apply equiv.symm !equiv_subtype
+    apply equiv.symm !equiv_subtype, exact _
   end
 
   definition is_set_x1 (x : X) : is_set x.1 :=

hott/cubical/cube.hlean

@@ -30,12 +30,12 @@ namespace eq
             {p₁₂₀ : a₀₂₀ = a₂₂₀} {p₂₁₀ : a₂₀₀ = a₂₂₀} {p₂₀₁ : a₂₀₀ = a₂₀₂}
             {p₁₀₂ : a₀₀₂ = a₂₀₂} {p₀₁₂ : a₀₀₂ = a₀₂₂} {p₀₂₁ : a₀₂₀ = a₀₂₂}
             {p₁₂₂ : a₀₂₂ = a₂₂₂} {p₂₁₂ : a₂₀₂ = a₂₂₂} {p₂₂₁ : a₂₂₀ = a₂₂₂}
-            {s₁₁₀ : square p₀₁₀ p₂₁₀ p₁₀₀ p₁₂₀}
-            {s₁₁₂ : square p₀₁₂ p₂₁₂ p₁₀₂ p₁₂₂}
             {s₀₁₁ : square p₀₁₀ p₀₁₂ p₀₀₁ p₀₂₁}
             {s₂₁₁ : square p₂₁₀ p₂₁₂ p₂₀₁ p₂₂₁}
             {s₁₀₁ : square p₁₀₀ p₁₀₂ p₀₀₁ p₂₀₁}
             {s₁₂₁ : square p₁₂₀ p₁₂₂ p₀₂₁ p₂₂₁}
+            {s₁₁₀ : square p₀₁₀ p₂₁₀ p₁₀₀ p₁₂₀}
+            {s₁₁₂ : square p₀₁₂ p₂₁₂ p₁₀₂ p₁₂₂}
             {b₁ b₂ b₃ b₄ : B}
             (c : cube s₀₁₁ s₂₁₁ s₁₀₁ s₁₂₁ s₁₁₀ s₁₁₂)
 
@@ -126,6 +126,7 @@ namespace eq
 
   /- Transporting along a square -/
 
+  -- TODO: remove: they are defined again below
   definition cube_transport110 {s₁₁₀' : square p₀₁₀ p₂₁₀ p₁₀₀ p₁₂₀}
     (p : s₁₁₀ = s₁₁₀') (c : cube s₀₁₁ s₂₁₁ s₁₀₁ s₁₂₁ s₁₁₀ s₁₁₂) :
     cube s₀₁₁ s₂₁₁ s₁₀₁ s₁₂₁ s₁₁₀' s₁₁₂ :=
@@ -203,8 +204,8 @@ namespace eq
   definition cube_fill110 : Σ lid, cube s₀₁₁ s₂₁₁ s₁₀₁ s₁₂₁ lid s₁₁₂ :=
   begin
     induction s₀₁₁, induction s₂₁₁,
-    let fillsq := square_fill_l (eq_of_vdeg_square s₁₀₁)
-        (eq_of_hdeg_square s₁₁₂) (eq_of_vdeg_square s₁₂₁),
+    let fillsq := square_fill_l (eq_of_vdeg_square s₁₀₁) (eq_of_vdeg_square s₁₂₁)
+      (eq_of_hdeg_square s₁₁₂),
     apply sigma.mk,
     apply cube_transport101 (left_inv (vdeg_square_equiv _ _) s₁₀₁),
     apply cube_transport112 (left_inv (hdeg_square_equiv _ _) s₁₁₂),
@@ -215,8 +216,8 @@ namespace eq
   definition cube_fill112 : Σ lid, cube s₀₁₁ s₂₁₁ s₁₀₁ s₁₂₁ s₁₁₀ lid :=
   begin
     induction s₀₁₁, induction s₂₁₁,
-    let fillsq := square_fill_r (eq_of_vdeg_square s₁₀₁)
-        (eq_of_hdeg_square s₁₁₀) (eq_of_vdeg_square s₁₂₁),
+    let fillsq := square_fill_r (eq_of_vdeg_square s₁₀₁) (eq_of_vdeg_square s₁₂₁)
+      (eq_of_hdeg_square s₁₁₀),
     apply sigma.mk,
     apply cube_transport101 (left_inv (vdeg_square_equiv _ _) s₁₀₁),
     apply cube_transport110 (left_inv (hdeg_square_equiv _ _) s₁₁₀),
@@ -227,8 +228,8 @@ namespace eq
   definition cube_fill011 : Σ lid, cube lid s₂₁₁ s₁₀₁ s₁₂₁ s₁₁₀ s₁₁₂ :=
   begin
     induction s₁₀₁, induction s₁₂₁,
-    let fillsq := square_fill_t (eq_of_vdeg_square s₁₁₀) (eq_of_vdeg_square s₁₁₂)
-      (eq_of_vdeg_square s₂₁₁),
+    let fillsq := square_fill_t (eq_of_vdeg_square s₂₁₁) (eq_of_vdeg_square s₁₁₀)
+      (eq_of_vdeg_square s₁₁₂),
     apply sigma.mk,
     apply cube_transport110 (left_inv (vdeg_square_equiv _ _) s₁₁₀),
     apply cube_transport211 (left_inv (vdeg_square_equiv _ _) s₂₁₁),
@@ -251,8 +252,8 @@ namespace eq
   definition cube_fill101 : Σ lid, cube s₀₁₁ s₂₁₁ lid s₁₂₁ s₁₁₀ s₁₁₂ :=
   begin
     induction s₁₁₀, induction s₁₁₂,
-    let fillsq := square_fill_t (eq_of_hdeg_square s₀₁₁) (eq_of_hdeg_square s₂₁₁)
-      (eq_of_hdeg_square s₁₂₁),
+    let fillsq := square_fill_t (eq_of_hdeg_square s₁₂₁) (eq_of_hdeg_square s₀₁₁)
+      (eq_of_hdeg_square s₂₁₁),
     apply sigma.mk,
     apply cube_transport011 (left_inv (hdeg_square_equiv _ _) s₀₁₁),
     apply cube_transport211 (left_inv (hdeg_square_equiv _ _) s₂₁₁),
@@ -339,11 +340,49 @@ namespace eq
   infix ` ⬝1 `:75 := cube_concat1
   infix ` ⬝2 `:75 := cube_concat2
   infix ` ⬝3 `:75 := cube_concat3
-  infix ` ⬝p1 `:75 := eq_concat1
-  infix ` ⬝1p `:75 := concat1_eq
-  infix ` ⬝p2 `:75 := eq_concat3
-  infix ` ⬝2p `:75 := concat2_eq
-  infix ` ⬝p3 `:75 := eq_concat3
-  infix ` ⬝3p `:75 := concat3_eq
+  infixr ` ⬝p1 `:75 := eq_concat1
+  infixl ` ⬝1p `:75 := concat1_eq
+  infixr ` ⬝p2 `:75 := eq_concat2
+  infixl ` ⬝2p `:75 := concat2_eq
+  infixr ` ⬝p3 `:75 := eq_concat3
+  infixl ` ⬝3p `:75 := concat3_eq
+
+  definition whisker001 {p₀₀₁' : a₀₀₀ = a₀₀₂} (q : p₀₀₁' = p₀₀₁)
+    (c : cube s₀₁₁ s₂₁₁ s₁₀₁ s₁₂₁ s₁₁₀ s₁₁₂) : cube (q ⬝ph s₀₁₁) s₂₁₁ (q ⬝ph s₁₀₁) s₁₂₁ s₁₁₀ s₁₁₂ :=
+  by induction q; exact c
+
+  definition whisker021 {p₀₂₁' : a₀₂₀ = a₀₂₂} (q : p₀₂₁' = p₀₂₁)
+    (c : cube s₀₁₁ s₂₁₁ s₁₀₁ s₁₂₁ s₁₁₀ s₁₁₂) :
+    cube (s₀₁₁ ⬝hp q⁻¹) s₂₁₁ s₁₀₁ (q ⬝ph s₁₂₁) s₁₁₀ s₁₁₂ :=
+  by induction q; exact c
+
+  definition whisker021' {p₀₂₁' : a₀₂₀ = a₀₂₂} (q : p₀₂₁ = p₀₂₁')
+    (c : cube s₀₁₁ s₂₁₁ s₁₀₁ s₁₂₁ s₁₁₀ s₁₁₂) :
+    cube (s₀₁₁ ⬝hp q) s₂₁₁ s₁₀₁ (q⁻¹ ⬝ph s₁₂₁) s₁₁₀ s₁₁₂ :=
+  by induction q; exact c
+
+  definition whisker201 {p₂₀₁' : a₂₀₀ = a₂₀₂} (q : p₂₀₁' = p₂₀₁)
+    (c : cube s₀₁₁ s₂₁₁ s₁₀₁ s₁₂₁ s₁₁₀ s₁₁₂) :
+    cube s₀₁₁ (q ⬝ph s₂₁₁) (s₁₀₁ ⬝hp q⁻¹) s₁₂₁ s₁₁₀ s₁₁₂ :=
+  by induction q; exact c
+
+  definition whisker201' {p₂₀₁' : a₂₀₀ = a₂₀₂} (q : p₂₀₁ = p₂₀₁')
+    (c : cube s₀₁₁ s₂₁₁ s₁₀₁ s₁₂₁ s₁₁₀ s₁₁₂) :
+    cube s₀₁₁ (q⁻¹ ⬝ph s₂₁₁) (s₁₀₁ ⬝hp q) s₁₂₁ s₁₁₀ s₁₁₂ :=
+  by induction q; exact c
+
+  definition whisker221 {p₂₂₁' : a₂₂₀ = a₂₂₂} (q : p₂₂₁ = p₂₂₁')
+    (c : cube s₀₁₁ s₂₁₁ s₁₀₁ s₁₂₁ s₁₁₀ s₁₁₂) : cube s₀₁₁ (s₂₁₁ ⬝hp q) s₁₀₁ (s₁₂₁ ⬝hp q) s₁₁₀ s₁₁₂ :=
+  by induction q; exact c
+
+  definition move221 {p₂₂₁' : a₂₂₀ = a₂₂₂} {s₁₂₁ : square p₁₂₀ p₁₂₂ p₀₂₁ p₂₂₁'} (q : p₂₂₁ = p₂₂₁')
+    (c : cube s₀₁₁ (s₂₁₁ ⬝hp q) s₁₀₁ s₁₂₁ s₁₁₀ s₁₁₂) :
+    cube s₀₁₁ s₂₁₁ s₁₀₁ (s₁₂₁ ⬝hp q⁻¹) s₁₁₀ s₁₁₂ :=
+  by induction q; exact c
+
+  definition move201 {p₂₀₁' : a₂₀₀ = a₂₀₂} {s₁₀₁ : square p₁₀₀ p₁₀₂ p₀₀₁ p₂₀₁'}  (q : p₂₀₁' = p₂₀₁)
+    (c : cube s₀₁₁ (q ⬝ph s₂₁₁) s₁₀₁ s₁₂₁ s₁₁₀ s₁₁₂) :
+    cube s₀₁₁ s₂₁₁ (s₁₀₁ ⬝hp q) s₁₂₁ s₁₁₀ s₁₁₂ :=
+  by induction q; exact c
 
 end eq

hott/cubical/pathover2.hlean

@@ -30,7 +30,7 @@ namespace eq
       = change_path (ap_compose g f p) (pathover_ap B (g ∘ f) q) :=
   by induction q; reflexivity
 
-  definition pathover_of_tr_eq_idp (r : b = b') : pathover_of_tr_eq r = pathover_idp_of_eq r :=
+  definition pathover_idp_of_eq_def (r : b = b') : pathover_of_tr_eq r = pathover_idp_of_eq r :=
   idp
 
   definition pathover_of_tr_eq_eq_concato (r : p ▸ b = b₂)
@@ -117,6 +117,10 @@ namespace eq
     apply ap_compose_ap02_constant
   end
 
+  theorem apd_constant' {A A' : Type} {B : A' → Type} {a₁ a₂ : A} {a' : A'} (b : B a')
+    (p : a₁ = a₂) : apd (λx, b) p = pathover_of_eq p idp :=
+  by induction p; reflexivity
+
   definition apd_change_path {B : A → Type} {a a₂ : A} (f : Πa, B a) {p p' : a = a₂} (s : p = p')
     : apd f p' = change_path s (apd f p) :=
   by induction s; reflexivity
@@ -130,4 +134,36 @@ namespace eq
     tr_eq_of_pathover (q ⬝op r) = tr_eq_of_pathover q ⬝ r :=
   by induction r; reflexivity
 
+  definition pathover_tr_pathover_idp_of_eq {A : Type} {B : A → Type} {a a' : A} {b : B a} {b' : B a'} {p : a = a'}
+    (q : b =[p] b') :
+    pathover_tr p b ⬝o pathover_idp_of_eq (tr_eq_of_pathover q) = q :=
+  begin induction q; reflexivity end
+
+  definition pathover_of_tr_eq_idp' {A : Type} {B : A → Type} {a a₂ : A} (p : a = a₂) (b : B a) :
+    pathover_of_tr_eq idp = pathover_tr p b :=
+  by induction p; constructor
+
+  definition eq_of_pathover_apo {A C : Type} {B : A → Type} {a a' : A} {b : B a} {b' : B a'}
+    {p : a = a'} (g : Πa, B a → C) (q : b =[p] b') :
+    eq_of_pathover (apo g q) = apd011 g p q :=
+  by induction q; reflexivity
+
+  definition pathover_ap_cono {A A' : Type} {a₁ a₂ a₃ : A}
+    {p₁ : a₁ = a₂} {p₂ : a₂ = a₃} (B' : A' → Type) (f : A → A')
+    {b₁ : B' (f a₁)} {b₂ : B' (f a₂)} {b₃ : B' (f a₃)}
+    (q₁ : b₁ =[p₁] b₂) (q₂ : b₂ =[p₂] b₃) :
+    pathover_ap B' f (q₁ ⬝o q₂) =
+    change_path !ap_con⁻¹ (pathover_ap B' f q₁ ⬝o pathover_ap B' f q₂) :=
+  by induction q₁; induction q₂; reflexivity
+
+  definition concato_eq_eq {A : Type} {B : A → Type} {a₁ a₂ : A} {p₁ : a₁ = a₂}
+    {b₁ : B a₁} {b₂ b₂' : B a₂} (r : b₁ =[p₁] b₂) (q : b₂ = b₂') :
+    r ⬝op q = r ⬝o pathover_idp_of_eq q :=
+  by induction q; reflexivity
+
+  definition eq_tr_of_pathover_con_tr_eq_of_pathover {A : Type} {B : A → Type}
+    {a₁ a₂ : A} (p : a₁ = a₂) {b₁ : B a₁} {b₂ : B a₂} (q : b₁ =[p] b₂) :
+    eq_tr_of_pathover q ⬝ tr_eq_of_pathover q⁻¹ᵒ = idp :=
+  by induction q; reflexivity
+
 end eq

hott/cubical/square.hlean

@@ -10,13 +10,13 @@ open eq equiv is_equiv sigma
 
 namespace eq
 
-  variables {A B : Type} {a a' a'' a₀₀ a₂₀ a₄₀ a₀₂ a₂₂ a₂₄ a₀₄ a₄₂ a₄₄ a₁ a₂ a₃ a₄ : A}
+  variables {A B C : Type} {a a' a'' a₀₀ a₂₀ a₄₀ a₀₂ a₂₂ a₂₄ a₀₄ a₄₂ a₄₄ a₁ a₂ a₃ a₄ : A}
             /-a₀₀-/ {p₁₀ p₁₀' : a₀₀ = a₂₀} /-a₂₀-/ {p₃₀ : a₂₀ = a₄₀} /-a₄₀-/
-       {p₀₁ p₀₁' : a₀₀ = a₀₂} /-s₁₁-/ {p₂₁ p₂₁' : a₂₀ = a₂₂} /-s₃₁-/ {p₄₁ : a₄₀ = a₄₂}
             /-a₀₂-/ {p₁₂ p₁₂' : a₀₂ = a₂₂} /-a₂₂-/ {p₃₂ : a₂₂ = a₄₂} /-a₄₂-/
-       {p₀₃ : a₀₂ = a₀₄} /-s₁₃-/ {p₂₃ : a₂₂ = a₂₄} /-s₃₃-/ {p₄₃ : a₄₂ = a₄₄}
             /-a₀₄-/ {p₁₄ : a₀₄ = a₂₄} /-a₂₄-/ {p₃₄ : a₂₄ = a₄₄} /-a₄₄-/
-
+       {p₀₁ p₀₁' : a₀₀ = a₀₂} /-s₁₁-/ {p₂₁ p₂₁' : a₂₀ = a₂₂} /-s₃₁-/ {p₄₁ : a₄₀ = a₄₂}
+       {p₀₃ : a₀₂ = a₀₄} /-s₁₃-/ {p₂₃ : a₂₂ = a₂₄} /-s₃₃-/ {p₄₃ : a₄₂ = a₄₄}
+            {b : B} {c : C}
 
   inductive square {A : Type} {a₀₀ : A}
     : Π{a₂₀ a₀₂ a₂₂ : A}, a₀₀ = a₂₀ → a₀₂ = a₂₂ → a₀₀ = a₀₂ → a₂₀ = a₂₂ → Type :=
@@ -88,10 +88,10 @@ namespace eq
 
   infix ` ⬝h `:69 := hconcat --type using \tr
   infix ` ⬝v `:70 := vconcat --type using \tr
-  infix ` ⬝hp `:71 := hconcat_eq --type using \tr
-  infix ` ⬝vp `:73 := vconcat_eq --type using \tr
-  infix ` ⬝ph `:72 := eq_hconcat --type using \tr
-  infix ` ⬝pv `:74 := eq_vconcat --type using \tr
+  infixl ` ⬝hp `:71 := hconcat_eq --type using \tr
+  infixl ` ⬝vp `:73 := vconcat_eq --type using \tr
+  infixr ` ⬝ph `:72 := eq_hconcat --type using \tr
+  infixr ` ⬝pv `:74 := eq_vconcat --type using \tr
   postfix `⁻¹ʰ`:(max+1) := hinverse --type using \-1h
   postfix `⁻¹ᵛ`:(max+1) := vinverse --type using \-1v
 
@@ -529,7 +529,7 @@ namespace eq
 
   definition is_trunc_square [instance] (n : trunc_index) [H : is_trunc n .+2 A]
     : is_trunc n (square p₁₀ p₁₂ p₀₁ p₂₁) :=
-  is_trunc_equiv_closed_rev n !square_equiv_eq
+  is_trunc_equiv_closed_rev n !square_equiv_eq _
 
   -- definition square_of_con_inv_hsquare {p₁ p₂ p₃ p₄ : a₁ = a₂}
   --   {t : p₁ = p₂} {b : p₃ = p₄} {l : p₁ = p₃} {r : p₂ = p₄}
@@ -552,6 +552,7 @@ namespace eq
 
   definition square_fill_r : Σ (p : a₂₀ = a₂₂) , square p₁₀ p₁₂ p₀₁ p :=
   by induction p₁₀; induction p₁₂; exact ⟨_, !hrefl⟩
+  variables {p₁₀ p₁₂ p₀₁ p₂₁}
 
   /- Squares having an 'ap' term on one face -/
   --TODO find better names
@@ -633,4 +634,109 @@ namespace eq
     induction q, esimp at r, induction r using idp_rec_on, exact hrfl
   end
 
+  definition natural_square2 {A B X : Type} {C : A → B → Type}
+    {a a₂ : A} {b b₂ : B} {c : C a b} {c₂ : C a₂ b₂} {f : A → X} {g : B → X}
+    (h : Πa b, C a b → f a = g b) (p : a = a₂) (q : b = b₂) (r : transport11 C p q c = c₂) :
+    square (h a b c) (h a₂ b₂ c₂) (ap f p) (ap g q) :=
+  by induction p; induction q; induction r; exact vrfl
+
+  /- some higher coherence conditions -/
+
+
+  theorem whisker_bl_whisker_tl_eq (p : a = a')
+    : whisker_bl p (whisker_tl p ids) = con.right_inv p ⬝ph vrfl :=
+  by induction p; reflexivity
+
+  theorem ap_is_constant_natural_square {g : B → C} {f : A → B} (H : Πa, g (f a) = c) (p : a = a') :
+    (ap_is_constant H p)⁻¹ ⬝ph natural_square H p ⬝hp ap_constant p c =
+      whisker_bl (H a') (whisker_tl (H a) ids) :=
+  begin induction p, esimp, rewrite inv_inv, rewrite whisker_bl_whisker_tl_eq end
+
+  definition inv_ph_eq_of_eq_ph {p : a₀₀ = a₀₂} {r : p₀₁ = p} {s₁₁ : square p₁₀ p₁₂ p₀₁ p₂₁}
+    {s₁₁' : square p₁₀ p₁₂ p p₂₁} (t : s₁₁ = r ⬝ph s₁₁') : r⁻¹ ⬝ph s₁₁ = s₁₁' :=
+  by induction r; exact t
+
+  -- the following is used for torus.elim_surf
+  theorem whisker_square_aps_eq {f : A → B}
+    {q₁₀ : f a₀₀ = f a₂₀} {q₀₁ : f a₀₀ = f a₀₂} {q₂₁ : f a₂₀ = f a₂₂} {q₁₂ : f a₀₂ = f a₂₂}
+    {r₁₀ : ap f p₁₀ = q₁₀} {r₀₁ : ap f p₀₁ = q₀₁} {r₂₁ : ap f p₂₁ = q₂₁} {r₁₂ : ap f p₁₂ = q₁₂}
+    {s₁₁ : p₁₀ ⬝ p₂₁ = p₀₁ ⬝ p₁₂} {t₁₁ : square q₁₀ q₁₂ q₀₁ q₂₁}
+    (u : square (ap02 f s₁₁) (eq_of_square t₁₁)
+                (ap_con f p₁₀ p₂₁ ⬝ (r₁₀ ◾ r₂₁)) (ap_con f p₀₁ p₁₂ ⬝ (r₀₁ ◾ r₁₂)))
+    : whisker_square r₁₀ r₁₂ r₀₁ r₂₁ (aps f (square_of_eq s₁₁)) = t₁₁ :=
+  begin
+    induction r₁₀, induction r₀₁, induction r₁₂, induction r₂₁,
+    induction p₁₂, induction p₁₀, induction p₂₁, esimp at *, induction s₁₁, esimp at *,
+    esimp [square_of_eq],
+    apply inj !square_equiv_eq, esimp,
+    exact (eq_bot_of_square u)⁻¹
+  end
+
+  definition natural_square_eq {A B : Type} {a a' : A} {f g : A → B} (p : f ~ g) (q : a = a')
+    : natural_square p q = square_of_pathover (apd p q) :=
+  idp
+
+  definition eq_of_square_hrfl_hconcat_eq {A : Type} {a a' : A} {p p' : a = a'} (q : p = p')
+    : eq_of_square (hrfl ⬝hp q⁻¹) = !idp_con ⬝ q :=
+  by induction q; induction p; reflexivity
+
+  definition aps_vrfl {A B : Type} {a a' : A} (f : A → B) (p : a = a') :
+    aps f (vrefl p) = vrefl (ap f p) :=
+  by induction p; reflexivity
+
+  definition aps_hrfl {A B : Type} {a a' : A} (f : A → B) (p : a = a') :
+    aps f (hrefl p) = hrefl (ap f p) :=
+  by induction p; reflexivity
+
+  -- should the following two equalities be cubes?
+  definition natural_square_ap_fn {A B C : Type} {a a' : A} {g h : A → B} (f : B → C) (p : g ~ h)
+    (q : a = a') : natural_square (λa, ap f (p a)) q =
+      ap_compose f g q ⬝ph (aps f (natural_square p q) ⬝hp (ap_compose f h q)⁻¹) :=
+  begin
+    induction q, exact !aps_vrfl⁻¹
+  end
+
+  definition natural_square_compose {A B C : Type} {a a' : A} {g g' : B → C}
+    (p : g ~ g') (f : A → B) (q : a = a') : natural_square (λa, p (f a)) q =
+    ap_compose g f q ⬝ph (natural_square p (ap f q) ⬝hp (ap_compose g' f q)⁻¹) :=
+  by induction q; reflexivity
+
+  definition natural_square_eq2 {A B : Type} {a a' : A} {f f' : A → B} (p : f ~ f') {q q' : a = a'}
+    (r : q = q') : natural_square p q = ap02 f r ⬝ph (natural_square p q' ⬝hp (ap02 f' r)⁻¹) :=
+  by induction r; reflexivity
+
+  definition natural_square_refl {A B : Type} {a a' : A} (f : A → B) (q : a = a')
+    : natural_square (homotopy.refl f) q = hrfl :=
+  by induction q; reflexivity
+
+  definition aps_eq_hconcat {p₀₁'} (f : A → B) (q : p₀₁' = p₀₁) (s₁₁ : square p₁₀ p₁₂ p₀₁ p₂₁) :
+    aps f (q ⬝ph s₁₁) = ap02 f q ⬝ph aps f s₁₁ :=
+  by induction q; reflexivity
+
+  definition aps_hconcat_eq {p₂₁'} (f : A → B) (s₁₁ : square p₁₀ p₁₂ p₀₁ p₂₁) (r : p₂₁' = p₂₁) :
+    aps f (s₁₁ ⬝hp r⁻¹) = aps f s₁₁ ⬝hp (ap02 f r)⁻¹ :=
+  by induction r; reflexivity
+
+  definition aps_hconcat_eq' {p₂₁'} (f : A → B) (s₁₁ : square p₁₀ p₁₂ p₀₁ p₂₁) (r : p₂₁ = p₂₁') :
+    aps f (s₁₁ ⬝hp r) = aps f s₁₁ ⬝hp ap02 f r :=
+  by induction r; reflexivity
+
+  definition aps_square_of_eq (f : A → B) (s : p₁₀ ⬝ p₂₁ = p₀₁ ⬝ p₁₂) :
+    aps f (square_of_eq s) = square_of_eq ((ap_con f p₁₀ p₂₁)⁻¹ ⬝ ap02 f s ⬝ ap_con f p₀₁ p₁₂) :=
+  by induction p₁₂; esimp at *; induction s; induction p₂₁; induction p₁₀; reflexivity
+
+  definition aps_eq_hconcat_eq {p₀₁' p₂₁'} (f : A → B) (q : p₀₁' = p₀₁) (s₁₁ : square p₁₀ p₁₂ p₀₁ p₂₁)
+    (r : p₂₁' = p₂₁) : aps f (q ⬝ph s₁₁ ⬝hp r⁻¹) = ap02 f q ⬝ph aps f s₁₁ ⬝hp (ap02 f r)⁻¹ :=
+  by induction q; induction r; reflexivity
+
+  definition eq_hconcat_equiv [constructor] {p : a₀₀ = a₀₂} (r : p = p₀₁) :
+    square p₁₀ p₁₂ p p₂₁ ≃ square p₁₀ p₁₂ p₀₁ p₂₁ :=
+  equiv.MK (eq_hconcat r⁻¹) (eq_hconcat r)
+    begin intro s, induction r, reflexivity end begin intro s, induction r, reflexivity end
+
+  definition hconcat_eq_equiv [constructor] {p : a₂₀ = a₂₂} (r : p₂₁ = p) :
+    square p₁₀ p₁₂ p₀₁ p₂₁ ≃ square p₁₀ p₁₂ p₀₁ p :=
+  equiv.MK (λs, hconcat_eq s r) (λs, hconcat_eq s r⁻¹)
+    begin intro s, induction r, reflexivity end begin intro s, induction r, reflexivity end
+
 end eq

hott/cubical/square2.hlean

@@ -1,52 +0,0 @@
-/-
-Copyright (c) 2015 Floris van Doorn. All rights reserved.
-Released under Apache 2.0 license as described in the file LICENSE.
-Author: Floris van Doorn
-
-Coherence conditions for operations on squares
--/
-
-import .square
-
-open equiv
-
-namespace eq
-
-  variables {A B C : Type} {a a' a'' a₀₀ a₂₀ a₄₀ a₀₂ a₂₂ a₂₄ a₀₄ a₄₂ a₄₄ a₁ a₂ a₃ a₄ : A}
-            {f : A → B} {b : B} {c : C}
-            /-a₀₀-/ {p₁₀ p₁₀' : a₀₀ = a₂₀} /-a₂₀-/ {p₃₀ : a₂₀ = a₄₀} /-a₄₀-/
-       {p₀₁ p₀₁' : a₀₀ = a₀₂} /-s₁₁-/ {p₂₁ p₂₁' : a₂₀ = a₂₂} /-s₃₁-/ {p₄₁ : a₄₀ = a₄₂}
-            /-a₀₂-/ {p₁₂ p₁₂' : a₀₂ = a₂₂} /-a₂₂-/ {p₃₂ : a₂₂ = a₄₂} /-a₄₂-/
-       {p₀₃ : a₀₂ = a₀₄} /-s₁₃-/ {p₂₃ : a₂₂ = a₂₄} /-s₃₃-/ {p₄₃ : a₄₂ = a₄₄}
-            /-a₀₄-/ {p₁₄ : a₀₄ = a₂₄} /-a₂₄-/ {p₃₄ : a₂₄ = a₄₄} /-a₄₄-/
-
-  theorem whisker_bl_whisker_tl_eq (p : a = a')
-    : whisker_bl p (whisker_tl p ids) = con.right_inv p ⬝ph vrfl :=
-  by induction p; reflexivity
-
-  theorem ap_is_constant_natural_square {g : B → C} {f : A → B} (H : Πa, g (f a) = c) (p : a = a') :
-    (ap_is_constant H p)⁻¹ ⬝ph natural_square H p ⬝hp ap_constant p c =
-      whisker_bl (H a') (whisker_tl (H a) ids) :=
-  begin induction p, esimp, rewrite inv_inv, rewrite whisker_bl_whisker_tl_eq end
-
-  definition inv_ph_eq_of_eq_ph {p : a₀₀ = a₀₂} {r : p₀₁ = p} {s₁₁ : square p₁₀ p₁₂ p₀₁ p₂₁}
-    {s₁₁' : square p₁₀ p₁₂ p p₂₁} (t : s₁₁ = r ⬝ph s₁₁') : r⁻¹ ⬝ph s₁₁ = s₁₁' :=
-  by induction r; exact t
-
-  -- the following is used for torus.elim_surf
-  theorem whisker_square_aps_eq
-    {q₁₀ : f a₀₀ = f a₂₀} {q₀₁ : f a₀₀ = f a₀₂} {q₂₁ : f a₂₀ = f a₂₂} {q₁₂ : f a₀₂ = f a₂₂}
-    {r₁₀ : ap f p₁₀ = q₁₀} {r₀₁ : ap f p₀₁ = q₀₁} {r₂₁ : ap f p₂₁ = q₂₁} {r₁₂ : ap f p₁₂ = q₁₂}
-    {s₁₁ : p₁₀ ⬝ p₂₁ = p₀₁ ⬝ p₁₂} {t₁₁ : square q₁₀ q₁₂ q₀₁ q₂₁}
-    (u : square (ap02 f s₁₁) (eq_of_square t₁₁)
-                (ap_con f p₁₀ p₂₁ ⬝ (r₁₀ ◾ r₂₁)) (ap_con f p₀₁ p₁₂ ⬝ (r₀₁ ◾ r₁₂)))
-    : whisker_square r₁₀ r₁₂ r₀₁ r₂₁ (aps f (square_of_eq s₁₁)) = t₁₁ :=
-  begin
-    induction r₁₀, induction r₀₁, induction r₁₂, induction r₂₁,
-    induction p₁₂, induction p₁₀, induction p₂₁, esimp at *, induction s₁₁, esimp at *,
-    esimp [square_of_eq],
-    apply eq_of_fn_eq_fn !square_equiv_eq, esimp,
-    exact (eq_bot_of_square u)⁻¹
-  end
-
-end eq

hott/cubical/squareover.hlean

@@ -28,21 +28,22 @@ namespace eq
   variables {A A' : Type} {B : A → Type}
             {a a' a'' a₀₀ a₂₀ a₄₀ a₀₂ a₂₂ a₂₄ a₀₄ a₄₂ a₄₄ : A}
             /-a₀₀-/ {p₁₀ : a₀₀ = a₂₀} /-a₂₀-/ {p₃₀ : a₂₀ = a₄₀} /-a₄₀-/
-       {p₀₁ : a₀₀ = a₀₂} /-s₁₁-/ {p₂₁ : a₂₀ = a₂₂} /-s₃₁-/ {p₄₁ : a₄₀ = a₄₂}
             /-a₀₂-/ {p₁₂ : a₀₂ = a₂₂} /-a₂₂-/ {p₃₂ : a₂₂ = a₄₂} /-a₄₂-/
-       {p₀₃ : a₀₂ = a₀₄} /-s₁₃-/ {p₂₃ : a₂₂ = a₂₄} /-s₃₃-/ {p₄₃ : a₄₂ = a₄₄}
             /-a₀₄-/ {p₁₄ : a₀₄ = a₂₄} /-a₂₄-/ {p₃₄ : a₂₄ = a₄₄} /-a₄₄-/
+       {p₀₁ : a₀₀ = a₀₂} /-s₁₁-/ {p₂₁ : a₂₀ = a₂₂} /-s₃₁-/ {p₄₁ : a₄₀ = a₄₂}
+       {p₀₃ : a₀₂ = a₀₄} /-s₁₃-/ {p₂₃ : a₂₂ = a₂₄} /-s₃₃-/ {p₄₃ : a₄₂ = a₄₄}
             {s₁₁ : square p₁₀ p₁₂ p₀₁ p₂₁} {s₃₁ : square p₃₀ p₃₂ p₂₁ p₄₁}
             {s₁₃ : square p₁₂ p₁₄ p₀₃ p₂₃} {s₃₃ : square p₃₂ p₃₄ p₂₃ p₄₃}
 
+            {b : B a}
             {b₀₀ : B a₀₀} {b₂₀ : B a₂₀} {b₄₀ : B a₄₀}
             {b₀₂ : B a₀₂} {b₂₂ : B a₂₂} {b₄₂ : B a₄₂}
             {b₀₄ : B a₀₄} {b₂₄ : B a₂₄} {b₄₄ : B a₄₄}
             /-b₀₀-/ {q₁₀ : b₀₀ =[p₁₀] b₂₀} /-b₂₀-/ {q₃₀ : b₂₀ =[p₃₀] b₄₀} /-b₄₀-/
-   {q₀₁ : b₀₀ =[p₀₁] b₀₂} /-t₁₁-/ {q₂₁ : b₂₀ =[p₂₁] b₂₂} /-t₃₁-/ {q₄₁ : b₄₀ =[p₄₁] b₄₂}
             /-b₀₂-/ {q₁₂ : b₀₂ =[p₁₂] b₂₂} /-b₂₂-/ {q₃₂ : b₂₂ =[p₃₂] b₄₂} /-b₄₂-/
-   {q₀₃ : b₀₂ =[p₀₃] b₀₄} /-t₁₃-/ {q₂₃ : b₂₂ =[p₂₃] b₂₄} /-t₃₃-/ {q₄₃ : b₄₂ =[p₄₃] b₄₄}
             /-b₀₄-/ {q₁₄ : b₀₄ =[p₁₄] b₂₄} /-b₂₄-/ {q₃₄ : b₂₄ =[p₃₄] b₄₄} /-b₄₄-/
+   {q₀₁ : b₀₀ =[p₀₁] b₀₂} /-t₁₁-/ {q₂₁ : b₂₀ =[p₂₁] b₂₂} /-t₃₁-/ {q₄₁ : b₄₀ =[p₄₁] b₄₂}
+   {q₀₃ : b₀₂ =[p₀₃] b₀₄} /-t₁₃-/ {q₂₃ : b₂₂ =[p₂₃] b₂₄} /-t₃₃-/ {q₄₃ : b₄₂ =[p₄₃] b₄₄}
 
   definition squareo := @squareover A B a₀₀
   definition idsquareo [reducible] [constructor] (b₀₀ : B a₀₀) := @squareover.idsquareo A B a₀₀ b₀₀
@@ -117,9 +118,9 @@ namespace eq
     squareover B (sp ⬝ph s₁₁) q₁₀ q₁₂ q q₂₁ :=
   by induction sp; induction r; exact t₁₁
 
-  definition hconcato_pathover {p : a₂₀ = a₂₂} {sp : p₂₁ = p} {q : b₂₀ =[p] b₂₂}
-    (t₁₁ : squareover B s₁₁ q₁₀ q₁₂ q₀₁ q₂₁) (r : change_path sp q₂₁ = q) :
-    squareover B (s₁₁ ⬝hp sp) q₁₀ q₁₂ q₀₁ q :=
+  definition hconcato_pathover {p : a₂₀ = a₂₂} {sp : p = p₂₁} {s : square p₁₀ p₁₂ p₀₁ p}
+    {q : b₂₀ =[p] b₂₂} (t₁₁ : squareover B (s ⬝hp sp) q₁₀ q₁₂ q₀₁ q₂₁)
+    (r : change_path sp q = q₂₁) : squareover B s q₁₀ q₁₂ q₀₁ q :=
   by induction sp; induction r; exact t₁₁
 
   infix ` ⬝ho `:69 := hconcato --type using \tr
@@ -241,7 +242,7 @@ namespace eq
     induction p₁₀, -- if needed we can remove this induction and use con_tr_idp in types/eq2
     rewrite [▸* at H,idp_con at H,+ap_id at H],
     let H' := eq_of_vdeg_square H,
-    exact eq_of_fn_eq_fn !pathover_equiv_tr_eq H'
+    exact inj !pathover_equiv_tr_eq H'
   end
 
   -- definition vdeg_tr_squareover {q₁₂ : p₀₁ ▸ b₀₀ =[p₁₂] p₂₁ ▸ b₂₀} (r : q₁₀ =[_] q₁₂)
@@ -304,4 +305,35 @@ namespace eq
     exact square_dpair_eq_dpair s₁₁ t₁₁
   end
 
+  definition move_right_of_top_over {p : a₀₀ = a} {p' : a = a₂₀}
+    {s : square p p₁₂ p₀₁ (p' ⬝ p₂₁)} {q : b₀₀ =[p] b} {q' : b =[p'] b₂₀}
+    (t : squareover B (move_top_of_right s) (q ⬝o q') q₁₂ q₀₁ q₂₁) :
+    squareover B s q q₁₂ q₀₁ (q' ⬝o q₂₁) :=
+  begin induction q', induction q, induction q₂₁, exact t end
+
+  variables (s₁₁ q₀₁ q₁₀ q₂₁ q₁₂)
+  definition squareover_fill_t : Σ (q : b₀₀ =[p₁₀] b₂₀), squareover B s₁₁ q q₁₂ q₀₁ q₂₁ :=
+  begin
+    induction s₁₁, induction q₀₁ using idp_rec_on, induction q₂₁ using idp_rec_on,
+    induction q₁₂ using idp_rec_on, exact ⟨idpo, idso⟩
+  end
+
+  definition squareover_fill_b : Σ (q : b₀₂ =[p₁₂] b₂₂), squareover B s₁₁ q₁₀ q q₀₁ q₂₁ :=
+  begin
+    induction s₁₁, induction q₀₁ using idp_rec_on, induction q₂₁ using idp_rec_on,
+    induction q₁₀ using idp_rec_on, exact ⟨idpo, idso⟩
+  end
+
+  definition squareover_fill_l : Σ (q : b₀₀ =[p₀₁] b₀₂), squareover B s₁₁ q₁₀ q₁₂ q q₂₁ :=
+  begin
+    induction s₁₁, induction q₁₀ using idp_rec_on, induction q₂₁ using idp_rec_on,
+    induction q₁₂ using idp_rec_on, exact ⟨idpo, idso⟩
+  end
+
+  definition squareover_fill_r : Σ (q : b₂₀ =[p₂₁] b₂₂) , squareover B s₁₁ q₁₀ q₁₂ q₀₁ q :=
+  begin
+    induction s₁₁, induction q₀₁ using idp_rec_on, induction q₁₀ using idp_rec_on,
+    induction q₁₂ using idp_rec_on, exact ⟨idpo, idso⟩
+  end
+
 end eq

hott/eq2.hlean

@@ -6,8 +6,8 @@ Author: Floris van Doorn
 Theorems about 2-dimensional paths
 -/
 
-import .cubical.square
-open function
+import .cubical.square .function
+open function is_equiv equiv sigma trunc
 
 namespace eq
   variables {A B C : Type} {f : A → B} {a a' a₁ a₂ a₃ a₄ : A} {b b' : B}
@@ -141,4 +141,163 @@ namespace eq
     : whisker_left p q⁻² ⬝ q = con.right_inv p :=
   by cases q; reflexivity
 
+  definition whisker_left_idp_square {A : Type} {a a' : A} {p q : a = a'} (r : p = q) :
+    square (whisker_left idp r) r (idp_con p) (idp_con q) :=
+  begin induction r, exact hrfl end
+
+  definition cast_fn_cast_square {A : Type} {B C : A → Type} (f : Π⦃a⦄, B a → C a) {a₁ a₂ : A}
+    (p : a₁ = a₂) (q : a₂ = a₁) (r : p ⬝ q = idp) (b : B a₁) :
+    cast (ap C q) (f (cast (ap B p) b)) = f b :=
+  have q⁻¹ = p, from inv_eq_of_idp_eq_con r⁻¹,
+  begin induction this, induction q, reflexivity end
+
+  definition ap011_ap_square_right {A B C : Type} (f : A → B → C) {a a' : A} (p : a = a')
+    {b₁ b₂ b₃ : B} {q₁₂ : b₁ = b₂} {q₂₃ : b₂ = b₃} {q₁₃ : b₁ = b₃} (r : q₁₂ ⬝ q₂₃ = q₁₃) :
+    square (ap011 f p q₁₂) (ap (λx, f x b₃) p) (ap (f a) q₁₃) (ap (f a') q₂₃) :=
+  by induction r; induction q₂₃; induction q₁₂; induction p; exact ids
+
+  definition ap011_ap_square_left {A B C : Type} (f : B → A → C) {a a' : A} (p : a = a')
+    {b₁ b₂ b₃ : B} {q₁₂ : b₁ = b₂} {q₂₃ : b₂ = b₃} {q₁₃ : b₁ = b₃} (r : q₁₂ ⬝ q₂₃ = q₁₃) :
+    square (ap011 f q₁₂ p) (ap (f b₃) p) (ap (λx, f x a) q₁₃) (ap (λx, f x a') q₂₃) :=
+  by induction r; induction q₂₃; induction q₁₂; induction p; exact ids
+
+  definition con2_assoc {A : Type} {x y z t : A} {p p' : x = y} {q q' : y = z} {r r' : z = t}
+    (h : p = p') (h' : q = q') (h'' : r = r') :
+    square ((h ◾ h') ◾ h'') (h ◾ (h' ◾ h'')) (con.assoc p q r) (con.assoc p' q' r') :=
+  by induction h; induction h'; induction h''; exact hrfl
+
+  definition con_left_inv_idp {A : Type} {x : A} {p : x = x} (q : p = idp)
+    : con.left_inv p = q⁻² ◾ q :=
+  by cases q; reflexivity
+
+  definition eckmann_hilton_con2 {A : Type} {x : A} {p p' q q': idp = idp :> x = x}
+    (h : p = p') (h' : q = q') : square (h ◾ h') (h' ◾ h) (eckmann_hilton p q) (eckmann_hilton p' q') :=
+  by induction h; induction h'; exact hrfl
+
+  definition ap_con_fn {A B : Type} {a a' : A} {b : B} (g h : A → b = b) (p : a = a') :
+    ap (λa, g a ⬝ h a) p = ap g p ◾ ap h p :=
+  by induction p; reflexivity
+
+  definition ap_eq_ap011 {A B C X : Type} (f : A → B → C) (g : X → A) (h : X → B) {x x' : X}
+    (p : x = x') : ap (λx, f (g x) (h x)) p = ap011 f (ap g p) (ap h p) :=
+  by induction p; reflexivity
+
+  definition ap_is_weakly_constant {A B : Type} {f : A → B}
+    (h : is_weakly_constant f) {a a' : A} (p : a = a') : ap f p = (h a a)⁻¹ ⬝ h a a' :=
+  by induction p; exact !con.left_inv⁻¹
+
+  definition ap_is_constant_idp {A B : Type} {f : A → B} {b : B} (p : Πa, f a = b) {a : A} (q : a = a)
+    (r : q = idp) : ap_is_constant p q = ap02 f r ⬝ (con.right_inv (p a))⁻¹ :=
+  by cases r; exact !idp_con⁻¹
+
+  definition con_right_inv_natural {A : Type} {a a' : A} {p p' : a = a'} (q : p = p') :
+    con.right_inv p = q ◾ q⁻² ⬝ con.right_inv p' :=
+  by induction q; induction p; reflexivity
+
+  definition whisker_right_ap {A B : Type} {a a' : A}{b₁ b₂ b₃ : B} (q : b₂ = b₃) (f : A → b₁ = b₂)
+    (p : a = a') : whisker_right q (ap f p) = ap (λa, f a ⬝ q) p :=
+  by induction p; reflexivity
+
+  definition ap02_ap_constant {A B C : Type} {a a' : A} (f : B → C) (b : B) (p : a = a') :
+    square (ap_constant p (f b)) (ap02 f (ap_constant p b)) (ap_compose f (λx, b) p) idp :=
+  by induction p; exact ids
+
+  definition ap_constant_compose {A B C : Type} {a a' : A} (c : C) (f : A → B) (p : a = a') :
+    square (ap_constant p c) (ap_constant (ap f p) c) (ap_compose (λx, c) f p) idp :=
+  by induction p; exact ids
+
+  definition ap02_constant {A B : Type} {a a' : A} (b : B) {p p' : a = a'}
+    (q : p = p') : square (ap_constant p b) (ap_constant p' b) (ap02 (λx, b) q) idp :=
+  by induction q; exact vrfl
+
+  definition ap_con_idp_left {A B : Type} (f : A → B) {a a' : A} (p : a = a') :
+    square (ap_con f idp p) idp (ap02 f (idp_con p)) (idp_con (ap f p)) :=
+  begin induction p, exact ids end
+
+  definition apd10_prepostcompose_nondep {A B C D : Type} (h : C → D) {g g' : B → C} (p : g = g')
+    (f : A → B) (a : A) : apd10 (ap (λg a, h (g (f a))) p) a = ap h (apd10 p (f a)) :=
+  begin induction p, reflexivity end
+
+  definition apd10_prepostcompose {A B : Type} {C : B → Type} {D : A → Type}
+    (f : A → B) (h : Πa, C (f a) → D a) {g g' : Πb, C b}
+    (p : g = g') (a : A) :
+    apd10 (ap (λg a, h a (g (f a))) p) a = ap (h a) (apd10 p (f a)) :=
+  begin induction p, reflexivity end
+
+  /- alternative induction principles -/
+  definition eq.rec_to {A : Type} {a₀ : A} {P : Π⦃a₁⦄, a₀ = a₁ → Type}
+    {a₁ : A} (p₀ : a₀ = a₁) (H : P p₀) ⦃a₂ : A⦄ (p : a₀ = a₂) : P p :=
+  begin
+    induction p₀, induction p, exact H
+  end
+
+  definition eq.rec_to2 {A : Type} {P : Π⦃a₀ a₁⦄, a₀ = a₁ → Type}
+    {a₀ a₀' a₁' : A} (p' : a₀' = a₁') (p₀ : a₀ = a₀') (H : P p') ⦃a₁ : A⦄ (p : a₀ = a₁) : P p :=
+  begin
+   induction p₀, induction p', induction p, exact H
+  end
+
+  definition eq.rec_right_inv {A : Type} (f : A ≃ A) {P : Π⦃a₀ a₁⦄, f a₀ = a₁ → Type}
+    (H : Πa, P (right_inv f a)) ⦃a₀ a₁ : A⦄ (p : f a₀ = a₁) : P p :=
+  begin
+    revert a₀ p, refine equiv_rect f⁻¹ᵉ _ _,
+    intro a₀ p, exact eq.rec_to (right_inv f a₀) (H a₀) p,
+  end
+
+  definition eq.rec_equiv {A B : Type} {a₀ : A} (f : A ≃ B) {P : Π{a₁}, f a₀ = f a₁ → Type}
+    (H : P (idpath (f a₀))) ⦃a₁ : A⦄ (p : f a₀ = f a₁) : P p :=
+  begin
+    assert qr : Σ(q : a₀ = a₁), ap f q = p,
+    { exact ⟨inj f p, ap_inj' f p⟩ },
+    cases qr with q r, apply transport P r, induction q, exact H
+  end
+
+  definition eq.rec_equiv_symm {A B : Type} {a₁ : A} (f : A ≃ B) {P : Π{a₀}, f a₀ = f a₁ → Type}
+    (H : P (idpath (f a₁))) ⦃a₀ : A⦄ (p : f a₀ = f a₁) : P p :=
+  begin
+    assert qr : Σ(q : a₀ = a₁), ap f q = p,
+    { exact ⟨inj f p, ap_inj' f p⟩ },
+    cases qr with q r, apply transport P r, induction q, exact H
+  end
+
+  definition eq.rec_equiv_to_same {A B : Type} {a₀ : A} (f : A ≃ B) {P : Π{a₁}, f a₀ = f a₁ → Type}
+    ⦃a₁' : A⦄ (p' : f a₀ = f a₁') (H : P p') ⦃a₁ : A⦄ (p : f a₀ = f a₁) : P p :=
+  begin
+    revert a₁' p' H a₁ p,
+    refine eq.rec_equiv f _,
+    exact eq.rec_equiv f
+  end
+
+  definition eq.rec_equiv_to {A A' B : Type} {a₀ : A} (f : A ≃ B) (g : A' ≃ B)
+    {P : Π{a₁}, f a₀ = g a₁ → Type}
+    ⦃a₁' : A'⦄ (p' : f a₀ = g a₁') (H : P p') ⦃a₁ : A'⦄ (p : f a₀ = g a₁) : P p :=
+  begin
+    assert qr : Σ(q : g⁻¹ (f a₀) = a₁), (right_inv g (f a₀))⁻¹ ⬝ ap g q = p,
+    { exact ⟨inj g (right_inv g (f a₀) ⬝ p),
+             whisker_left _ (ap_inj' g _) ⬝ !inv_con_cancel_left⟩ },
+    assert q'r' : Σ(q' : g⁻¹ (f a₀) = a₁'), (right_inv g (f a₀))⁻¹ ⬝ ap g q' = p',
+    { exact ⟨inj g (right_inv g (f a₀) ⬝ p'),
+             whisker_left _ (ap_inj' g _) ⬝ !inv_con_cancel_left⟩ },
+    induction qr with q r, induction q'r' with q' r',
+    induction q, induction q',
+    induction r, induction r',
+    exact H
+  end
+
+  definition eq.rec_grading {A A' B : Type} {a : A} (f : A ≃ B) (g : A' ≃ B)
+    {P : Π{b}, f a = b → Type}
+    {a' : A'} (p' : f a = g a') (H : P p') ⦃b : B⦄ (p : f a = b) : P p :=
+  begin
+    revert b p, refine equiv_rect g _ _,
+    exact eq.rec_equiv_to f g p' H
+  end
+
+  definition eq.rec_grading_unbased {A B B' C : Type} (f : A ≃ B) (g : B ≃ C) (h : B' ≃ C)
+    {P : Π{b c}, g b = c → Type}
+    {a' : A} {b' : B'} (p' : g (f a') = h b') (H : P p') ⦃b : B⦄ ⦃c : C⦄ (q : f a' = b)
+    (p : g b = c) : P p :=
+  begin
+    induction q, exact eq.rec_grading (f ⬝e g) h p' H p
+  end
+
 end eq

hott/function.hlean

@@ -7,24 +7,20 @@ Ported from Coq HoTT
 Theorems about embeddings and surjections
 -/
 
-import hit.trunc types.equiv cubical.square
+import hit.trunc types.equiv cubical.square types.nat
 
-open equiv sigma sigma.ops eq trunc is_trunc pi is_equiv fiber prod
+open equiv sigma sigma.ops eq trunc is_trunc pi is_equiv fiber prod pointed nat
 
-variables {A B C : Type} (f : A → B) {b : B}
+variables {A B C : Type} (f f' : A → B) {b : B}
 
 /- the image of a map is the (-1)-truncated fiber -/
 definition image' [constructor] (f : A → B) (b : B) : Type := ∥ fiber f b ∥
 definition is_prop_image' [instance] (f : A → B) (b : B) : is_prop (image' f b) := !is_trunc_trunc
 definition image [constructor] (f : A → B) (b : B) : Prop := Prop.mk (image' f b) _
 
-definition image.mk [constructor] {f : A → B} {b : B} (a : A) (p : f a = b)
-  : image f b :=
-tr (fiber.mk a p)
+definition total_image {A B : Type} (f : A → B) : Type := sigma (image f)
 
-protected definition image.rec [unfold 8] [recursor 8] {f : A → B} {b : B} {P : image' f b → Type}
-  [H : Πv, is_prop (P v)] (H : Π(a : A) (p : f a = b), P (image.mk a p)) (v : image' f b) : P v :=
-begin unfold [image'] at *, induction v with v, induction v with a p, exact H a p end
+/- properties of functions -/
 
 definition is_embedding [class] (f : A → B) := Π(a a' : A), is_equiv (ap f : a = a' → f a = f a')
 
@@ -46,10 +42,51 @@ structure is_constant [class] (f : A → B) :=
   (pt : B)
   (eq : Π(a : A), f a = pt)
 
+definition merely_constant {A B : Type} (f : A → B) : Type :=
+Σb, Πa, merely (f a = b)
+
 structure is_conditionally_constant [class] (f : A → B) :=
   (g : ∥A∥ → B)
   (eq : Π(a : A), f a = g (tr a))
 
+section image
+protected definition image.mk [constructor] {f : A → B} {b : B} (a : A) (p : f a = b)
+  : image f b :=
+tr (fiber.mk a p)
+
+protected definition image.rec [unfold 8] [recursor 8] {f : A → B} {b : B} {P : image' f b → Type}
+  [H : Πv, is_prop (P v)] (H : Π(a : A) (p : f a = b), P (image.mk a p)) (v : image' f b) : P v :=
+begin unfold [image'] at *, induction v with v, induction v with a p, exact H a p end
+
+definition image.elim {A B : Type} {f : A → B} {C : Type} [is_prop C] {b : B}
+  (H : image f b) (H' : ∀ (a : A), f a = b → C) : C :=
+begin
+  refine (trunc.elim _ H),
+  intro H'', cases H'' with a Ha, exact H' a Ha
+end
+
+definition image.equiv_exists {A B : Type} {f : A → B} {b : B} : image f b ≃ ∃ a, f a = b :=
+trunc_equiv_trunc _ (fiber.sigma_char _ _)
+
+definition image_pathover {f : A → B} {x y : B} (p : x = y) (u : image f x) (v : image f y) :
+  u =[p] v :=
+!is_prop.elimo
+
+definition total_image.rec [unfold 7]
+  {A B : Type} {f : A → B} {C : total_image f → Type} [H : Πx, is_prop (C x)]
+  (g : Πa, C ⟨f a, image.mk a idp⟩)
+  (x : total_image f) : C x :=
+begin
+  induction x with b v,
+  refine @image.rec _ _ _ _ _ (λv, H ⟨b, v⟩) _ v,
+  intro a p,
+  induction p, exact g a
+end
+
+/- total_image.elim_set is in hit.prop_trunc to avoid dependency cycle -/
+
+end image
+
 namespace function
 
   abbreviation sect          [unfold 4] := @is_retraction.sect
@@ -137,6 +174,14 @@ namespace function
     exact tr (fiber.mk (f a) p)
   end
 
+  definition is_contr_of_is_surjective (f : A → B) (H : is_surjective f) (HA : is_contr A)
+    (HB : is_set B) : is_contr B :=
+  is_contr.mk (f !center) begin intro b, induction H b, exact ap f !is_prop.elim ⬝ p end
+
+  definition is_surjective_of_is_contr [constructor] (f : A → B) (a : A) (H : is_contr B) :
+    is_surjective f :=
+  λb, image.mk a !eq_of_is_contr
+
   definition is_weakly_constant_ap [instance] [H : is_weakly_constant f] (a a' : A) :
     is_weakly_constant (ap f : a = a' → f a = f a') :=
   take p q : a = a',
@@ -276,9 +321,9 @@ namespace function
   definition is_embedding_compose (g : B → C) (f : A → B)
     (H₁ : is_embedding g) (H₂ : is_embedding f) : is_embedding (g ∘ f) :=
   begin
-    intros, apply @(is_equiv.homotopy_closed (ap g ∘ ap f)),
-    { apply is_equiv_compose},
-    symmetry, exact ap_compose g f
+    intros, apply is_equiv.homotopy_closed (ap g ∘ ap f),
+    { symmetry, exact ap_compose g f },
+    { exact is_equiv_compose _ _ _ _ }
   end
 
   definition is_surjective_compose (g : B → C) (f : A → B)
@@ -300,6 +345,95 @@ namespace function
     ⦃a a' : A⦄ (p : g (f a) = g (f a')) : a = a' :=
   H₂ (H₁ p)
 
+  definition is_embedding_pr1 [instance] [constructor] {A : Type} (B : A → Type) [H : Π a, is_prop (B a)]
+      : is_embedding (@pr1 A B) :=
+  λv v', to_is_equiv (sigma_eq_equiv v v' ⬝e sigma_equiv_of_is_contr_right _ _)
+
+  variables {f f'}
+  definition is_embedding_homotopy_closed (p : f ~ f') (H : is_embedding f) : is_embedding f' :=
+  begin
+    intro a a', fapply is_equiv_of_equiv_of_homotopy,
+    exact equiv.mk (ap f) _ ⬝e equiv_eq_closed_left _ (p a) ⬝e equiv_eq_closed_right _ (p a'),
+    intro q, esimp, exact (eq_bot_of_square (transpose (natural_square p q)))⁻¹
+  end
+
+  definition is_embedding_homotopy_closed_rev (p : f' ~ f) (H : is_embedding f) : is_embedding f' :=
+  is_embedding_homotopy_closed p⁻¹ʰᵗʸ H
+
+  definition is_surjective_homotopy_closed (p : f ~ f') (H : is_surjective f) : is_surjective f' :=
+  begin
+    intro b, induction H b with a q,
+    exact image.mk a ((p a)⁻¹ ⬝ q)
+  end
+
+  definition is_surjective_homotopy_closed_rev (p : f' ~ f) (H : is_surjective f) :
+    is_surjective f' :=
+  is_surjective_homotopy_closed p⁻¹ʰᵗʸ H
+
+  definition is_surjective_factor {g : B → C} (f : A → B) (h : A → C) (H : g ∘ f ~ h) :
+    is_surjective h → is_surjective g :=
+  begin
+    induction H using homotopy.rec_on_idp,
+    intro S,
+    intro c,
+    note p := S c,
+    induction p,
+    apply tr,
+    fapply fiber.mk,
+    exact f a,
+    exact p
+  end
+
+  definition is_equiv_ap1_gen_of_is_embedding {A B : Type} (f : A → B) [is_embedding f]
+    {a a' : A} {b b' : B} (q : f a = b) (q' : f a' = b') : is_equiv (ap1_gen f q q') :=
+  begin
+    induction q, induction q',
+    exact is_equiv.homotopy_closed _ (ap1_gen_idp_left f)⁻¹ʰᵗʸ _,
+  end
+
+  definition is_equiv_ap1_of_is_embedding {A B : Type*} (f : A →* B) [is_embedding f] :
+    is_equiv (Ω→ f) :=
+  is_equiv_ap1_gen_of_is_embedding f (respect_pt f) (respect_pt f)
+
+  definition loop_pequiv_loop_of_is_embedding [constructor] {A B : Type*} (f : A →* B)
+    [is_embedding f] : Ω A ≃* Ω B :=
+  pequiv_of_pmap (Ω→ f) (is_equiv_ap1_of_is_embedding f)
+
+  definition loopn_pequiv_loopn_of_is_embedding [constructor] (n : ℕ) [H : is_succ n]
+    {A B : Type*} (f : A →* B) [is_embedding f] : Ω[n] A ≃* Ω[n] B :=
+  begin
+    induction H with n,
+    exact !loopn_succ_in ⬝e*
+      loopn_pequiv_loopn n (loop_pequiv_loop_of_is_embedding f) ⬝e*
+      !loopn_succ_in⁻¹ᵉ*
+  end
+
+  definition is_contr_of_is_embedding (f : A → B) (H : is_embedding f) (HB : is_prop B)
+    (a₀ : A) : is_contr A :=
+  is_contr.mk a₀ (λa, is_injective_of_is_embedding (is_prop.elim (f a₀) (f a)))
+
+  definition is_embedding_of_square {A B C D : Type} {f : A → B} {g : C → D} (h : A ≃ C)
+    (k : B ≃ D) (s : k ∘ f ~ g ∘ h) (Hf : is_embedding f) : is_embedding g :=
+  begin
+    apply is_embedding_homotopy_closed, exact inv_homotopy_of_homotopy_pre _ _ _ s,
+    apply is_embedding_compose, apply is_embedding_compose,
+    apply is_embedding_of_is_equiv, exact Hf, apply is_embedding_of_is_equiv
+  end
+
+  definition is_embedding_of_square_rev {A B C D : Type} {f : A → B} {g : C → D} (h : A ≃ C)
+    (k : B ≃ D) (s : k ∘ f ~ g ∘ h) (Hg : is_embedding g) : is_embedding f :=
+  is_embedding_of_square h⁻¹ᵉ k⁻¹ᵉ s⁻¹ʰᵗʸᵛ Hg
+
+  definition is_embedding_factor [is_set A] [is_set B] (g : B → C) (h : A → C) (H : g ∘ f ~ h) :
+    is_embedding h → is_embedding f :=
+  begin
+    induction H using homotopy.rec_on_idp,
+    intro E,
+    fapply is_embedding_of_is_injective,
+    intro x y p,
+    fapply @is_injective_of_is_embedding _ _ _ E _ _ (ap g p)
+  end
+
   /-
     The definitions
       is_surjective_of_is_equiv

hott/hit/coeq.hlean

@@ -58,7 +58,7 @@ parameters {A B : Type.{u}} (f g : A → B)
   theorem elim_cp {P : Type} (P_i : B → P) (Pcp : Π(x : A), P_i (f x) = P_i (g x))
     (x : A) : ap (elim P_i Pcp) (cp x) = Pcp x :=
   begin
-    apply eq_of_fn_eq_fn_inv !(pathover_constant (cp x)),
+    apply inj_inv !(pathover_constant (cp x)),
     rewrite [▸*,-apd_eq_pathover_of_eq_ap,↑elim,rec_cp],
   end
 

hott/hit/colimit.hlean

@@ -67,7 +67,7 @@ section
     (Pglue : Π(j : J) (x : A (dom j)), Pincl (f j x) = Pincl x)
       {j : J} (x : A (dom j)) : ap (elim Pincl Pglue) (cglue j x) = Pglue j x :=
   begin
-    apply eq_of_fn_eq_fn_inv !(pathover_constant (cglue j x)),
+    apply inj_inv !(pathover_constant (cglue j x)),
     rewrite [▸*,-apd_eq_pathover_of_eq_ap,↑elim,rec_cglue],
   end
 
@@ -157,7 +157,7 @@ section
     (Pglue : Π⦃n : ℕ⦄ (a : A n), Pincl (f a) = Pincl a) {n : ℕ} (a : A n)
       : ap (elim Pincl Pglue) (glue a) = Pglue a :=
   begin
-    apply eq_of_fn_eq_fn_inv !(pathover_constant (glue a)),
+    apply inj_inv !(pathover_constant (glue a)),
     rewrite [▸*,-apd_eq_pathover_of_eq_ap,↑elim,rec_glue],
   end
 

hott/hit/groupoid_quotient.hlean

@@ -145,7 +145,7 @@ section
     (Pcomp : Π⦃a b c⦄ (g : b ⟶ c) (f : a ⟶ b) (x : Pe a), Pp (g ∘ f) x = Pp g (Pp f x))
     {a b : G} (f : a ⟶ b) :
     transport (elim_set Pe Pp Pcomp) (pth f) = Pp f :=
-  by rewrite [tr_eq_cast_ap_fn, ↑elim_set, ▸*, ap_compose' trunctype.carrier, elim_pth];
+  by rewrite [tr_eq_cast_ap_fn, ↑elim_set, ▸*, -ap_compose' trunctype.carrier, elim_pth];
      apply tcast_tua_fn
 
 end
@@ -219,7 +219,7 @@ section
   definition encode_con (p : elt a = elt b)
     (q : elt b = elt c) : encode (elt c) (p ⬝ q) = encode (elt c) q ∘ encode (elt b) p :=
   begin
-    apply eq_of_fn_eq_fn (elt_eq_elt_equiv a c)⁻¹ᵉ,
+    apply inj (elt_eq_elt_equiv a c)⁻¹ᵉ,
     refine !right_inv ⬝ _ ⬝ !decode_comp⁻¹,
     apply concat2, do 2 exact (to_left_inv !elt_eq_elt_equiv _)⁻¹
   end

hott/hit/prop_trunc.hlean

@@ -1,4 +1,4 @@
-import function types.trunc hit.colimit homotopy.connectedness --types.nat.hott hit.trunc cubical.square
+import types.trunc hit.colimit homotopy.connectedness
 
 open eq is_trunc unit quotient seq_colim pi nat equiv sum algebra is_conn function
 
@@ -78,7 +78,7 @@ namespace one_step_tr
     (Pe : Π(a a' : A), Pt a = Pt a') (a a' : A)
     : ap (elim Pt Pe) (tr_eq a a') = Pe a a' :=
   begin
-    apply eq_of_fn_eq_fn_inv !(pathover_constant (tr_eq a a')),
+    apply inj_inv !(pathover_constant (tr_eq a a')),
     rewrite [▸*,-apd_eq_pathover_of_eq_ap,↑elim,rec_tr_eq],
   end
 
@@ -119,7 +119,7 @@ namespace one_step_tr
     { have q : trunc -1 ((tr_eq a a) = idp),
       begin
         refine to_fun !tr_eq_tr_equiv _,
-        refine @is_prop.elim _ _ _ _, apply is_trunc_equiv_closed, apply tr_eq_tr_equiv
+        refine @is_prop.elim _ _ _ _, exact is_trunc_equiv_closed -1 !tr_eq_tr_equiv _
       end,
       refine trunc.elim_on q _, clear q, intro p, exact !tr_eq_ne_idp p},
     { apply is_prop.elim}
@@ -144,7 +144,7 @@ namespace one_step_tr
 
   theorem trunc_0_one_step_tr_equiv (A : Type) : trunc 0 (one_step_tr A) ≃ ∥ A ∥ :=
   begin
-    apply equiv_of_is_prop,
+    refine equiv_of_is_prop _ _ _ _,
     { intro x, refine trunc.rec _ x, clear x, intro x, induction x,
       { exact trunc.tr a},
       { apply is_prop.elim}},
@@ -409,7 +409,7 @@ open prop_trunc trunc
 -- Corollaries for the actual truncation.
 namespace is_trunc
   local attribute is_prop_trunc_one_step_tr [instance]
-  definition is_prop.elim_set {A : Type} {P : Type} [is_set P] (f : A → P)
+  definition prop_trunc.elim_set [unfold 6] {A : Type} {P : Type} [is_set P] (f : A → P)
     (p : Πa a', f a = f a') (x : trunc -1 A) : P :=
   begin
     have y : trunc 0 (one_step_tr A),
@@ -420,8 +420,21 @@ namespace is_trunc
     { exact p a a'}
   end
 
-  definition is_prop.elim_set_tr {A : Type} {P : Type} {H : is_set P} (f : A → P)
-    (p : Πa a', f a = f a') (a : A) : is_prop.elim_set f p (tr a) = f a :=
+  definition prop_trunc.elim_set_tr {A : Type} {P : Type} {H : is_set P} (f : A → P)
+    (p : Πa a', f a = f a') (a : A) : prop_trunc.elim_set f p (tr a) = f a :=
   by reflexivity
 
+  open sigma
+
+  local attribute prop_trunc.elim_set [recursor 6]
+  definition total_image.elim_set [unfold 8]
+    {A B : Type} {f : A → B} {C : Type} [is_set C]
+    (g : A → C) (h : Πa a', f a = f a' → g a = g a') (x : total_image f) : C :=
+  begin
+    induction x with b v,
+    induction v using prop_trunc.elim_set with x x x',
+    { induction x with a p, exact g a },
+    { induction x with a p, induction x' with a' p', induction p', exact h _ _ p }
+  end
+
 end is_trunc

hott/hit/pushout.hlean

@@ -66,7 +66,7 @@ parameters {TL BL TR : Type} (f : TL → BL) (g : TL → TR)
     (Pglue : Π(x : TL), Pinl (f x) = Pinr (g x)) (x : TL)
     : ap (elim Pinl Pinr Pglue) (glue x) = Pglue x :=
   begin
-    apply eq_of_fn_eq_fn_inv !(pathover_constant (glue x)),
+    apply inj_inv !(pathover_constant (glue x)),
     rewrite [▸*,-apd_eq_pathover_of_eq_ap,↑pushout.elim,rec_glue],
   end
 
@@ -112,6 +112,16 @@ namespace pushout
 
   variables {TL BL TR : Type} (f : TL → BL) (g : TL → TR)
 
+  protected theorem elim_inl {P : Type} (Pinl : BL → P) (Pinr : TR → P)
+    (Pglue : Π(x : TL), Pinl (f x) = Pinr (g x)) {b b' : BL} (p : b = b')
+    : ap (pushout.elim Pinl Pinr Pglue) (ap inl p) = ap Pinl p :=
+  !ap_compose⁻¹
+
+  protected theorem elim_inr {P : Type} (Pinl : BL → P) (Pinr : TR → P)
+    (Pglue : Π(x : TL), Pinl (f x) = Pinr (g x)) {b b' : TR} (p : b = b')
+    : ap (pushout.elim Pinl Pinr Pglue) (ap inr p) = ap Pinr p :=
+  !ap_compose⁻¹
+
   /- The non-dependent universal property -/
   definition pushout_arrow_equiv (C : Type)
     : (pushout f g → C) ≃ (Σ(i : BL → C) (j : TR → C), Πc, i (f c) = j (g c)) :=
@@ -174,7 +184,7 @@ namespace pushout
         { apply ap inl, reflexivity },
         { apply ap inr, reflexivity },
         { unfold F, unfold G, apply eq_pathover,
-          rewrite [ap_id,ap_compose' (quotient.elim _ _)],
+          rewrite [ap_id,-ap_compose' (quotient.elim _ _)],
           krewrite elim_glue, krewrite elim_eq_of_rel, apply hrefl } },
       { intro q, induction q with z z z' fr,
         { induction z with a p, induction a with x x,
@@ -182,7 +192,7 @@ namespace pushout
           { reflexivity } },
         { induction fr with a a' r p, induction r with x,
           esimp, apply eq_pathover,
-          rewrite [ap_id,ap_compose' (pushout.elim _ _ _)],
+          rewrite [ap_id,-ap_compose' (pushout.elim _ _ _)],
           krewrite elim_eq_of_rel, krewrite elim_glue, apply hrefl } }
     end
   end
@@ -206,7 +216,7 @@ namespace pushout
       krewrite [elim_glue, ap_inv, elim_glue, inv_inv], apply hrfl
   end
 
-  protected definition symm : pushout f g ≃ pushout g f :=
+  protected definition symm [constructor] : pushout f g ≃ pushout g f :=
   begin
     fapply equiv.MK, do 2 exact !pushout.transpose,
     do 2 (intro x; apply pushout.transpose_involutive),
@@ -234,7 +244,7 @@ namespace pushout
               (fh : bl ∘ f ~ f' ∘ tl) (gh : tr ∘ g ~ g' ∘ tl)
     include fh gh
 
-    protected definition functor [reducible] : pushout f g → pushout f' g' :=
+    protected definition functor [unfold 16] : pushout f g → pushout f' g' :=
     begin
       intro x, induction x with a b z,
       { exact inl (bl a) },
@@ -254,7 +264,7 @@ namespace pushout
     include ietl iebl ietr
 
     open equiv is_equiv arrow
-    protected definition is_equiv_functor [instance]
+    protected definition is_equiv_functor [instance] [constructor]
       : is_equiv (pushout.functor tl bl tr fh gh) :=
     adjointify
       (pushout.functor tl bl tr fh gh)
@@ -266,7 +276,7 @@ namespace pushout
       { apply ap inl, apply right_inv },
       { apply ap inr, apply right_inv },
       { apply eq_pathover,
-        rewrite [ap_id,ap_compose' (pushout.functor tl bl tr fh gh)],
+        rewrite [ap_id,-ap_compose' (pushout.functor tl bl tr fh gh)],
         krewrite elim_glue,
         rewrite [ap_inv,ap_con,ap_inv],
         krewrite [pushout.ap_functor_inr], rewrite ap_con,
@@ -297,7 +307,7 @@ namespace pushout
       { apply ap inl, apply left_inv },
       { apply ap inr, apply left_inv },
       { apply eq_pathover,
-        rewrite [ap_id,ap_compose'
+        rewrite [ap_id,-ap_compose'
           (pushout.functor tl⁻¹ bl⁻¹ tr⁻¹ _ _)
           (pushout.functor tl bl tr _ _)],
         krewrite elim_glue,
@@ -336,7 +346,7 @@ namespace pushout
               (fh : bl ∘ f ~ f' ∘ tl) (gh : tr ∘ g ~ g' ∘ tl)
     include fh gh
 
-    protected definition equiv : pushout f g ≃ pushout f' g' :=
+    protected definition equiv [constructor] : pushout f g ≃ pushout f' g' :=
     equiv.mk (pushout.functor tl bl tr fh gh) _
   end
 

hott/hit/quotient.hlean

@@ -34,7 +34,7 @@ namespace quotient
     (Pp : Π⦃a a' : A⦄ (H : R a a'), Pc a = Pc a') {a a' : A} (H : R a a')
     : ap (quotient.elim Pc Pp) (eq_of_rel R H) = Pp H :=
   begin
-    apply eq_of_fn_eq_fn_inv !(pathover_constant (eq_of_rel R H)),
+    apply inj_inv !(pathover_constant (eq_of_rel R H)),
     rewrite [▸*,-apd_eq_pathover_of_eq_ap,↑quotient.elim,rec_eq_of_rel],
   end
 
@@ -148,7 +148,7 @@ namespace quotient
       induction v with q p,
       induction q,
       { exact Qpt p},
-      { apply pi_pathover_left', esimp, intro c,
+      { apply pi_pathover_left, esimp, intro c,
         refine _ ⬝op apdt Qpt (elim_type_eq_of_rel C f H c)⁻¹ᵖ,
         refine _ ⬝op (tr_compose Q Ppt _ _)⁻¹ ,
         rewrite ap_inv,
@@ -212,96 +212,68 @@ namespace quotient
   end flattening
 
   section
-  open is_equiv equiv prod prod.ops
-  variables {A : Type} (R : A → A → Type)
-             {B : Type} (Q : B → B → Type)
+  open is_equiv equiv prod function
+  variables {A : Type} {R : A → A → Type}
+            {B : Type} {Q : B → B → Type}
+            {C : Type} {S : C → C → Type}
             (f : A → B) (k : Πa a' : A, R a a' → Q (f a) (f a'))
-  include f k
+            (g : B → C) (l : Πb b' : B, Q b b' → S (g b) (g b'))
 
-  protected definition functor [reducible] : quotient R → quotient Q :=
+  protected definition functor : quotient R → quotient Q :=
   quotient.elim (λa, class_of Q (f a)) (λa a' r, eq_of_rel Q (k a a' r))
 
+  definition functor_class_of (a : A) :
+    quotient.functor f k (class_of R a) = class_of Q (f a) :=
+  by reflexivity
+
+  definition functor_eq_of_rel {a a' : A} (r : R a a') :
+    ap (quotient.functor f k) (eq_of_rel R r) = eq_of_rel Q (k a a' r) :=
+  elim_eq_of_rel _ _ r
+
+  protected definition functor_compose :
+    quotient.functor (g ∘ f) (λa a' r, l (f a) (f a') (k a a' r)) ~
+    quotient.functor g l ∘ quotient.functor f k :=
+  begin
+    intro x, induction x,
+    { reflexivity },
+    { apply eq_pathover, refine hdeg_square _ ⬝hp (ap_compose (quotient.functor g l) _ _)⁻¹,
+      refine !functor_eq_of_rel ⬝ !functor_eq_of_rel⁻¹ ⬝ ap02 _ !functor_eq_of_rel⁻¹ }
+  end
+
+  protected definition functor_homotopy {f f' : A → B} {k : Πa a' : A, R a a' → Q (f a) (f a')}
+    {k' : Πa a' : A, R a a' → Q (f' a) (f' a')} (h : f ~ f')
+    (h2 : Π(a a' : A) (r : R a a'), transport11 Q (h a) (h a') (k a a' r) = k' a a' r) :
+    quotient.functor f k ~ quotient.functor f' k' :=
+  begin
+    intro x, induction x with a a a' r,
+    { exact ap (class_of Q) (h a) },
+    { apply eq_pathover, refine !functor_eq_of_rel ⬝ph _ ⬝hp !functor_eq_of_rel⁻¹,
+      apply transpose, apply natural_square2 (eq_of_rel Q), apply h2 }
+  end
+
+  protected definition functor_id (x : quotient R) :
+    quotient.functor id (λa a' r, r) x = x :=
+  begin
+    induction x,
+    { reflexivity },
+    { apply eq_pathover_id_right, apply hdeg_square, apply functor_eq_of_rel }
+  end
+
   variables [F : is_equiv f] [K : Πa a', is_equiv (k a a')]
   include F K
 
-  protected definition functor_inv [reducible] : quotient Q → quotient R :=
-  quotient.elim (λb, class_of R (f⁻¹ b))
-                (λb b' q, eq_of_rel R ((k (f⁻¹ b) (f⁻¹ b'))⁻¹
-                          ((right_inv f b)⁻¹ ▸ (right_inv f b')⁻¹ ▸ q)))
-
-  protected definition is_equiv [instance]
-    : is_equiv (quotient.functor R Q f k):=
+  protected definition is_equiv [instance] : is_equiv (quotient.functor f k) :=
   begin
-    fapply adjointify _ (quotient.functor_inv R Q f k),
-    { intro qb, induction qb with b b b' q,
-      { apply ap (class_of Q), apply right_inv },
-      { apply eq_pathover, rewrite [ap_id,ap_compose' (quotient.elim _ _)],
-        do 2 krewrite elim_eq_of_rel, rewrite (right_inv (k (f⁻¹ b) (f⁻¹ b'))),
-        have H1 : pathover (λz : B × B, Q z.1 z.2)
-          ((right_inv f b)⁻¹ ▸ (right_inv f b')⁻¹ ▸ q)
-          (prod_eq (right_inv f b) (right_inv f b')) q,
-        begin apply pathover_of_eq_tr, krewrite [prod_eq_inv,prod_eq_transport] end,
-        have H2 : square
-          (ap (λx : (Σz : B × B, Q z.1 z.2), class_of Q x.1.1)
-            (sigma_eq (prod_eq (right_inv f b) (right_inv f b')) H1))
-          (ap (λx : (Σz : B × B, Q z.1 z.2), class_of Q x.1.2)
-            (sigma_eq (prod_eq (right_inv f b) (right_inv f b')) H1))
-          (eq_of_rel Q ((right_inv f b)⁻¹ ▸ (right_inv f b')⁻¹ ▸ q))
-          (eq_of_rel Q q),
-        from
-          natural_square_tr (λw : (Σz : B × B, Q z.1 z.2), eq_of_rel Q w.2)
-          (sigma_eq (prod_eq (right_inv f b) (right_inv f b')) H1),
-        krewrite (ap_compose' (class_of Q)) at H2,
-        krewrite (ap_compose' (λz : B × B, z.1)) at H2,
-        rewrite sigma.ap_pr1 at H2, rewrite sigma_eq_pr1 at H2,
-        krewrite prod.ap_pr1 at H2, krewrite prod_eq_pr1 at H2,
-        krewrite (ap_compose' (class_of Q) (λx : (Σz : B × B, Q z.1 z.2), x.1.2)) at H2,
-        krewrite (ap_compose' (λz : B × B, z.2)) at H2,
-        rewrite sigma.ap_pr1 at H2, rewrite sigma_eq_pr1 at H2,
-        krewrite prod.ap_pr2 at H2, krewrite prod_eq_pr2 at H2,
-        apply H2 } },
-    { intro qa, induction qa with a a a' r,
-      { apply ap (class_of R), apply left_inv },
-      { apply eq_pathover, rewrite [ap_id,(ap_compose' (quotient.elim _ _))],
-        do 2 krewrite elim_eq_of_rel,
-        have H1 : pathover (λz : A × A, R z.1 z.2)
-          ((left_inv f a)⁻¹ ▸ (left_inv f a')⁻¹ ▸ r)
-          (prod_eq (left_inv f a) (left_inv f a')) r,
-        begin apply pathover_of_eq_tr, krewrite [prod_eq_inv,prod_eq_transport] end,
-        have H2 : square
-          (ap (λx : (Σz : A × A, R z.1 z.2), class_of R x.1.1)
-            (sigma_eq (prod_eq (left_inv f a) (left_inv f a')) H1))
-          (ap (λx : (Σz : A × A, R z.1 z.2), class_of R x.1.2)
-            (sigma_eq (prod_eq (left_inv f a) (left_inv f a')) H1))
-          (eq_of_rel R ((left_inv f a)⁻¹ ▸ (left_inv f a')⁻¹ ▸ r))
-          (eq_of_rel R r),
-        begin
-          exact
-          natural_square_tr (λw : (Σz : A × A, R z.1 z.2), eq_of_rel R w.2)
-          (sigma_eq (prod_eq (left_inv f a) (left_inv f a')) H1)
-        end,
-        krewrite (ap_compose' (class_of R)) at H2,
-        krewrite (ap_compose' (λz : A × A, z.1)) at H2,
-        rewrite sigma.ap_pr1 at H2, rewrite sigma_eq_pr1 at H2,
-        krewrite prod.ap_pr1 at H2, krewrite prod_eq_pr1 at H2,
-        krewrite (ap_compose' (class_of R) (λx : (Σz : A × A, R z.1 z.2), x.1.2)) at H2,
-        krewrite (ap_compose' (λz : A × A, z.2)) at H2,
-        rewrite sigma.ap_pr1 at H2, rewrite sigma_eq_pr1 at H2,
-        krewrite prod.ap_pr2 at H2, krewrite prod_eq_pr2 at H2,
-        have H3 :
-          (k (f⁻¹ (f a)) (f⁻¹ (f a')))⁻¹
-          ((right_inv f (f a))⁻¹ ▸ (right_inv f (f a'))⁻¹ ▸ k a a' r)
-          = (left_inv f a)⁻¹ ▸ (left_inv f a')⁻¹ ▸ r,
-        begin
-          rewrite [adj f a,adj f a',ap_inv',ap_inv'],
-          rewrite [-(tr_compose _ f (left_inv f a')⁻¹ (k a a' r)),
-                   -(tr_compose _ f (left_inv f a)⁻¹)],
-          rewrite [-(fn_tr_eq_tr_fn (left_inv f a')⁻¹ (λx, k a x) r),
-                   -(fn_tr_eq_tr_fn (left_inv f a)⁻¹
-                     (λx, k x (f⁻¹ (f a')))),
-                   left_inv (k _ _)]
-        end,
-        rewrite H3, apply H2 } }
+    apply adjointify _ (quotient.functor f⁻¹ᶠ
+      (λb b' q, (k (f⁻¹ᶠ b) (f⁻¹ᶠ b'))⁻¹ᶠ (transport11 Q (right_inv f b)⁻¹ (right_inv f b')⁻¹ q))),
+    exact abstract begin intro x, refine (quotient.functor_compose _ _ _ _ x)⁻¹ ⬝ _ ⬝ quotient.functor_id x,
+      apply quotient.functor_homotopy (right_inv f), intros a a' r,
+      rewrite [right_inv (k _ _), -transport11_con, con.left_inv, con.left_inv] end end,
+    exact abstract begin intro x, refine (quotient.functor_compose _ _ _ _ x)⁻¹ ⬝ _ ⬝ quotient.functor_id x,
+      apply quotient.functor_homotopy (left_inv f), intros a a' r,
+      rewrite [adj f, adj f, -ap_inv, -ap_inv, transport11_ap,
+           -fn_transport11_eq_transport11_fn _ _ _ _ k, left_inv (k _ _), -transport11_con,
+           con.left_inv, con.left_inv] end end
   end
 end
 
@@ -313,7 +285,7 @@ section
 
   /- This could also be proved using ua, but then it wouldn't compute -/
   protected definition equiv : quotient R ≃ quotient Q :=
-  equiv.mk (quotient.functor R Q f k) _
+  equiv.mk (quotient.functor f k) _
 end
 
 

hott/hit/set_quotient.hlean

@@ -8,7 +8,7 @@ Declaration of set-quotients, i.e. quotient of a mere relation which is then set
 
 import function algebra.relation types.trunc types.eq hit.quotient
 
-open eq is_trunc trunc quotient equiv
+open eq is_trunc trunc quotient equiv is_equiv
 
 namespace set_quotient
 section
@@ -59,7 +59,7 @@ section
     (Pp : Π⦃a a' : A⦄ (H : R a a'), Pc a = Pc a') {a a' : A} (H : R a a')
     : ap (elim Pc Pp) (eq_of_rel H) = Pp H :=
   begin
-    apply eq_of_fn_eq_fn_inv !(pathover_constant (eq_of_rel H)),
+    apply inj_inv !(pathover_constant (eq_of_rel H)),
     rewrite [▸*,-apd_eq_pathover_of_eq_ap,↑elim,rec_eq_of_rel],
   end
 
@@ -86,6 +86,36 @@ namespace set_quotient
   definition is_surjective_class_of : is_surjective (class_of : A → set_quotient R) :=
   λx, set_quotient.rec_on x (λa, tr (fiber.mk a idp)) (λa a' r, !is_prop.elimo)
 
+  definition is_prop_set_quotient {A : Type} (R : A → A → Prop) [is_prop A] :
+    is_prop (set_quotient R) :=
+  begin
+    apply is_prop.mk, intro x y,
+    induction x using set_quotient.rec_prop, induction y using set_quotient.rec_prop,
+    exact ap class_of !is_prop.elim
+  end
+
+  local attribute is_prop_set_quotient [instance]
+  definition is_trunc_set_quotient [instance] (n : ℕ₋₂) {A : Type} (R : A → A → Prop) [is_trunc n A] :
+    is_trunc n (set_quotient R) :=
+  begin
+    cases n with n, { refine is_contr_of_inhabited_prop _ _, exact class_of !center },
+    cases n with n, { apply _ },
+    exact is_trunc_succ_succ_of_is_set _ _ _
+  end
+
+  definition is_equiv_class_of [constructor] {A : Type} [is_set A] (R : A → A → Prop)
+    (p : Π⦃a b⦄, R a b → a = b) : is_equiv (@class_of A R) :=
+  begin
+    fapply adjointify,
+    { intro x, induction x, exact a, exact p H },
+    { intro x, induction x using set_quotient.rec_prop, reflexivity },
+    { intro a, reflexivity }
+  end
+
+  definition equiv_set_quotient [constructor] {A : Type} [is_set A] (R : A → A → Prop)
+    (p : Π⦃a b⦄, R a b → a = b) : A ≃ set_quotient R :=
+  equiv.mk _ (is_equiv_class_of R p)
+
   /- non-dependent universal property -/
 
   definition set_quotient_arrow_equiv (B : Type) [H : is_set B] :
@@ -105,10 +135,8 @@ namespace set_quotient
     : Prop :=
   set_quotient.elim_on x (R a)
     begin
-      intros a' a'' H1,
-      refine to_inv !trunctype_eq_equiv _, esimp,
-      apply ua,
-      apply equiv_of_is_prop,
+      intros a' a'' H1, apply tua,
+      refine equiv_of_is_prop _ _ _ _,
       { intro H2, exact is_transitive.trans R H2 H1},
       { intro H2, apply is_transitive.trans R H2, exact is_symmetric.symm R H1}
     end

hott/hit/trunc.hlean

@@ -36,11 +36,11 @@ namespace trunc
 
   local attribute is_trunc_eq [instance]
 
-  variables {A n}
+  variables {n A}
   definition untrunc_of_is_trunc [reducible] [unfold 4] [H : is_trunc n A] : trunc n A → A :=
   trunc.rec id
 
-  variables (A n)
+  variables (n A)
   definition is_equiv_tr [instance] [constructor] [H : is_trunc n A] : is_equiv (@tr n A) :=
   adjointify _
              (untrunc_of_is_trunc)
@@ -51,7 +51,7 @@ namespace trunc
   (equiv.mk tr _)⁻¹ᵉ
 
   definition is_trunc_of_is_equiv_tr [H : is_equiv (@tr n A)] : is_trunc n A :=
-  is_trunc_is_equiv_closed n (@tr n _)⁻¹
+  is_trunc_is_equiv_closed n (@tr n _)⁻¹ᶠ _ _
 
   /- Functoriality -/
   definition trunc_functor [unfold 5] (f : X → Y) : trunc n X → trunc n Y :=
@@ -71,7 +71,7 @@ namespace trunc
     exact fn_tr_eq_tr_fn p (λy, tr) x ⬝ !tr_compose
   end
 
-  definition is_equiv_trunc_functor [constructor] (f : X → Y) [H : is_equiv f]
+  definition is_equiv_trunc_functor [constructor] (f : X → Y) (H : is_equiv f)
     : is_equiv (trunc_functor n f) :=
   adjointify _
              (trunc_functor n f⁻¹)
@@ -83,7 +83,7 @@ namespace trunc
 
   section
     definition trunc_equiv_trunc [constructor] (f : X ≃ Y) : trunc n X ≃ trunc n Y :=
-    equiv.mk _ (is_equiv_trunc_functor n f)
+    equiv.mk _ (is_equiv_trunc_functor n f _)
   end
 
   section
@@ -126,8 +126,12 @@ namespace trunc
   definition or.intro_left  [reducible] [constructor] (x : X) : X ∨ Y             := tr (inl x)
   definition or.intro_right [reducible] [constructor] (y : Y) : X ∨ Y             := tr (inr y)
 
+  definition exists.elim {A : Type} {p : A → Type} {B : Type} [is_prop B] (H : Exists p)
+    (H' : ∀ (a : A), p a → B) : B :=
+  trunc.elim (sigma.rec H') H
+
   definition is_contr_of_merely_prop [H : is_prop A] (aa : merely A) : is_contr A :=
-  is_contr_of_inhabited_prop (trunc.rec_on aa id)
+  is_contr_of_inhabited_prop (trunc.rec_on aa id) _
 
   section
   open sigma.ops

hott/hit/two_quotient.hlean

@@ -5,7 +5,7 @@ Released under Apache 2.0 license as described in the file LICENSE.
 Authors: Floris van Doorn
 -/
 
-import homotopy.circle eq2 algebra.e_closure cubical.squareover cubical.cube cubical.square2
+import homotopy.circle eq2 algebra.e_closure cubical.squareover cubical.cube
 
 open quotient eq circle sum sigma equiv function relation e_closure
 
@@ -92,7 +92,7 @@ namespace simple_two_quotient
     (Pe : Π⦃a a' : A⦄ (s : R a a'), Pj a = Pj a') ⦃a a' : A⦄ (s : R a a')
     : ap (pre_elim Pj Pa Pe) (e s) = Pe s :=
   begin
-    apply eq_of_fn_eq_fn_inv !(pathover_constant (e s)),
+    apply inj_inv !(pathover_constant (e s)),
     rewrite [▸*,-apd_eq_pathover_of_eq_ap,↑pre_elim,rec_e],
   end
 

hott/homotopy/EM.hlean

@@ -129,60 +129,56 @@ namespace EM
   is_conn_EM1' G
 
   variable {G}
-  definition EM1_map [unfold 7] {X : Type*} (e : G → Ω X)
-    (r : Πg h, e (g * h) = e g ⬝ e h) [is_conn 0 X] [is_trunc 1 X] : EM1 G → X :=
+  open infgroup
+  definition EM1_map [unfold 6] {G : Group} {X : Type*} (e : G →∞g Ωg X) [is_trunc 1 X] :
+    EM1 G → X :=
   begin
     intro x, induction x using EM.elim,
     { exact Point X },
     { exact e g },
-    { exact r g h }
+    { exact to_respect_mul_inf e g h }
   end
 
   /- Uniqueness of K(G, 1) -/
 
-  definition EM1_pmap [constructor] {X : Type*} (e : G → Ω X)
-    (r : Πg h, e (g * h) = e g ⬝ e h) [is_conn 0 X] [is_trunc 1 X] : EM1 G →* X :=
-  pmap.mk (EM1_map e r) idp
+  definition EM1_pmap [constructor] {G : Group} {X : Type*} (e : G →∞g Ωg X) [is_trunc 1 X] :
+    EM1 G →* X :=
+  pmap.mk (EM1_map e) idp
 
   variable (G)
   definition loop_EM1 [constructor] : G ≃* Ω (EM1 G) :=
   (pequiv_of_equiv (base_eq_base_equiv G) idp)⁻¹ᵉ*
 
   variable {G}
-  definition loop_EM1_pmap {X : Type*} (e : G →* Ω X)
-    (r : Πg h, e (g * h) = e g ⬝ e h) [is_conn 0 X] [is_trunc 1 X] :
-    Ω→(EM1_pmap e r) ∘* loop_EM1 G ~* e :=
+  definition loop_EM1_pmap {G : Group} {X : Type*} (e : G →∞g Ωg X) [is_trunc 1 X] :
+    Ω→(EM1_pmap e) ∘* loop_EM1 G ~* pmap_of_inf_homomorphism e :=
   begin
     fapply phomotopy.mk,
-    { intro g, refine !idp_con ⬝ elim_pth r g },
+    { intro g, refine !idp_con ⬝ elim_pth (to_respect_mul_inf e) g },
     { apply is_set.elim }
   end
 
-  definition EM1_pequiv'.{u} {G : Group.{u}} {X : pType.{u}} (e : G ≃* Ω X)
-    (r : Πg h, e (g * h) = e g ⬝ e h) [is_conn 0 X] [is_trunc 1 X] : EM1 G ≃* X :=
+  definition EM1_pequiv'.{u} {G : Group.{u}} {X : pType.{u}} (e : G ≃∞g Ωg X)
+    [is_conn 0 X] [is_trunc 1 X] : EM1 G ≃* X :=
   begin
-    apply pequiv_of_pmap (EM1_pmap e r),
+    apply pequiv_of_pmap (EM1_pmap e),
     apply whitehead_principle_pointed 1,
     intro k, cases k with k,
     { apply @is_equiv_of_is_contr,
       all_goals (esimp; exact _)},
     { cases k with k,
       { apply is_equiv_trunc_functor, esimp,
-        apply is_equiv.homotopy_closed, rotate 1,
-        { symmetry, exact phomotopy_pinv_right_of_phomotopy (loop_EM1_pmap _ _) },
-        apply is_equiv_compose e },
+        apply is_equiv.homotopy_closed,
+        { symmetry, exact phomotopy_pinv_right_of_phomotopy (loop_EM1_pmap e) },
+        refine is_equiv_compose e _ _ _, apply inf_isomorphism.is_equiv_to_hom },
       { apply @is_equiv_of_is_contr,
         do 2 exact trivial_homotopy_group_of_is_trunc _ (succ_lt_succ !zero_lt_succ)}}
   end
 
   definition EM1_pequiv.{u} {G : Group.{u}} {X : pType.{u}} (e : G ≃g π₁ X)
     [is_conn 0 X] [is_trunc 1 X] : EM1 G ≃* X :=
-  begin
-    apply EM1_pequiv' (pequiv_of_isomorphism e ⬝e* ptrunc_pequiv 0 (Ω X)),
-    refine is_equiv.preserve_binary_of_inv_preserve _ mul concat _,
-    intro p q,
-    exact to_respect_mul e⁻¹ᵍ (tr p) (tr q)
-  end
+  have is_set (Ωg X), from !is_trunc_loop,
+  EM1_pequiv' (inf_isomorphism_of_isomorphism e ⬝∞g gtrunc_isomorphism (Ωg X))
 
   definition EM1_pequiv_type (X : Type*) [is_conn 0 X] [is_trunc 1 X] : EM1 (π₁ X) ≃* X :=
   EM1_pequiv !isomorphism.refl
@@ -226,10 +222,10 @@ namespace EM
   /- K(G, n+1) -/
   definition EMadd1 : ℕ → Type*
   | 0 := EM1 G
-  | (n+1) := ptrunc (n+2) (psusp (EMadd1 n))
+  | (n+1) := ptrunc (n+2) (susp (EMadd1 n))
 
   definition EMadd1_succ [unfold_full] (n : ℕ) :
-    EMadd1 G (succ n) = ptrunc (n.+2) (psusp (EMadd1 G n)) :=
+    EMadd1 G (succ n) = ptrunc (n.+2) (susp (EMadd1 G n)) :=
   idp
 
   definition loop_EM2 : Ω[1] (EMadd1 G 1) ≃* EM1 G :=
@@ -239,7 +235,7 @@ namespace EM
   begin
     induction n with n IH,
     { apply is_conn_EM1 },
-    { rewrite EMadd1_succ, esimp, exact _ }
+    { rewrite EMadd1_succ, exact _ }
   end
 
   definition is_trunc_EMadd1 [instance] (n : ℕ) : is_trunc (n+1) (EMadd1 G n) :=
@@ -257,7 +253,7 @@ namespace EM
     { rewrite [EMadd1_succ G (succ n)],
       refine (ptrunc_pequiv (succ n + 1) _)⁻¹ᵉ*  ⬝e* _ ⬝e* (loop_ptrunc_pequiv _ _)⁻¹ᵉ*,
       have succ n + 1 ≤ 2 * succ n, from add_mul_le_mul_add n 1 1,
-      refine freudenthal_pequiv _ this }
+      refine freudenthal_pequiv this _ }
   end
 
   definition loopn_EMadd1_pequiv_EM1 (G : AbGroup) (n : ℕ) : EM1 G ≃* Ω[n] (EMadd1 G n) :=
@@ -283,40 +279,30 @@ namespace EM
     !loopn_succ_in⁻¹ᵉ* ∘* apn (succ n) !loop_EMadd1 ∘* loopn_EMadd1 G n :=
   by reflexivity
 
-  definition EM_up {G : AbGroup} {X : Type*} {n : ℕ} (e : Ω[succ (succ n)] X ≃* G)
-    : Ω[succ n] (Ω X) ≃* G :=
-  !loopn_succ_in⁻¹ᵉ* ⬝e* e
-
-  definition is_homomorphism_EM_up {G : AbGroup} {X : Type*} {n : ℕ}
-    (e : Ω[succ (succ n)] X ≃* G)
-    (r : Π(p q : Ω[succ (succ n)] X), e (p ⬝ q) = e p * e q)
-    (p q : Ω[succ n] (Ω X)) : EM_up e (p ⬝ q) = EM_up e p * EM_up e q :=
-  begin
-    refine _ ⬝ !r, apply ap e, esimp, apply apn_con
-  end
+  definition EM_up {G : AbGroup} {X : Type*} {n : ℕ}
+    (e : AbInfGroup_of_AbGroup G →∞g Ωg[succ (succ n)] X) :
+    AbInfGroup_of_AbGroup G →∞g Ωg[succ n] (Ω X) :=
+  gloopn_succ_in (succ n) X ∘∞g e
 
   definition EMadd1_pmap [unfold 8] {G : AbGroup} {X : Type*} (n : ℕ)
-    (e : Ω[succ n] X ≃* G)
-    (r : Πp q, e (p ⬝ q) = e p * e q)
-    [H1 : is_conn n X] [H2 : is_trunc (n.+1) X] : EMadd1 G n →* X :=
+    (e : AbInfGroup_of_AbGroup G →∞g Ωg[succ n] X) [H : is_trunc (n.+1) X] : EMadd1 G n →* X :=
   begin
-    revert X e r H1 H2, induction n with n f: intro X e r H1 H2,
-    { exact EM1_pmap e⁻¹ᵉ* (equiv.inv_preserve_binary e concat mul r) },
+    revert X e H, induction n with n f: intro X e H,
+    { exact EM1_pmap e },
     rewrite [EMadd1_succ],
-    exact ptrunc.elim ((succ n).+1)
-            (psusp.elim (f _ (EM_up e) (is_homomorphism_EM_up e r) _ _)),
+    apply ptrunc.elim ((succ n).+1),
+    apply susp_elim,
+    exact f _ (EM_up e) _
   end
 
-  definition EMadd1_pmap_succ {G : AbGroup} {X : Type*} (n : ℕ) (e : Ω[succ (succ n)] X ≃* G)
-    r [H1 : is_conn (succ n) X] [H2 : is_trunc ((succ n).+1) X] : EMadd1_pmap (succ n) e r =
-    ptrunc.elim ((succ n).+1) (psusp.elim (EMadd1_pmap n (EM_up e) (is_homomorphism_EM_up e r))) :=
+  definition EMadd1_pmap_succ {G : AbGroup} {X : Type*} (n : ℕ)
+    (e : AbInfGroup_of_AbGroup G →∞g Ωg[succ (succ n)] X) [H2 : is_trunc ((succ n).+1) X] :
+    EMadd1_pmap (succ n) e = ptrunc.elim ((succ n).+1) (susp_elim (EMadd1_pmap n (EM_up e))) :=
   by reflexivity
 
-  definition loop_EMadd1_pmap {G : AbGroup} {X : Type*} {n : ℕ} (e : Ω[succ (succ n)] X ≃* G)
-    (r : Πp q, e (p ⬝ q) = e p * e q)
-    [H1 : is_conn (succ n) X] [H2 : is_trunc ((succ n).+1) X] :
-    Ω→(EMadd1_pmap (succ n) e r) ∘* loop_EMadd1 G n ~*
-    EMadd1_pmap n (EM_up e) (is_homomorphism_EM_up e r) :=
+  definition loop_EMadd1_pmap {G : AbGroup} {X : Type*} {n : ℕ}
+    (e : AbInfGroup_of_AbGroup G →∞g Ωg[succ (succ n)] X) [H : is_trunc ((succ n).+1) X] :
+    Ω→(EMadd1_pmap (succ n) e) ∘* loop_EMadd1 G n ~* EMadd1_pmap n (EM_up e) :=
   begin
     cases n with n,
     { apply hopf_delooping_elim },
@@ -329,28 +315,28 @@ namespace EM
       reflexivity }
   end
 
-  definition loopn_EMadd1_pmap' {G : AbGroup} {X : Type*} {n : ℕ} (e : Ω[succ n] X ≃* G)
-    (r : Πp q, e (p ⬝ q) = e p * e q)
-    [H1 : is_conn n X] [H2 : is_trunc (n.+1) X] :
-    Ω→[succ n](EMadd1_pmap n e r) ∘* loopn_EMadd1 G n ~* e⁻¹ᵉ* :=
+  definition loopn_EMadd1_pmap' {G : AbGroup} {X : Type*} {n : ℕ}
+    (e : AbInfGroup_of_AbGroup G →∞g Ωg[succ n] X) [H : is_trunc (n.+1) X] :
+    Ω→[succ n](EMadd1_pmap n e) ∘* loopn_EMadd1 G n ~* pmap_of_inf_homomorphism e :=
   begin
-    revert X e r H1 H2, induction n with n IH: intro X e r H1 H2,
+    revert X e H, induction n with n IH: intro X e H,
     { apply loop_EM1_pmap },
     refine pwhisker_left _ !loopn_EMadd1_succ ⬝* _,
     refine !passoc⁻¹* ⬝* _,
     refine pwhisker_right _ !loopn_succ_in_inv_natural ⬝* _,
     refine !passoc ⬝* _,
     refine pwhisker_left _ (!passoc⁻¹* ⬝*
-             pwhisker_right _ (!apn_pcompose⁻¹* ⬝* apn_phomotopy _ !loop_EMadd1_pmap) ⬝*
-             !IH ⬝* !pinv_trans_pinv_left) ⬝* _,
-    apply pinv_pcompose_cancel_left
+             pwhisker_right _ (!apn_pcompose⁻¹* ⬝* apn_phomotopy _ !loop_EMadd1_pmap) ⬝* !IH) ⬝* _,
+    refine _ ⬝* pinv_pcompose_cancel_left !loopn_succ_in (pmap_of_inf_homomorphism e),
+    apply pwhisker_left,
+    apply phomotopy_of_homotopy, reflexivity, intro g, apply is_set_loopn,
   end
 
-  definition EMadd1_pequiv' {G : AbGroup} {X : Type*} (n : ℕ) (e : Ω[succ n] X ≃* G)
-    (r : Π(p q : Ω[succ n] X), e (p ⬝ q) = e p * e q)
-    [H1 : is_conn n X] [H2 : is_trunc (n.+1) X] : EMadd1 G n ≃* X :=
+  definition EMadd1_pequiv' {G : AbGroup} {X : Type*} (n : ℕ)
+    (e : AbInfGroup_of_AbGroup G ≃∞g Ωg[succ n] X) [H1 : is_conn n X] [H2 : is_trunc (n.+1) X] :
+    EMadd1 G n ≃* X :=
   begin
-    apply pequiv_of_pmap (EMadd1_pmap n e r),
+    apply pequiv_of_pmap (EMadd1_pmap n e),
     have is_conn 0 (EMadd1 G n), from is_conn_of_le _ (zero_le_of_nat n),
     have is_trunc (n.+1) (EMadd1 G n), from !is_trunc_EMadd1,
     refine whitehead_principle_pointed (n.+1) _ _,
@@ -358,22 +344,22 @@ namespace EM
     { apply @is_equiv_of_is_contr,
       do 2 exact trivial_homotopy_group_of_is_conn _ (le_of_lt_succ H)},
     { cases H, esimp, apply is_equiv_trunc_functor, esimp,
-      apply is_equiv.homotopy_closed, rotate 1,
-      { symmetry, exact phomotopy_pinv_right_of_phomotopy (loopn_EMadd1_pmap' _ _) },
-      apply is_equiv_compose (e⁻¹ᵉ*)},
+      apply is_equiv.homotopy_closed,
+      { symmetry, exact phomotopy_pinv_right_of_phomotopy (loopn_EMadd1_pmap' _) },
+      refine is_equiv_compose e _ _ _, apply inf_isomorphism.is_equiv_to_hom },
     { apply @is_equiv_of_is_contr,
       do 2 exact trivial_homotopy_group_of_is_trunc _ H}
   end
 
-  definition EMadd1_pequiv {G : AbGroup} {X : Type*} (n : ℕ) (e : πg[n+1] X ≃g G)
+  definition EMadd1_pequiv {G : AbGroup} {X : Type*} (n : ℕ) (e : G ≃g πg[n+1] X)
     [H1 : is_conn n X] [H2 : is_trunc (n.+1) X] : EMadd1 G n ≃* X :=
   begin
-    have is_set (Ω[succ n] X), from !is_set_loopn,
-    apply EMadd1_pequiv' n ((ptrunc_pequiv _ _)⁻¹ᵉ* ⬝e* pequiv_of_isomorphism e),
-    intro p q, esimp, exact to_respect_mul e (tr p) (tr q)
+    have is_set (Ωg[succ n] X), from is_set_loopn (succ n) X,
+    apply EMadd1_pequiv' n,
+    refine inf_isomorphism_of_isomorphism e ⬝∞g gtrunc_isomorphism (Ωg[succ n] X),
   end
 
-  definition EMadd1_pequiv_succ {G : AbGroup} {X : Type*} (n : ℕ) (e : πag[n+2] X ≃g G)
+  definition EMadd1_pequiv_succ {G : AbGroup} {X : Type*} (n : ℕ) (e : G ≃g πag[n+2] X)
     [H1 : is_conn (n.+1) X] [H2 : is_trunc (n.+2) X] : EMadd1 G (succ n) ≃* X :=
   EMadd1_pequiv (succ n) e
 
@@ -441,7 +427,7 @@ namespace EM
 
   definition EM1_functor [constructor] {G H : Group} (φ : G →g H) : EM1 G →* EM1 H :=
   begin
-    fconstructor,
+    fapply pmap.mk,
     { intro g, induction g,
       { exact base },
       { exact pth (φ g) },
@@ -454,9 +440,13 @@ namespace EM
   begin
     induction n with n ψ,
     { exact EM1_functor φ },
-    { apply ptrunc_functor, apply psusp_functor, exact ψ }
+    { apply ptrunc_functor, apply susp_functor, exact ψ }
   end
 
+  definition EMadd1_functor_succ [constructor] {G H : AbGroup} (φ : G →g H) (n : ℕ) :
+    EMadd1_functor φ (succ n) ~* ptrunc_functor (n+2) (susp_functor (EMadd1_functor φ n)) :=
+  by reflexivity
+
   definition EM_functor [unfold 4] {G H : AbGroup} (φ : G →g H) (n : ℕ) :
     K G n →* K H n :=
   begin
@@ -465,8 +455,6 @@ namespace EM
     { exact EMadd1_functor φ n }
   end
 
-  -- TODO: (K G n →* K H n) ≃ (G →g H)
-
   /- Equivalence of Groups and pointed connected 1-truncated types -/
 
   definition ptruncconntype10_pequiv (X Y : 1-Type*[0]) (e : π₁ X ≃g π₁ Y) : X ≃* Y :=
@@ -490,7 +478,7 @@ namespace EM
   | (succ n) X Y e :=
   begin
     refine (EMadd1_pequiv_succ n _)⁻¹ᵉ* ⬝e* EMadd1_pequiv_succ n !isomorphism.refl,
-    exact e
+    exact e⁻¹ᵍ
   end
 
   definition EM1_pequiv_ptruncconntype (n : ℕ) (X : (n+1+1)-Type*[n+1]) :

hott/homotopy/LES_of_homotopy_groups.hlean

@@ -75,12 +75,14 @@ We get the long exact sequence of homotopy groups by taking the set-truncation o
 
 import .chain_complex algebra.homotopy_group eq2
 
-open eq pointed sigma fiber equiv is_equiv sigma.ops is_trunc nat trunc algebra function sum
+open eq pointed sigma fiber equiv is_equiv is_trunc nat trunc algebra function
 /--------------
     PART 1
  --------------/
 
 namespace chain_complex
+  section
+  open sigma.ops
 
   definition fiber_sequence_helper [constructor] (v : Σ(X Y : Type*), X →* Y)
     : Σ(Z X : Type*), Z →* X :=
@@ -90,7 +92,10 @@ namespace chain_complex
     : Σ(Z X : Type*), Z →* X :=
   iterate fiber_sequence_helper n v
 
+  end
+
   section
+  open sigma.ops
   universe variable u
   parameters {X Y : pType.{u}} (f : X →* Y)
   include f
@@ -117,75 +122,23 @@ namespace chain_complex
   λn x p, fiber.mk (fiber.mk x p) rfl
 
   /- (generalization of) Lemma 8.4.4(i)(ii) -/
-  definition fiber_sequence_carrier_equiv (n : ℕ)
-    : fiber_sequence_carrier (n+3) ≃ Ω(fiber_sequence_carrier n) :=
-  calc
-    fiber_sequence_carrier (n+3) ≃ fiber (fiber_sequence_fun (n+1)) pt : erfl
-    ... ≃ Σ(x : fiber_sequence_carrier _), fiber_sequence_fun (n+1) x = pt
-      : fiber.sigma_char
-    ... ≃ Σ(x : fiber (fiber_sequence_fun n) pt), fiber_sequence_fun _ x = pt
-      : erfl
-    ... ≃ Σ(v : Σ(x : fiber_sequence_carrier _), fiber_sequence_fun _ x = pt),
-            fiber_sequence_fun _ (fiber.mk v.1 v.2) = pt
-      : by exact sigma_equiv_sigma !fiber.sigma_char (λa, erfl)
-    ... ≃ Σ(v : Σ(x : fiber_sequence_carrier _), fiber_sequence_fun _ x = pt),
-            v.1 = pt
-      : erfl
-    ... ≃ Σ(v : Σ(x : fiber_sequence_carrier _), x = pt),
-            fiber_sequence_fun _ v.1 = pt
-      : sigma_assoc_comm_equiv
-    ... ≃ fiber_sequence_fun _ !center.1 = pt
-      : @(sigma_equiv_of_is_contr_left _) !is_contr_sigma_eq'
-    ... ≃ fiber_sequence_fun _ pt = pt
-      : erfl
-    ... ≃ pt = pt
-      : by exact !equiv_eq_closed_left !respect_pt
-    ... ≃ Ω(fiber_sequence_carrier n) : erfl
-
-  /- computation rule -/
-  definition fiber_sequence_carrier_equiv_eq (n : ℕ)
-    (x : fiber_sequence_carrier (n+1)) (p : fiber_sequence_fun n x = pt)
-    (q : fiber_sequence_fun (n+1) (fiber.mk x p) = pt)
-    : fiber_sequence_carrier_equiv n (fiber.mk (fiber.mk x p) q)
-      = !respect_pt⁻¹ ⬝ ap (fiber_sequence_fun n) q⁻¹ ⬝ p :=
-  begin
-    refine _ ⬝ !con.assoc⁻¹,
-    apply whisker_left,
-    refine eq_transport_Fl _ _ ⬝ _,
-    apply whisker_right,
-    refine inverse2 !ap_inv ⬝ !inv_inv ⬝ _,
-    refine ap_compose (fiber_sequence_fun n) pr₁ _ ⬝
-           ap02 (fiber_sequence_fun n) !ap_pr1_center_eq_sigma_eq',
-  end
-
-  definition fiber_sequence_carrier_equiv_inv_eq (n : ℕ)
-    (p : Ω(fiber_sequence_carrier n)) : (fiber_sequence_carrier_equiv n)⁻¹ᵉ p =
-      fiber.mk (fiber.mk pt (respect_pt (fiber_sequence_fun n) ⬝ p)) idp :=
-  begin
-    apply inv_eq_of_eq,
-    refine _ ⬝ !fiber_sequence_carrier_equiv_eq⁻¹, esimp,
-    exact !inv_con_cancel_left⁻¹
-  end
-
   definition fiber_sequence_carrier_pequiv (n : ℕ)
     : fiber_sequence_carrier (n+3) ≃* Ω(fiber_sequence_carrier n) :=
-  pequiv_of_equiv (fiber_sequence_carrier_equiv n)
-    begin
-      esimp,
-      apply con.left_inv
-    end
+  pfiber_ppoint_pequiv (fiber_sequence_fun n)
 
   definition fiber_sequence_carrier_pequiv_eq (n : ℕ)
     (x : fiber_sequence_carrier (n+1)) (p : fiber_sequence_fun n x = pt)
     (q : fiber_sequence_fun (n+1) (fiber.mk x p) = pt)
     : fiber_sequence_carrier_pequiv n (fiber.mk (fiber.mk x p) q)
       = !respect_pt⁻¹ ⬝ ap (fiber_sequence_fun n) q⁻¹ ⬝ p :=
-  fiber_sequence_carrier_equiv_eq n x p q
+  pfiber_ppoint_equiv_eq p q
 
   definition fiber_sequence_carrier_pequiv_inv_eq (n : ℕ)
     (p : Ω(fiber_sequence_carrier n)) : (fiber_sequence_carrier_pequiv n)⁻¹ᵉ* p =
       fiber.mk (fiber.mk pt (respect_pt (fiber_sequence_fun n) ⬝ p)) idp :=
-  by rexact fiber_sequence_carrier_equiv_inv_eq n p
+  pfiber_ppoint_equiv_inv_eq (fiber_sequence_fun n) p
+
+  /- TODO: prove naturality of pfiber_ppoint_pequiv in general -/
 
   /- Lemma 8.4.4(iii) -/
   definition fiber_sequence_fun_eq_helper (n : ℕ)
@@ -193,7 +146,7 @@ namespace chain_complex
     fiber_sequence_carrier_pequiv n
       (fiber_sequence_fun (n + 3)
         ((fiber_sequence_carrier_pequiv (n + 1))⁻¹ᵉ* p)) =
-          ap1 (fiber_sequence_fun n) p⁻¹ :=
+          Ω→ (fiber_sequence_fun n) p⁻¹ :=
   begin
     refine ap (λx, fiber_sequence_carrier_pequiv n (fiber_sequence_fun (n + 3) x))
               (fiber_sequence_carrier_pequiv_inv_eq (n+1) p) ⬝ _,
@@ -228,7 +181,7 @@ namespace chain_complex
     (fiber_sequence_carrier_pequiv n ∘*
       fiber_sequence_fun (n + 3)) ∘*
         (fiber_sequence_carrier_pequiv (n + 1))⁻¹ᵉ* ~*
-          ap1 (fiber_sequence_fun n) ∘* pinverse :=
+          Ω→ (fiber_sequence_fun n) ∘* !pinverse :=
   begin
     fapply phomotopy.mk,
     { exact chain_complex.fiber_sequence_fun_eq_helper f n},
@@ -240,16 +193,17 @@ namespace chain_complex
 
   theorem fiber_sequence_fun_eq (n : ℕ) : Π(x : fiber_sequence_carrier (n + 4)),
     fiber_sequence_carrier_pequiv n (fiber_sequence_fun (n + 3) x) =
-      ap1 (fiber_sequence_fun n) (fiber_sequence_carrier_pequiv (n + 1) x)⁻¹ :=
+      Ω→ (fiber_sequence_fun n) (fiber_sequence_carrier_pequiv (n + 1) x)⁻¹ :=
   begin
-    apply homotopy_of_inv_homotopy_pre (fiber_sequence_carrier_pequiv (n + 1)),
+    refine @(homotopy_of_inv_homotopy_pre (fiber_sequence_carrier_pequiv (n + 1)))
+             !pequiv.to_is_equiv _ _ _,
     apply fiber_sequence_fun_eq_helper n
   end
 
   theorem fiber_sequence_fun_phomotopy (n : ℕ) :
     fiber_sequence_carrier_pequiv n ∘*
       fiber_sequence_fun (n + 3) ~*
-          (ap1 (fiber_sequence_fun n) ∘* pinverse) ∘* fiber_sequence_carrier_pequiv (n + 1) :=
+          (Ω→ (fiber_sequence_fun n) ∘* !pinverse) ∘* fiber_sequence_carrier_pequiv (n + 1) :=
   begin
     apply phomotopy_of_pinv_right_phomotopy,
     apply fiber_sequence_fun_phomotopy_helper
@@ -262,7 +216,7 @@ namespace chain_complex
     PART 2
  --------------/
 
-  /- Now we are ready to define the long exact sequence of homotopy groups.
+  /- Now we are ready to define the long exact sequence of loop spaces.
      First we define its carrier -/
   definition loop_spaces : ℕ → Type*
   | 0     := Y
@@ -271,16 +225,15 @@ namespace chain_complex
   | (k+3) := Ω (loop_spaces k)
 
   /- The maps between the homotopy groups -/
-  definition loop_spaces_fun
-    : Π(n : ℕ), loop_spaces (n+1) →* loop_spaces n
+  definition loop_spaces_fun : Π(n : ℕ), loop_spaces (n+1) →* loop_spaces n
   | 0     := proof f qed
   | 1     := proof ppoint f qed
   | 2     := proof boundary_map qed
-  | (k+3) := proof ap1 (loop_spaces_fun k) qed
+  | (k+3) := proof Ω→ (loop_spaces_fun k) qed
 
   definition loop_spaces_fun_add3 [unfold_full] (n : ℕ) :
-    loop_spaces_fun (n + 3) = ap1 (loop_spaces_fun n) :=
-  proof idp qed
+    loop_spaces_fun (n + 3) = Ω→ (loop_spaces_fun n) :=
+  idp
 
   definition fiber_sequence_pequiv_loop_spaces :
     Πn, fiber_sequence_carrier n ≃* loop_spaces n
@@ -296,11 +249,11 @@ namespace chain_complex
 
   definition fiber_sequence_pequiv_loop_spaces_add3 (n : ℕ)
     : fiber_sequence_pequiv_loop_spaces (n + 3) =
-      ap1 (fiber_sequence_pequiv_loop_spaces n) ∘* fiber_sequence_carrier_pequiv n :=
+      Ω→ (fiber_sequence_pequiv_loop_spaces n) ∘* fiber_sequence_carrier_pequiv n :=
   by reflexivity
 
   definition fiber_sequence_pequiv_loop_spaces_3_phomotopy
-    : fiber_sequence_pequiv_loop_spaces 3 ~* proof fiber_sequence_carrier_pequiv nat.zero qed :=
+    : fiber_sequence_pequiv_loop_spaces 3 ~* fiber_sequence_carrier_pequiv 0 :=
   begin
     refine pwhisker_right _ ap1_pid ⬝* _,
     apply pid_pcompose
@@ -317,31 +270,9 @@ namespace chain_complex
     : pid_or_pinverse (n + 4) = !pequiv_pinverse ⬝e* loop_pequiv_loop (pid_or_pinverse (n + 1)) :=
   by reflexivity
 
-  definition pid_or_pinverse_add4_rev : Π(n : ℕ),
-    pid_or_pinverse (n + 4) ~* pinverse ∘* Ω→(pid_or_pinverse (n + 1))
-  | 0     := begin rewrite [pid_or_pinverse_add4, + to_pmap_pequiv_trans],
-                   replace pid_or_pinverse (0 + 1) with pequiv.refl X,
-                   refine pwhisker_right _ !loop_pequiv_loop_rfl ⬝* _, refine !pid_pcompose ⬝* _,
-                   exact !pcompose_pid⁻¹* ⬝* pwhisker_left _ !ap1_pid⁻¹* end
-  | 1     := begin rewrite [pid_or_pinverse_add4, + to_pmap_pequiv_trans],
-                   replace pid_or_pinverse (1 + 1) with pequiv.refl (pfiber f),
-                   refine pwhisker_right _ !loop_pequiv_loop_rfl ⬝* _, refine !pid_pcompose ⬝* _,
-                   exact !pcompose_pid⁻¹* ⬝* pwhisker_left _ !ap1_pid⁻¹* end
-  | 2     := begin rewrite [pid_or_pinverse_add4, + to_pmap_pequiv_trans],
-                   replace pid_or_pinverse (2 + 1) with pequiv.refl (Ω Y),
-                   refine pwhisker_right _ !loop_pequiv_loop_rfl ⬝* _, refine !pid_pcompose ⬝* _,
-                   exact !pcompose_pid⁻¹* ⬝* pwhisker_left _ !ap1_pid⁻¹* end
-  | (k+3) :=
-    begin
-      replace (k + 3 + 1) with (k + 4),
-      rewrite [+ pid_or_pinverse_add4, + to_pmap_pequiv_trans],
-      refine _ ⬝* pwhisker_left _ !ap1_pcompose⁻¹*,
-      refine _ ⬝* !passoc,
-      apply pconcat2,
-      { refine ap1_phomotopy (pid_or_pinverse_add4_rev k) ⬝* _,
-        refine !ap1_pcompose ⬝* _, apply pwhisker_right, apply ap1_pinverse},
-      { refine !ap1_pinverse⁻¹*}
-    end
+  definition pid_or_pinverse_add4_rev (n : ℕ) :
+    pid_or_pinverse (n + 4) ~* !pinverse ∘* Ω→(pid_or_pinverse (n + 1)) :=
+  !pinverse_natural
 
   theorem fiber_sequence_phomotopy_loop_spaces : Π(n : ℕ),
     fiber_sequence_pequiv_loop_spaces n ∘* fiber_sequence_fun n ~*
@@ -354,7 +285,7 @@ namespace chain_complex
       replace loop_spaces_fun 2 with boundary_map,
       refine _ ⬝* pwhisker_left _ fiber_sequence_pequiv_loop_spaces_3_phomotopy⁻¹*,
       apply phomotopy_of_pinv_right_phomotopy,
-      exact !pid_pcompose⁻¹*
+      exact !pcompose_pid⁻¹*
     end
   | (k+3) :=
     begin
@@ -369,7 +300,7 @@ namespace chain_complex
       xrewrite [loop_spaces_fun_add3, pid_or_pinverse_add4, to_pmap_pequiv_trans],
       refine _ ⬝* !passoc⁻¹*,
       refine _ ⬝* pwhisker_left _ !passoc⁻¹*,
-      refine _ ⬝* pwhisker_left _ (pwhisker_left _ !ap1_pcompose_pinverse),
+      refine _ ⬝* pwhisker_left _ (pwhisker_left _ !pinverse_natural),
       refine !passoc⁻¹* ⬝* _ ⬝* !passoc ⬝* !passoc,
       apply pwhisker_right,
       refine !ap1_pcompose⁻¹* ⬝* _ ⬝* !ap1_pcompose ⬝* pwhisker_right _ !ap1_pcompose,
@@ -381,7 +312,7 @@ namespace chain_complex
   | 0     := !pid
   | 1     := !pid
   | 2     := !pid
-  | (k+3) := Ω→(pid_or_pinverse_right k) ∘* pinverse
+  | (k+3) := Ω→(pid_or_pinverse_right k) ∘* !pinverse
 
   definition pid_or_pinverse_left : Π(n : ℕ), loop_spaces n →* loop_spaces n
   | 0     := pequiv.rfl
@@ -389,14 +320,14 @@ namespace chain_complex
   | 2     := pequiv.rfl
   | 3     := pequiv.rfl
   | 4     := pequiv.rfl
-  | (k+5) := Ω→(pid_or_pinverse_left (k+2)) ∘* pinverse
+  | (k+5) := Ω→(pid_or_pinverse_left (k+2)) ∘* !pinverse
 
   definition pid_or_pinverse_right_add3 (n : ℕ)
-    : pid_or_pinverse_right (n + 3) = Ω→(pid_or_pinverse_right n) ∘* pinverse :=
+    : pid_or_pinverse_right (n + 3) = Ω→(pid_or_pinverse_right n) ∘* !pinverse :=
   by reflexivity
 
   definition pid_or_pinverse_left_add5 (n : ℕ)
-    : pid_or_pinverse_left (n + 5) = Ω→(pid_or_pinverse_left (n+2)) ∘* pinverse :=
+    : pid_or_pinverse_left (n + 5) = Ω→(pid_or_pinverse_left (n+2)) ∘* !pinverse :=
   by reflexivity
 
   theorem pid_or_pinverse_commute_right : Π(n : ℕ),
@@ -414,7 +345,7 @@ namespace chain_complex
       apply pwhisker_left,
       refine !ap1_pcompose ⬝* _ ⬝* !passoc ⬝* !passoc,
       apply pwhisker_right,
-      refine _ ⬝* pwhisker_right _ !ap1_pcompose_pinverse,
+      refine _ ⬝* pwhisker_right _ !pinverse_natural,
       refine _ ⬝* !passoc⁻¹*,
       refine !pcompose_pid⁻¹* ⬝* pwhisker_left _ _,
       symmetry, apply pinverse_pinverse
@@ -429,11 +360,11 @@ namespace chain_complex
   | (k+4) :=
     begin
       replace (k + 4 + 1) with (k + 5),
-      rewrite [pid_or_pinverse_left_add5, pid_or_pinverse_add4, to_pmap_pequiv_trans],
+      rewrite [pid_or_pinverse_left_add5, pid_or_pinverse_add4],
       replace (k + 4) with (k + 1 + 3),
       rewrite [loop_spaces_fun_add3],
       refine !passoc⁻¹* ⬝* _ ⬝* !passoc⁻¹*,
-      refine _ ⬝* pwhisker_left _ !ap1_pcompose_pinverse,
+      refine _ ⬝* pwhisker_left _ !pinverse_natural,
       refine _ ⬝* !passoc,
       apply pwhisker_right,
       refine !ap1_pcompose⁻¹* ⬝* _ ⬝* !ap1_pcompose,
@@ -470,10 +401,14 @@ namespace chain_complex
       PART 3
    --------------/
 
+  definition fibration_sequence [unfold 4] : fin 3 → Type*
+  | (fin.mk 0 H)     := Y
+  | (fin.mk 1 H)     := X
+  | (fin.mk 2 H)     := pfiber f
+  | (fin.mk (n+3) H) := begin exfalso, apply lt_le_antisymm H, apply le_add_left end
+
   definition loop_spaces2 [reducible] : +3ℕ → Type*
-  | (n, fin.mk 0 H) := Ω[n] Y
-  | (n, fin.mk 1 H) := Ω[n] X
-  | (n, fin.mk k H) := Ω[n] (pfiber f)
+  | (n, m) := Ω[n] (fibration_sequence m)
 
   definition loop_spaces2_add1 (n : ℕ) : Π(x : fin 3),
     loop_spaces2 (n+1, x) = Ω (loop_spaces2 (n, x))
@@ -485,7 +420,7 @@ namespace chain_complex
   definition loop_spaces_fun2 : Π(n : +3ℕ), loop_spaces2 (S n) →* loop_spaces2 n
   | (n, fin.mk 0 H) := proof Ω→[n] f qed
   | (n, fin.mk 1 H) := proof Ω→[n] (ppoint f) qed
-  | (n, fin.mk 2 H) := proof Ω→[n] boundary_map ∘* loopn_succ_in Y n qed
+  | (n, fin.mk 2 H) := proof Ω→[n] boundary_map ∘* loopn_succ_in n Y qed
   | (n, fin.mk (k+3) H) := begin exfalso, apply lt_le_antisymm H, apply le_add_left end
 
   definition loop_spaces_fun2_add1_0 (n : ℕ) (H : 0 < succ 2)
@@ -629,11 +564,10 @@ namespace chain_complex
 /--------------
     PART 4
  --------------/
+  open prod.ops
 
-  definition homotopy_groups [reducible] : +3ℕ → Set*
-  | (n, fin.mk 0 H) := π[n] Y
-  | (n, fin.mk 1 H) := π[n] X
-  | (n, fin.mk k H) := π[n] (pfiber f)
+  definition homotopy_groups [reducible] : +3ℕ → Set* :=
+  λnm, π[nm.1] (fibration_sequence nm.2)
 
   definition homotopy_groups_pequiv_loop_spaces2 [reducible]
     : Π(n : +3ℕ), ptrunc 0 (loop_spaces2 n) ≃* homotopy_groups n
@@ -646,7 +580,7 @@ namespace chain_complex
   | (n, fin.mk 0 H) := proof π→[n] f qed
   | (n, fin.mk 1 H) := proof π→[n] (ppoint f) qed
   | (n, fin.mk 2 H) :=
-    proof π→[n] boundary_map ∘* homotopy_group_succ_in Y n qed
+    proof π→[n] boundary_map ∘* homotopy_group_succ_in n Y qed
   | (n, fin.mk (k+3) H) := begin exfalso, apply lt_le_antisymm H, apply le_add_left end
 
   definition homotopy_groups_fun_phomotopy_loop_spaces_fun2 [reducible]
@@ -704,32 +638,28 @@ namespace chain_complex
     cc_to_fn LES_of_homotopy_groups (n, 1) = π→[n] (ppoint f) :=
   by reflexivity
   definition LES_of_homotopy_groups_fun_2 : cc_to_fn LES_of_homotopy_groups (n, 2) =
-    π→[n] boundary_map ∘* homotopy_group_succ_in Y n :=
+    π→[n] boundary_map ∘* homotopy_group_succ_in n Y :=
   by reflexivity
 
   open group
 
-  definition group_LES_of_homotopy_groups (n : ℕ) : Π(x : fin (succ 2)),
-    group (LES_of_homotopy_groups (n + 1, x))
-  | (fin.mk 0     H) := begin rexact group_homotopy_group n Y end
-  | (fin.mk 1     H) := begin rexact group_homotopy_group n X end
-  | (fin.mk 2     H) := begin rexact group_homotopy_group n (pfiber f) end
-  | (fin.mk (k+3) H) := begin exfalso, apply lt_le_antisymm H, apply le_add_left end
+  definition group_LES_of_homotopy_groups (n : ℕ) [is_succ n] (x : fin (succ 2)) :
+    group (LES_of_homotopy_groups (n, x)) :=
+  group_homotopy_group n (fibration_sequence x)
 
-  definition ab_group_LES_of_homotopy_groups (n : ℕ) : Π(x : fin (succ 2)),
-    ab_group (LES_of_homotopy_groups (n + 2, x))
-  | (fin.mk 0 H) := proof ab_group_homotopy_group n Y qed
-  | (fin.mk 1 H) := proof ab_group_homotopy_group n X qed
-  | (fin.mk 2 H) := proof ab_group_homotopy_group n (pfiber f) qed
-  | (fin.mk (k+3) H) := begin exfalso, apply lt_le_antisymm H, apply le_add_left end
+  definition pgroup_LES_of_homotopy_groups (n : ℕ) [H : is_succ n] (x : fin (succ 2)) :
+    pgroup (LES_of_homotopy_groups (n, x)) :=
+  by induction H with n; exact @pgroup_of_group _ (group_LES_of_homotopy_groups (n+1) x) idp
 
-  definition Group_LES_of_homotopy_groups (x : +3ℕ) : Group.{u} :=
-  Group.mk (LES_of_homotopy_groups (nat.succ (pr1 x), pr2 x))
-              (group_LES_of_homotopy_groups (pr1 x) (pr2 x))
+  definition ab_group_LES_of_homotopy_groups (n : ℕ) [is_at_least_two n] (x : fin (succ 2)) :
+    ab_group (LES_of_homotopy_groups (n, x)) :=
+  ab_group_homotopy_group n (fibration_sequence x)
+
+  definition Group_LES_of_homotopy_groups (n : +3ℕ) : Group.{u} :=
+  πg[n.1+1] (fibration_sequence n.2)
 
   definition AbGroup_LES_of_homotopy_groups (n : +3ℕ) : AbGroup.{u} :=
-  AbGroup.mk (LES_of_homotopy_groups (pr1 n + 2, pr2 n))
-                  (ab_group_LES_of_homotopy_groups (pr1 n) (pr2 n))
+  πag[n.1+2] (fibration_sequence n.2)
 
   definition homomorphism_LES_of_homotopy_groups_fun : Π(k : +3ℕ),
     Group_LES_of_homotopy_groups (S k) →g Group_LES_of_homotopy_groups k
@@ -743,11 +673,75 @@ namespace chain_complex
     begin
       apply homomorphism.mk (cc_to_fn LES_of_homotopy_groups (k + 1, 2)),
       exact abstract begin rewrite [LES_of_homotopy_groups_fun_2],
-      refine homomorphism.struct ((π→g[k+1] boundary_map) ∘g ghomotopy_group_succ_in Y k),
+      refine homomorphism.struct ((π→g[k+1] boundary_map) ∘g ghomotopy_group_succ_in k Y),
       end end
     end
   | (k, fin.mk (l+3) H) := begin exfalso, apply lt_le_antisymm H, apply le_add_left end
 
+  definition LES_is_equiv_of_trivial (n : ℕ) (x : fin (succ 2)) [H : is_succ n]
+    (HX1 : is_contr (LES_of_homotopy_groups (stratified_pred snat' (n, x))))
+    (HX2 : is_contr (LES_of_homotopy_groups (stratified_pred snat' (n+1, x))))
+    : is_equiv (cc_to_fn LES_of_homotopy_groups (n, x)) :=
+  begin
+    induction H with n,
+    induction x with m H, cases m with m,
+    { rexact @is_equiv_of_trivial +3ℕ LES_of_homotopy_groups (n, 2) (is_exact_LES_of_homotopy_groups (n, 2))
+        proof (is_exact_LES_of_homotopy_groups (n+1, 0)) qed HX1 proof HX2 qed
+        proof pgroup_LES_of_homotopy_groups (n+1) 0 qed proof pgroup_LES_of_homotopy_groups (n+1) 1 qed
+        proof homomorphism.struct (homomorphism_LES_of_homotopy_groups_fun (n, 0)) qed },
+    cases m with m,
+    { rexact @is_equiv_of_trivial +3ℕ LES_of_homotopy_groups (n+1, 0) (is_exact_LES_of_homotopy_groups (n+1, 0))
+        proof (is_exact_LES_of_homotopy_groups (n+1, 1)) qed HX1 proof HX2 qed
+        proof pgroup_LES_of_homotopy_groups (n+1) 1 qed proof pgroup_LES_of_homotopy_groups (n+1) 2 qed
+        proof homomorphism.struct (homomorphism_LES_of_homotopy_groups_fun (n, 1)) qed }, cases m with m,
+    { rexact @is_equiv_of_trivial +3ℕ LES_of_homotopy_groups (n+1, 1) (is_exact_LES_of_homotopy_groups (n+1, 1))
+        proof (is_exact_LES_of_homotopy_groups (n+1, 2)) qed HX1 proof HX2 qed
+        proof pgroup_LES_of_homotopy_groups (n+1) 2 qed proof pgroup_LES_of_homotopy_groups (n+2) 0 qed
+        proof homomorphism.struct (homomorphism_LES_of_homotopy_groups_fun (n, 2)) qed },
+    exfalso, apply lt_le_antisymm H, apply le_add_left
+  end
+
+  definition LES_isomorphism_of_trivial_cod (n : ℕ) [H : is_succ n]
+    (HX1 : is_contr (πg[n] Y)) (HX2 : is_contr (πg[n+1] Y)) : πg[n] (pfiber f) ≃g πg[n] X :=
+  begin
+    induction H with n,
+    refine isomorphism.mk (homomorphism_LES_of_homotopy_groups_fun (n, 1)) _,
+    apply LES_is_equiv_of_trivial, apply HX1, apply HX2
+  end
+
+  definition LES_isomorphism_of_trivial_dom (n : ℕ) [H : is_succ n]
+    (HX1 : is_contr (πg[n] X)) (HX2 : is_contr (πg[n+1] X)) : πg[n+1] Y ≃g πg[n] (pfiber f) :=
+  begin
+    induction H with n,
+    refine isomorphism.mk (homomorphism_LES_of_homotopy_groups_fun (n, 2)) _,
+    apply LES_is_equiv_of_trivial, apply HX1, apply HX2
+  end
+
+  definition LES_isomorphism_of_trivial_pfiber (n : ℕ)
+    (HX1 : is_contr (π[n] (pfiber f))) (HX2 : is_contr (πg[n+1] (pfiber f))) : πg[n+1] X ≃g πg[n+1] Y :=
+  begin
+    refine isomorphism.mk (homomorphism_LES_of_homotopy_groups_fun (n, 0)) _,
+    apply LES_is_equiv_of_trivial, apply HX1, apply HX2
+  end
+
+  definition LES_is_contr_of_is_embedding_of_is_surjective (n : ℕ)
+    (H : is_embedding (π→[n] f)) (H2 : is_surjective (π→[n+1] f)) : is_contr (π[n] (pfiber f)) :=
+  begin
+    rexact @is_contr_of_is_embedding_of_is_surjective +3ℕ LES_of_homotopy_groups (n, 0)
+      (is_exact_LES_of_homotopy_groups _) proof H qed proof H2 qed
+  end
+
+  definition is_contr_homotopy_group_fiber {n : ℕ}
+    (H1 : is_embedding (π→[n] f)) (H2 : is_surjective (π→g[n+1] f)) : is_contr (π[n] (pfiber f)) :=
+  begin
+    apply @is_contr_of_is_embedding_of_is_surjective +3ℕ LES_of_homotopy_groups (n, 0),
+    exact is_exact_LES_of_homotopy_groups (n, 1), exact H1, exact H2
+  end
+
+  definition is_contr_homotopy_group_fiber_of_is_equiv {n : ℕ}
+    (H1 : is_equiv (π→[n] f)) (H2 : is_equiv (π→g[n+1] f)) : is_contr (π[n] (pfiber f)) :=
+  is_contr_homotopy_group_fiber (is_embedding_of_is_equiv _) (is_surjective_of_is_equiv _)
+
   end
 
   /-
@@ -773,7 +767,7 @@ namespace chain_complex
     : Π(n : +3ℕ), fibration_sequence_car (S n) →* fibration_sequence_car n
   | (n, fin.mk 0 H) := proof Ω→[n] f qed
   | (n, fin.mk 1 H) := proof Ω→[n] g qed
-  | (n, fin.mk 2 H) := proof Ω→[n] (e ∘* boundary_map f) ∘* loopn_succ_in Y n qed
+  | (n, fin.mk 2 H) := proof Ω→[n] (e ∘* boundary_map f) ∘* loopn_succ_in n Y qed
   | (n, fin.mk (k+3) H) := begin exfalso, apply lt_le_antisymm H, apply le_add_left end
 
   definition fibration_sequence_pequiv : Π(x : +3ℕ),
@@ -794,22 +788,22 @@ namespace chain_complex
       refine _ ⬝* !apn_pcompose⁻¹*, reflexivity end
   | (n, fin.mk (k+3) H) := begin exfalso, apply lt_le_antisymm H, apply le_add_left end
 
-  definition type_fibration_sequence [constructor] : type_chain_complex +3ℕ :=
+  definition type_LES_fibration_sequence [constructor] : type_chain_complex +3ℕ :=
   transfer_type_chain_complex
     (LES_of_loop_spaces2 f)
     fibration_sequence_fun
     fibration_sequence_pequiv
     fibration_sequence_fun_phomotopy
 
-  definition is_exact_type_fibration_sequence : is_exact_t type_fibration_sequence :=
+  definition is_exact_type_fibration_sequence : is_exact_t type_LES_fibration_sequence :=
   begin
     intro n,
     apply is_exact_at_t_transfer,
     apply is_exact_LES_of_loop_spaces2
   end
 
-  definition fibration_sequence [constructor] : chain_complex +3ℕ :=
-  trunc_chain_complex type_fibration_sequence
+  definition LES_fibration_sequence [constructor] : chain_complex +3ℕ :=
+  trunc_chain_complex type_LES_fibration_sequence
 
   end
 

hott/homotopy/cellcomplex.hlean

@@ -5,7 +5,7 @@ Authors: Ulrik Buchholtz
 -/
 import types.trunc homotopy.sphere hit.pushout
 
-open eq is_trunc is_equiv nat equiv trunc prod pushout sigma sphere_index unit
+open eq is_trunc is_equiv nat equiv trunc prod pushout sigma unit pointed
 
 -- where should this be?
 definition family : Type := ΣX, X → Type

hott/homotopy/chain_complex.hlean

@@ -49,6 +49,11 @@ definition stratified_succ {N : succ_str} {n : ℕ} (x : stratified_type N n)
   : stratified_type N n :=
 (if val (pr2 x) = n then S (pr1 x) else pr1 x, cyclic_succ (pr2 x))
 
+/- You might need to manually change the succ_str, to use predecessor as "successor" -/
+definition stratified_pred (N : succ_str) {n : ℕ} (x : stratified_type N n)
+  : stratified_type N n :=
+(if val (pr2 x) = 0 then S (pr1 x) else pr1 x, cyclic_pred (pr2 x))
+
 definition stratified [reducible] [constructor] (N : succ_str) (n : ℕ) : succ_str :=
 succ_str.mk (stratified_type N n) stratified_succ
 
@@ -212,17 +217,17 @@ namespace chain_complex
     (p : Π{m} (x : X (S (f m))), e (tcc_to_fn X (f m) x) = g (e (cast (ap (λx, X x) (c m)) x)))
     : type_chain_complex M :=
   type_chain_complex.mk Y @g
-    begin
+    abstract begin
       intro m,
       apply equiv_rect (equiv_of_pequiv e),
       apply equiv_rect (equiv_of_eq (ap (λx, X x) (c (S m)))), esimp,
       apply equiv_rect (equiv_of_eq (ap (λx, X (S x)) (c m))), esimp,
       intro x, refine ap g (p _)⁻¹ ⬝ _,
-      refine ap g (ap e (fn_cast_eq_cast_fn (c m) (tcc_to_fn X) x)) ⬝ _,
+      refine ap g (ap e (fn_cast_eq_cast_fn (c m) (λn, pmap.to_fun (tcc_to_fn X n)) x)) ⬝ _,
       refine (p _)⁻¹ ⬝ _,
       refine ap e (tcc_is_chain_complex X (f m) _) ⬝ _,
       apply respect_pt
-    end
+    end end
 
   definition is_exact_at_t_transfer2 {X : type_chain_complex N} {M : succ_str} {Y : M → Type*}
     (f : M ≃ N) (c : Π(m : M), S (f m) = f (S m))
@@ -234,18 +239,18 @@ namespace chain_complex
     intro y q, esimp at *,
     have H2 : tcc_to_fn X (f m) ((equiv_of_eq (ap (λx, X x) (c m)))⁻¹ᵉ (e⁻¹ y)) = pt,
     begin
-      refine _ ⬝ ap e⁻¹ᵉ* q ⬝ (respect_pt (e⁻¹ᵉ*)), apply eq_inv_of_eq, clear q, revert y,
+      refine _ ⬝ ap e⁻¹ᵉ* q ⬝ (respect_pt (e⁻¹ᵉ*)), apply @eq_inv_of_eq _ _ e, clear q, revert y,
       apply inv_homotopy_of_homotopy_pre e,
       apply inv_homotopy_of_homotopy_pre, apply p
     end,
     induction (H _ H2) with x r,
     refine fiber.mk (e (cast (ap (λx, X x) (c (S m))) (cast (ap (λx, X (S x)) (c m)) x))) _,
     refine (p _)⁻¹ ⬝ _,
-    refine ap e (fn_cast_eq_cast_fn (c m) (tcc_to_fn X) x) ⬝ _,
+    refine ap e (fn_cast_eq_cast_fn (c m) (λn, pmap.to_fun (tcc_to_fn X n)) x) ⬝ _,
     refine ap (λx, e (cast _ x)) r ⬝ _,
     esimp [equiv.symm], rewrite [-ap_inv],
     refine ap e !cast_cast_inv ⬝ _,
-    apply right_inv
+    apply to_right_inv
   end
 
   end
@@ -350,7 +355,7 @@ namespace chain_complex
 
   definition transfer_chain_complex2 [constructor] {M : succ_str} {Y : M → Set*}
     (f : N ≃ M) (c : Π(n : N), f (S n) = S (f n))
-    (g : Π{m : M}, Y (S m) →* Y m) (e : Π{n}, X n ≃* Y (f n))
+    (g : Π{m : M}, pmap (Y (S m)) (Y m)) (e : Π{n}, X n ≃* Y (f n))
     (p : Π{n} (x : X (S n)), e (cc_to_fn X n x) = g (c n ▸ e x)) : chain_complex M :=
   chain_complex.mk Y @g
     begin
@@ -366,7 +371,8 @@ namespace chain_complex
       refine pi.pi_functor _ _ H,
       { intro x, exact (c (S n))⁻¹ ▸ (c n)⁻¹ ▸ x}, -- with implicit arguments, this is:
       -- transport (λx, Y x) (c (S n))⁻¹ (transport (λx, Y (S x)) (c n)⁻¹ x)
-      { intro x, intro p, refine _ ⬝ p, rewrite [tr_inv_tr, fn_tr_eq_tr_fn (c n)⁻¹ @g, tr_inv_tr]}
+      { intro x, intro p, refine _ ⬝ p,
+        rewrite [tr_inv_tr, fn_tr_eq_tr_fn (c n)⁻¹ᵖ (λn, ppi.to_fun g), tr_inv_tr]}
     end
 
   definition is_exact_at_transfer2 {X : chain_complex N} {M : succ_str} {Y : M → Set*}
@@ -384,7 +390,7 @@ namespace chain_complex
     end,
     induction (H _ H2) with x r,
     refine image.mk (c n ▸ c (S n) ▸ e x) _,
-    rewrite [fn_tr_eq_tr_fn (c n) @g],
+    rewrite [fn_tr_eq_tr_fn (c n) (λn, ppi.to_fun g)],
     refine ap (λx, c n ▸ x) (p x)⁻¹ ⬝ _,
     refine ap (λx, c n ▸ e x) r ⬝ _,
     refine ap (λx, c n ▸ x) !right_inv ⬝ _,

hott/homotopy/circle.hlean

@@ -10,7 +10,7 @@ import .sphere
 import types.int.hott
 import algebra.homotopy_group .connectedness
 
-open eq susp bool sphere_index is_equiv equiv is_trunc is_conn pi algebra pointed
+open eq susp bool is_equiv equiv is_trunc is_conn pi algebra pointed
 
 definition circle : Type₀ := sphere 1
 
@@ -18,8 +18,8 @@ namespace circle
   notation `S¹` := circle
   definition base1 : S¹ := !north
   definition base2 : S¹ := !south
-  definition seg1 : base1 = base2 := merid !north
-  definition seg2 : base1 = base2 := merid !south
+  definition seg1 : base1 = base2 := merid ff
+  definition seg2 : base1 = base2 := merid tt
 
   definition base : S¹ := base1
   definition loop : base = base := seg2 ⬝ seg1⁻¹
@@ -32,8 +32,7 @@ namespace circle
     { exact Pb2 },
     { esimp at *, induction b with y,
       { exact Ps1 },
-      { exact Ps2},
-      { cases y}},
+      { exact Ps2 }},
   end
 
   definition rec2_on [reducible] {P : S¹ → Type} (x : S¹) (Pb1 : P base1) (Pb2 : P base2)
@@ -60,14 +59,14 @@ namespace circle
   theorem elim2_seg1 {P : Type} (Pb1 Pb2 : P) (Ps1 : Pb1 = Pb2) (Ps2 : Pb1 = Pb2)
     : ap (elim2 Pb1 Pb2 Ps1 Ps2) seg1 = Ps1 :=
   begin
-    apply eq_of_fn_eq_fn_inv !(pathover_constant seg1),
+    apply inj_inv !(pathover_constant seg1),
     rewrite [▸*,-apd_eq_pathover_of_eq_ap,↑elim2,rec2_seg1],
   end
 
   theorem elim2_seg2 {P : Type} (Pb1 Pb2 : P) (Ps1 : Pb1 = Pb2) (Ps2 : Pb1 = Pb2)
     : ap (elim2 Pb1 Pb2 Ps1 Ps2) seg2 = Ps2 :=
   begin
-    apply eq_of_fn_eq_fn_inv !(pathover_constant seg2),
+    apply inj_inv !(pathover_constant seg2),
     rewrite [▸*,-apd_eq_pathover_of_eq_ap,↑elim2,rec2_seg2],
   end
 
@@ -105,9 +104,6 @@ namespace circle
     pathover_tr_of_pathover q ⬝o !pathover_tr⁻¹ᵒ = q :=
   by cases p'; cases q; exact idp
 
-  definition con_refl {A : Type} {x y : A} (p : x = y) : p ⬝ refl _ = p :=
-  eq.rec_on p idp
-
   theorem rec_loop {P : S¹ → Type} (Pbase : P base) (Ploop : Pbase =[loop] Pbase) :
     apd (circle.rec Pbase Ploop) loop = Ploop :=
   begin
@@ -126,14 +122,14 @@ namespace circle
   theorem elim_loop {P : Type} (Pbase : P) (Ploop : Pbase = Pbase) :
     ap (circle.elim Pbase Ploop) loop = Ploop :=
   begin
-    apply eq_of_fn_eq_fn_inv !(pathover_constant loop),
+    apply inj_inv !(pathover_constant loop),
     rewrite [▸*,-apd_eq_pathover_of_eq_ap,↑circle.elim,rec_loop],
   end
 
   theorem elim_seg1 {P : Type} (Pbase : P) (Ploop : Pbase = Pbase)
     : ap (circle.elim Pbase Ploop) seg1 = (tr_constant seg1 Pbase)⁻¹ :=
   begin
-    apply eq_of_fn_eq_fn_inv !(pathover_constant seg1),
+    apply inj_inv !(pathover_constant seg1),
     rewrite [▸*,-apd_eq_pathover_of_eq_ap,↑circle.elim,↑circle.rec],
     rewrite [↑circle.rec2_on,rec2_seg1], apply inverse,
     apply pathover_of_eq_tr_constant_inv
@@ -142,7 +138,7 @@ namespace circle
   theorem elim_seg2 {P : Type} (Pbase : P) (Ploop : Pbase = Pbase)
     : ap (circle.elim Pbase Ploop) seg2 = Ploop ⬝ (tr_constant seg1 Pbase)⁻¹ :=
   begin
-    apply eq_of_fn_eq_fn_inv !(pathover_constant seg2),
+    apply inj_inv !(pathover_constant seg2),
     rewrite [▸*,-apd_eq_pathover_of_eq_ap,↑circle.elim,↑circle.rec],
     rewrite [↑circle.rec2_on,rec2_seg2],
     assert l : Π(A B : Type)(a a₂ a₂' : A)(b b' : B)(p : a = a₂)(p' : a₂' = a₂)
@@ -162,13 +158,25 @@ namespace circle
     (Ploop : Pbase ≃ Pbase) : Type :=
   circle.elim_type Pbase Ploop x
 
-  theorem elim_type_loop (Pbase : Type) (Ploop : Pbase ≃ Pbase) :
+  theorem elim_type_loop_fn (Pbase : Type) (Ploop : Pbase ≃ Pbase) :
     transport (circle.elim_type Pbase Ploop) loop = Ploop :=
   by rewrite [tr_eq_cast_ap_fn,↑circle.elim_type,elim_loop];apply cast_ua_fn
 
-  theorem elim_type_loop_inv (Pbase : Type) (Ploop : Pbase ≃ Pbase) :
+  theorem elim_type_loop (Pbase : Type) (Ploop : Pbase ≃ Pbase) (x : Pbase) :
+    transport (circle.elim_type Pbase Ploop) loop x = Ploop x :=
+  apd10 (elim_type_loop_fn Pbase Ploop) x
+
+  definition elim_type_loop_pathover (Pbase : Type) (Ploop : Pbase ≃ Pbase) (x : Pbase) :
+    x =[loop; circle.elim_type Pbase Ploop] Ploop x :=
+  pathover_of_tr_eq (elim_type_loop Pbase Ploop x)
+
+  theorem elim_type_loop_inv_fn (Pbase : Type) (Ploop : Pbase ≃ Pbase) :
     transport (circle.elim_type Pbase Ploop) loop⁻¹ = to_inv Ploop :=
-  by rewrite [tr_inv_fn]; apply inv_eq_inv; apply elim_type_loop
+  by rewrite [tr_inv_fn]; apply inv_eq_inv; apply elim_type_loop_fn
+
+  theorem elim_type_loop_inv (Pbase : Type) (Ploop : Pbase ≃ Pbase) (x : Pbase) :
+    transport (circle.elim_type Pbase Ploop) loop⁻¹ x = to_inv Ploop x :=
+  apd10 (elim_type_loop_inv_fn Pbase Ploop) x
 end circle
 
 attribute circle.base1 circle.base2 circle.base [constructor]
@@ -248,10 +256,10 @@ namespace circle
   circle.elim_type_on x ℤ equiv_succ
 
   definition transport_code_loop (a : ℤ) : transport circle.code loop a = succ a :=
-  ap10 !elim_type_loop a
+  !elim_type_loop
 
   definition transport_code_loop_inv (a : ℤ) : transport circle.code loop⁻¹ a = pred a :=
-  ap10 !elim_type_loop_inv a
+  !elim_type_loop_inv
 
   protected definition encode [unfold 2] {x : S¹} (p : base = x) : circle.code x :=
   transport circle.code p (0 : ℤ)
@@ -299,7 +307,7 @@ namespace circle
   trunc_equiv_trunc 0 base_eq_base_equiv ⬝e @(trunc_equiv 0 ℤ) proof _ qed
 
   definition con_comm_base (p q : base = base) : p ⬝ q = q ⬝ p :=
-  eq_of_fn_eq_fn base_eq_base_equiv (by esimp;rewrite [+encode_con,add.comm])
+  inj base_eq_base_equiv (by esimp;rewrite [+encode_con,add.comm])
 
   definition fundamental_group_of_circle : π₁(S¹*) ≃g gℤ :=
   begin
@@ -312,15 +320,15 @@ namespace circle
   open nat
   definition homotopy_group_of_circle (n : ℕ) : πg[n+2] S¹* ≃g G0 :=
   begin
-    refine @trivial_homotopy_add_of_is_set_loopn S¹* 1 n _,
-    apply is_trunc_equiv_closed_rev, apply base_eq_base_equiv
+    refine @trivial_homotopy_add_of_is_set_loopn 1 n S¹* _,
+    exact is_trunc_equiv_closed_rev _ base_eq_base_equiv _
   end
 
   definition eq_equiv_Z (x : S¹) : x = x ≃ ℤ :=
   begin
     induction x,
     { apply base_eq_base_equiv},
-    { apply equiv_pathover, intro p p' q, apply pathover_of_eq,
+    { apply equiv_pathover2, intro p p' q, apply pathover_of_eq,
       note H := eq_of_square (square_of_pathover q),
       rewrite con_comm_base at H,
       note H' := cancel_left _ H,
@@ -331,11 +339,11 @@ namespace circle
   begin
     apply is_trunc_succ_of_is_trunc_loop,
     { apply trunc_index.minus_one_le_succ },
-    { intro x, apply is_trunc_equiv_closed_rev, apply eq_equiv_Z}
+    { intro x, exact is_trunc_equiv_closed_rev 0 !eq_equiv_Z _ }
   end
 
   proposition is_conn_circle [instance] : is_conn 0 S¹ :=
-  sphere.is_conn_sphere -1.+2
+  sphere.is_conn_sphere 1
 
   definition is_conn_pcircle [instance] : is_conn 0 S¹* := !is_conn_circle
   definition is_trunc_pcircle [instance] : is_trunc 1 S¹* := !is_trunc_circle
@@ -353,4 +361,27 @@ namespace circle
   definition circle_base_mul [reducible] (x : S¹) : circle_mul base x = x :=
   idp
 
+  /-
+    Suppose for `f, g : A -> B` we prove a homotopy `H : f ~ g` by induction on the element in `A`.
+    And suppose `p : a = a'` is a path constructor in `A`.
+    Then `natural_square_tr H p` has type `square (H a) (H a') (ap f p) (ap g p)` and is equal
+    to the square which defined H on the path constructor
+  -/
+
+  definition natural_square_elim_loop {A : Type} {f g : S¹ → A} (p : f base = g base)
+    (q : square p p (ap f loop) (ap g loop))
+    : natural_square (circle.rec p (eq_pathover q)) loop = q :=
+  begin
+    refine ap square_of_pathover !rec_loop ⬝ _,
+    exact to_right_inv !eq_pathover_equiv_square q
+  end
+
+  definition circle_elim_constant [unfold 5] {A : Type} {a : A} {p : a = a} (r : p = idp) (x : S¹) :
+    circle.elim a p x = a :=
+  begin
+    induction x,
+    { reflexivity },
+    { apply eq_pathover_constant_right, apply hdeg_square, exact !elim_loop ⬝ r }
+  end
+
 end circle

hott/homotopy/cofiber.hlean

@@ -9,60 +9,51 @@ import hit.pushout function .susp types.unit
 
 open eq pushout unit pointed is_trunc is_equiv susp unit equiv
 
-definition cofiber {A B : Type} (f : A → B) := pushout (λ (a : A), ⋆) f
+definition cofiber {A B : Type} (f : A → B) := pushout f (λ (a : A), ⋆)
 
 namespace cofiber
   section
   parameters {A B : Type} (f : A → B)
 
-  protected definition base : cofiber f := inl ⋆
-
-  protected definition cod : B → cofiber f := inr
+  definition cod : B → cofiber f := inl
+  definition base : cofiber f := inr ⋆
 
   parameter {f}
-  protected definition glue (a : A) : cofiber.base f = cofiber.cod f (f a) :=
+  protected definition glue (a : A) : cofiber.cod f (f a) = cofiber.base f :=
   pushout.glue a
 
-  parameter (f)
-  protected definition contr_of_equiv [H : is_equiv f] : is_contr (cofiber f) :=
-  begin
-    fapply is_contr.mk, exact base,
-    intro a, induction a with [u, b],
-    { cases u, reflexivity },
-    { exact !glue ⬝ ap inr (right_inv f b) },
-    { apply eq_pathover, refine _ ⬝hp !ap_id⁻¹, refine !ap_constant ⬝ph _,
-      apply move_bot_of_left, refine !idp_con ⬝ph _, apply transpose, esimp,
-      refine _ ⬝hp (ap (ap inr) !adj⁻¹), refine _ ⬝hp !ap_compose, apply square_Flr_idp_ap },
-  end
-
-  parameter {f}
-  protected definition rec {P : cofiber f → Type}
-    (Pbase : P base) (Pcod : Π (b : B), P (cod b))
-    (Pglue : Π (a : A), pathover P Pbase (glue a) (Pcod (f a))) :
+  protected definition rec {P : cofiber f → Type} (Pcod : Π (b : B), P (cod b)) (Pbase : P base)
+    (Pglue : Π (a : A), pathover P (Pcod (f a)) (glue a) Pbase) :
     (Π y, P y) :=
   begin
-    intro y, induction y, induction x, exact Pbase, exact Pcod x, esimp, exact Pglue x,
+    intro y, induction y, exact Pcod x, induction x, exact Pbase, exact Pglue x
   end
 
   protected definition rec_on {P : cofiber f → Type} (y : cofiber f)
-    (Pbase : P base) (Pcod : Π (b : B), P (cod b))
-    (Pglue : Π (a : A), pathover P Pbase (glue a) (Pcod (f a))) : P y :=
-  cofiber.rec Pbase Pcod Pglue y
+    (Pcod : Π (b : B), P (cod b)) (Pbase : P base)
+    (Pglue : Π (a : A), pathover P (Pcod (f a)) (glue a) Pbase) : P y :=
+  cofiber.rec Pcod Pbase Pglue y
 
-  protected definition elim {P : Type} (Pbase : P) (Pcod : B → P)
-    (Pglue : Π (x : A), Pbase = Pcod (f x)) (y : cofiber f) : P :=
-  pushout.elim (λu, Pbase) Pcod Pglue y
+  protected theorem rec_glue {P : cofiber f → Type} (Pcod : Π (b : B), P (cod b)) (Pbase : P base)
+    (Pglue : Π (a : A), pathover P (Pcod (f a)) (glue a) Pbase) (a : A)
+    : apd (cofiber.rec Pcod Pbase Pglue) (cofiber.glue a) = Pglue a :=
+  !pushout.rec_glue
 
-  protected definition elim_on {P : Type} (y : cofiber f) (Pbase : P) (Pcod : B → P)
-    (Pglue : Π (x : A), Pbase = Pcod (f x)) : P :=
-  cofiber.elim Pbase Pcod Pglue y
+  protected definition elim {P : Type} (Pcod : B → P) (Pbase : P)
+    (Pglue : Π (x : A), Pcod (f x) = Pbase) (y : cofiber f) : P :=
+  pushout.elim Pcod (λu, Pbase) Pglue y
 
-  protected theorem elim_glue {P : Type} (y : cofiber f) (Pbase : P) (Pcod : B → P)
-    (Pglue : Π (x : A), Pbase = Pcod (f x)) (a : A)
-    : ap (elim Pbase Pcod Pglue) (glue a) = Pglue a :=
+  protected definition elim_on {P : Type} (y : cofiber f) (Pcod : B → P) (Pbase : P)
+    (Pglue : Π (x : A), Pcod (f x) = Pbase) : P :=
+  cofiber.elim Pcod Pbase Pglue y
+
+  protected theorem elim_glue {P : Type} (Pcod : B → P) (Pbase : P)
+    (Pglue : Π (x : A), Pcod (f x) = Pbase) (a : A)
+    : ap (cofiber.elim Pcod Pbase Pglue) (cofiber.glue a) = Pglue a :=
   !pushout.elim_glue
 
   end
+
 end cofiber
 
 attribute cofiber.base cofiber.cod [constructor]
@@ -78,21 +69,42 @@ notation `ℂ` := pcofiber
 
 namespace cofiber
 
-  variables (A : Type*)
+  variables {A B : Type*} (f : A →* B)
 
-  definition cofiber_unit : pcofiber (pconst A punit) ≃* psusp A :=
+  definition is_contr_cofiber_of_equiv [H : is_equiv f] : is_contr (cofiber f) :=
+  begin
+    fapply is_contr.mk, exact cofiber.base f,
+    intro a, induction a with b a,
+    { exact !glue⁻¹ ⬝ ap inl (right_inv f b) },
+    { reflexivity },
+    { apply eq_pathover_constant_left_id_right, apply move_top_of_left,
+      refine _ ⬝pv natural_square_tr cofiber.glue (left_inv f a) ⬝vp !ap_constant,
+      refine ap02 inl _ ⬝ !ap_compose⁻¹, exact adj f a },
+  end
+
+  definition pcod [constructor] (f : A →* B) : B →* pcofiber f :=
+  pmap.mk (cofiber.cod f) (ap inl (respect_pt f)⁻¹ ⬝ cofiber.glue pt)
+
+  definition pcod_pcompose [constructor] (f : A →* B) : pcod f ∘* f ~* pconst A (ℂ f) :=
+  begin
+    fapply phomotopy.mk,
+    { intro a, exact cofiber.glue a },
+    { exact !con_inv_cancel_left⁻¹ ⬝ idp ◾ (!ap_inv⁻¹ ◾ idp) }
+  end
+
+  definition pcofiber_punit (A : Type*) : pcofiber (pconst A punit) ≃* susp A :=
   begin
     fapply pequiv_of_pmap,
-    { fconstructor, intro x, induction x, exact north, exact south, exact merid x,
-      reflexivity },
+    { fapply pmap.mk, intro x, induction x, exact north, exact south, exact merid x,
+      exact (merid pt)⁻¹ },
     { esimp, fapply adjointify,
       { intro s, induction s, exact inl ⋆, exact inr ⋆, apply glue a },
       { intro s, induction s, do 2 reflexivity, esimp,
         apply eq_pathover, refine _ ⬝hp !ap_id⁻¹, apply hdeg_square,
         refine !(ap_compose (pushout.elim _ _ _)) ⬝ _,
         refine ap _ !elim_merid ⬝ _, apply elim_glue },
-      { intro c, induction c with s, reflexivity,
-        induction s, reflexivity, esimp, apply eq_pathover, apply hdeg_square,
+      { intro c, induction c with u, induction u, reflexivity,
+        reflexivity, esimp, apply eq_pathover, apply hdeg_square,
         refine _ ⬝ !ap_id⁻¹, refine !(ap_compose (pushout.elim _ _ _)) ⬝ _,
         refine ap02 _ !elim_glue ⬝ _, apply elim_merid }},
   end

hott/homotopy/complex_hopf.hlean

@@ -10,6 +10,7 @@ The H-space structure on S¹ and the complex Hopf fibration
 import .hopf .circle types.fin
 
 open eq equiv is_equiv circle is_conn trunc is_trunc sphere susp pointed fiber sphere.ops function
+     join
 
 namespace hopf
 
@@ -28,23 +29,21 @@ namespace hopf
       { apply is_prop.elimo, apply is_trunc_square }}
   end
 
-  open sphere_index
-
-  definition complex_hopf : S 3 → S 2 :=
+  definition complex_hopf' : S 3 → S 2 :=
   begin
     intro x, apply @sigma.pr1 (susp S¹) (hopf S¹),
-    apply inv (hopf.total S¹), apply inv (join.spheres 1 1), exact x
+    apply inv (hopf.total S¹), exact (join_sphere 1 1)⁻¹ᵉ x
   end
 
-  definition complex_phopf [constructor] : S* 3 →* S* 2 :=
-  proof pmap.mk complex_hopf idp qed
+  definition complex_hopf [constructor] : S 3 →* S 2 :=
+  proof pmap.mk complex_hopf' idp qed
 
-  definition pfiber_complex_phopf : pfiber complex_phopf ≃* S* 1 :=
+  definition pfiber_complex_hopf : pfiber complex_hopf ≃* S 1 :=
   begin
     fapply pequiv_of_equiv,
-    { esimp, unfold [complex_hopf],
+    { esimp, unfold [complex_hopf'],
       refine fiber.equiv_precompose (sigma.pr1 ∘ (hopf.total S¹)⁻¹ᵉ)
-        (join.spheres (of_nat 1) (of_nat 1))⁻¹ᵉ _ ⬝e _,
+        (join_sphere 1 1)⁻¹ᵉ _ ⬝e _,
       refine fiber.equiv_precompose _ (hopf.total S¹)⁻¹ᵉ _ ⬝e _,
       apply fiber_pr1 },
     { reflexivity }

hott/homotopy/connectedness.hlean

@@ -24,16 +24,18 @@ namespace is_conn
     : A ≃ B → is_conn n A → is_conn n B :=
   begin
     intros H C,
-    fapply @is_contr_equiv_closed (trunc n A) _,
-    apply trunc_equiv_trunc,
-    assumption
+    exact is_contr_equiv_closed (trunc_equiv_trunc n H) C,
   end
 
+  definition is_conn_equiv_closed_rev (n : ℕ₋₂) {A B : Type} (f : A ≃ B) (H : is_conn n B) :
+    is_conn n A :=
+  is_conn_equiv_closed n f⁻¹ᵉ _
+
+  definition is_conn_of_eq {n m : ℕ₋₂} (p : n = m) {A : Type} (H : is_conn n A) : is_conn m A :=
+  transport (λk, is_conn k A) p H
+
   theorem is_conn_of_le (A : Type) {n k : ℕ₋₂} (H : n ≤ k) [is_conn k A] : is_conn n A :=
-  begin
-    apply is_contr_equiv_closed,
-    apply trunc_trunc_equiv_left _ H
-  end
+  is_contr_equiv_closed (trunc_trunc_equiv_left _ H) _
 
   theorem is_conn_fun_of_le {A B : Type} (f : A → B) {n k : ℕ₋₂} (H : n ≤ k)
     [is_conn_fun k f] : is_conn_fun n f :=
@@ -99,14 +101,14 @@ namespace is_conn
             intro r,
             refine equiv.trans _ (eq_con_inv_equiv_con_eq q p
                                    (ap (λv a, v (f a)) (eq_of_homotopy r))),
-            rewrite [-(ap (λv a, v (f a)) (apd10_eq_of_homotopy r))],
+            rewrite [-(ap (λv a, v (f a)) (apd10_eq_of_homotopy_fn r))],
             rewrite [-(apd10_ap_precompose_dependent f (eq_of_homotopy r))],
             apply equiv.symm,
-            apply eq_equiv_fn_eq (@apd10 A (λa, P (f a)) (λa, g (f a)) (λa, h (f a)))
+            apply eq_equiv_fn_eq_of_is_equiv (@apd10 A (λa, P (f a)) (λa, g (f a)) (λa, h (f a)))
           end,
           apply equiv.trans (sigma.sigma_equiv_sigma_right e'), clear e',
           apply equiv.trans (equiv.symm (sigma.sigma_equiv_sigma_left
-                                           eq_equiv_homotopy)),
+                                           !eq_equiv_homotopy)),
           apply equiv.symm, apply equiv.trans !fiber_eq_equiv,
           apply sigma.sigma_equiv_sigma_right, intro r,
           apply eq_equiv_eq_symm
@@ -175,7 +177,7 @@ namespace is_conn
     begin
       intro a,
       apply is_conn_equiv_closed n (equiv.symm (fiber_const_equiv A a₀ a)),
-      apply @is_contr_equiv_closed _ _ (tr_eq_tr_equiv n a₀ a),
+      apply is_contr_equiv_closed (tr_eq_tr_equiv n a₀ a) _,
     end
 
   end
@@ -223,7 +225,7 @@ namespace is_conn
     : is_surjective f → is_conn_fun -1 f :=
   begin
     intro H, intro b,
-    exact @is_contr_of_inhabited_prop (∥fiber f b∥) (is_trunc_trunc -1 (fiber f b)) (H b),
+    exact is_contr_of_inhabited_prop (H b) _,
   end
 
   definition is_surjection_of_minus_one_conn {A B : Type} (f : A → B)
@@ -237,7 +239,7 @@ namespace is_conn
   λH, @center (∥A∥) H
 
   definition minus_one_conn_of_merely {A : Type} : ∥A∥ → is_conn -1 A :=
-  @is_contr_of_inhabited_prop (∥A∥) (is_trunc_trunc -1 A)
+  λx, is_contr_of_inhabited_prop x _
 
   section
     open arrow
@@ -261,6 +263,7 @@ namespace is_conn
   @retract_of_conn_is_conn _ _
     (arrow.arrow_hom_of_homotopy p) (arrow.is_retraction_arrow_hom_of_homotopy p) n H
 
+  /- introduction rules for connectedness -/
   -- all types are -2-connected
   definition is_conn_minus_two (A : Type) : is_conn -2 A :=
   _
@@ -269,17 +272,36 @@ namespace is_conn
   definition is_conn_minus_one (A : Type) (a : ∥ A ∥) : is_conn -1 A :=
   is_contr.mk a (is_prop.elim _)
 
+  definition is_conn_minus_one_pointed [instance] (A : Type*) : is_conn -1 A :=
+  is_conn_minus_one A (tr pt)
+
+  definition is_conn_succ_intro {n : ℕ₋₂} {A : Type} (a : trunc (n.+1) A)
+    (H2 : Π(a a' : A), is_conn n (a = a')) : is_conn (n.+1) A :=
+  begin
+    refine is_contr_of_inhabited_prop _ _,
+    { exact a },
+    { apply is_trunc_succ_intro,
+      refine trunc.rec _, intro a, refine trunc.rec _, intro a',
+      exact is_contr_equiv_closed !tr_eq_tr_equiv⁻¹ᵉ _ }
+  end
+
+  definition is_conn_zero {A : Type} (a₀ : trunc 0 A) (p : Πa a' : A, ∥ a = a' ∥) : is_conn 0 A :=
+  is_conn_succ_intro a₀ (λa a', is_conn_minus_one _ (p a a'))
+
+  definition is_conn_zero_pointed {A : Type*} (p : Πa a' : A, ∥ a = a' ∥) : is_conn 0 A :=
+  is_conn_zero (tr pt) p
+
+  definition is_conn_zero_pointed' {A : Type*} (p : Πa : A, ∥ a = pt ∥) : is_conn 0 A :=
+  is_conn_zero_pointed (λa a', tconcat (p a) (tinverse (p a')))
+
+  /- connectedness of certain types -/
   definition is_conn_trunc [instance] (A : Type) (n k : ℕ₋₂) [H : is_conn n A]
     : is_conn n (trunc k A) :=
-  begin
-    apply is_trunc_equiv_closed, apply trunc_trunc_equiv_trunc_trunc
-  end
+  is_contr_equiv_closed !trunc_trunc_equiv_trunc_trunc _
 
   definition is_conn_eq [instance] (n : ℕ₋₂) {A : Type} (a a' : A) [is_conn (n.+1) A] :
     is_conn n (a = a') :=
-  begin
-    apply is_trunc_equiv_closed, apply tr_eq_tr_equiv,
-  end
+  is_contr_equiv_closed !tr_eq_tr_equiv _
 
   definition is_conn_loop [instance] (n : ℕ₋₂) (A : Type*) [is_conn (n.+1) A] : is_conn n (Ω A) :=
   !is_conn_eq
@@ -289,12 +311,71 @@ namespace is_conn
     : is_conn n (ptrunc k A) :=
   is_conn_trunc A n k
 
-  -- the following trivial cases are solved by type class inference
+  definition is_conn_pathover (n : ℕ₋₂) {A : Type} {B : A → Type} {a a' : A} (p : a = a') (b : B a)
+    (b' : B a') [is_conn (n.+1) (B a')] : is_conn n (b =[p] b') :=
+  is_conn_equiv_closed_rev n !pathover_equiv_tr_eq _
+
+  open sigma
+  lemma is_conn_sigma [instance] {A : Type} (B : A → Type) (n : ℕ₋₂)
+    [HA : is_conn n A] [HB : Πa, is_conn n (B a)] : is_conn n (Σa, B a) :=
+  begin
+    revert A B HA HB, induction n with n IH: intro A B HA HB,
+    { apply is_conn_minus_two },
+    apply is_conn_succ_intro,
+    { induction center (trunc (n.+1) A) with a, induction center (trunc (n.+1) (B a)) with b,
+      exact tr ⟨a, b⟩ },
+    intro a a', refine is_conn_equiv_closed_rev n !sigma_eq_equiv _,
+    apply IH, apply is_conn_eq, intro p, apply is_conn_pathover
+    /- an alternative proof of the successor case -/
+    -- induction center (trunc (n.+1) A) with a₀,
+    -- induction center (trunc (n.+1) (B a₀)) with b₀,
+    -- apply is_contr.mk (tr ⟨a₀, b₀⟩),
+    -- intro ab, induction ab with ab, induction ab with a b,
+    -- induction tr_eq_tr_equiv n a₀ a !is_prop.elim with p, induction p,
+    -- induction tr_eq_tr_equiv n b₀ b !is_prop.elim with q, induction q,
+    -- reflexivity
+  end
+
+  lemma is_conn_prod [instance] (A B : Type) (n : ℕ₋₂) [is_conn n A] [is_conn n B] :
+    is_conn n (A × B) :=
+  is_conn_equiv_closed n !sigma.equiv_prod _
+
+  lemma is_conn_fun_of_is_conn {A B : Type} (n : ℕ₋₂) (f : A → B)
+    [HA : is_conn n A] [HB : is_conn (n.+1) B] : is_conn_fun n f :=
+  λb, is_conn_equiv_closed_rev n !fiber.sigma_char _
+
+  definition is_conn_fiber_of_is_conn (n : ℕ₋₂) {A B : Type} (f : A → B) (b : B) [is_conn n A]
+    [is_conn (n.+1) B] : is_conn n (fiber f b) :=
+  is_conn_fun_of_is_conn n f b
+
+  lemma is_conn_pfiber_of_is_conn {A B : Type*} (n : ℕ₋₂) (f : A →* B)
+    [HA : is_conn n A] [HB : is_conn (n.+1) B] : is_conn n (pfiber f) :=
+  is_conn_fun_of_is_conn n f pt
+
   definition is_conn_of_is_contr (k : ℕ₋₂) (A : Type) [is_contr A] : is_conn k A := _
+
+  definition is_conn_succ_of_is_conn_loop {n : ℕ₋₂} {A : Type*}
+    (H : is_conn 0 A) (H2 : is_conn n (Ω A)) : is_conn (n.+1) A :=
+  begin
+    apply is_conn_succ_intro, exact tr pt,
+    intros a a',
+    induction merely_of_minus_one_conn (is_conn_eq -1 a a') with p, induction p,
+    induction merely_of_minus_one_conn (is_conn_eq -1 pt a) with p, induction p,
+    exact H2
+  end
+
+  /- connected functions -/
   definition is_conn_fun_of_is_equiv (k : ℕ₋₂) {A B : Type} (f : A → B) [is_equiv f] :
     is_conn_fun k f :=
   _
 
+  definition is_conn_fun_id (k : ℕ₋₂) (A : Type) : is_conn_fun k (@id A) :=
+  λa, _
+
+  definition is_conn_fun_compose (k : ℕ₋₂) {A B C : Type} {g : B → C} {f : A → B}
+    (Hg : is_conn_fun k g) (Hf : is_conn_fun k f) : is_conn_fun k (g ∘ f) :=
+  λc, is_conn_equiv_closed_rev k (fiber_compose_equiv g f c) _
+
   -- Lemma 7.5.14
   theorem is_equiv_trunc_functor_of_is_conn_fun [instance] {A B : Type} (n : ℕ₋₂) (f : A → B)
     [H : is_conn_fun n f] : is_equiv (trunc_functor n f) :=
@@ -306,15 +387,19 @@ namespace is_conn
     { intro a, induction a with a, esimp, rewrite [center_eq (tr (fiber.mk a idp))]}
   end
 
-  theorem trunc_equiv_trunc_of_is_conn_fun {A B : Type} (n : ℕ₋₂) (f : A → B)
+  definition trunc_equiv_trunc_of_is_conn_fun {A B : Type} (n : ℕ₋₂) (f : A → B)
     [H : is_conn_fun n f] : trunc n A ≃ trunc n B :=
   equiv.mk (trunc_functor n f) (is_equiv_trunc_functor_of_is_conn_fun n f)
 
+  definition ptrunc_pequiv_ptrunc_of_is_conn_fun {A B : Type*} (n : ℕ₋₂) (f : A →* B)
+    [H : is_conn_fun n f] : ptrunc n A ≃* ptrunc n B :=
+  pequiv_of_pmap (ptrunc_functor n f) (is_equiv_trunc_functor_of_is_conn_fun n f)
+
   definition is_conn_fun_trunc_functor_of_le {n k : ℕ₋₂} {A B : Type} (f : A → B) (H : k ≤ n)
     [H2 : is_conn_fun k f] : is_conn_fun k (trunc_functor n f) :=
   begin
     apply is_conn_fun.intro,
-    intro P, have Πb, is_trunc n (P b), from (λb, is_trunc_of_le _ H),
+    intro P, have Πb, is_trunc n (P b), from (λb, is_trunc_of_le _ H _),
     fconstructor,
     { intro f' b,
       induction b with b,
@@ -327,7 +412,7 @@ namespace is_conn
     [H2 : is_conn_fun k f] : is_conn_fun k (trunc_functor n f) :=
   begin
     apply is_conn_fun_of_is_equiv,
-    apply is_equiv_trunc_functor_of_le f H
+    exact is_equiv_trunc_functor_of_le f H _
   end
 
   -- Exercise 7.18
@@ -343,8 +428,8 @@ namespace is_conn
   definition is_conn_fun_lift_functor (n : ℕ₋₂) {A B : Type} (f : A → B) [is_conn_fun n f] :
     is_conn_fun n (lift_functor f) :=
   begin
-    intro b, cases b with b, apply is_trunc_equiv_closed_rev,
-    { apply trunc_equiv_trunc, apply fiber_lift_functor}
+    intro b, cases b with b,
+    exact is_contr_equiv_closed_rev (trunc_equiv_trunc _ !fiber_lift_functor) _
   end
 
   open trunc_index
@@ -365,6 +450,73 @@ namespace is_conn
     rewrite -of_nat_add_two, exact _
   end
 
+  definition is_conn_fun_trunc_elim_of_le {n k : ℕ₋₂} {A B : Type} [is_trunc n B] (f : A → B)
+    (H : k ≤ n) [H2 : is_conn_fun k f] : is_conn_fun k (trunc.elim f : trunc n A → B) :=
+  begin
+    apply is_conn_fun.intro,
+    intro P, have Πb, is_trunc n (P b), from (λb, is_trunc_of_le _ H _),
+    fconstructor,
+    { intro f' b,
+      refine is_conn_fun.elim k H2 _ _ b, intro a, exact f' (tr a) },
+    { intro f', apply eq_of_homotopy, intro a,
+      induction a with a, esimp, rewrite [is_conn_fun.elim_β] }
+  end
+
+  definition is_conn_fun_trunc_elim_of_ge {n k : ℕ₋₂} {A B : Type} [is_trunc n B] (f : A → B)
+    (H : n ≤ k) [H2 : is_conn_fun k f] : is_conn_fun k (trunc.elim f : trunc n A → B) :=
+  begin
+   apply is_conn_fun_of_is_equiv,
+   have H3 : is_equiv (trunc_functor k f), from !is_equiv_trunc_functor_of_is_conn_fun,
+   have H4 : is_equiv (trunc_functor n f), from is_equiv_trunc_functor_of_le _ H _,
+   apply is_equiv_of_equiv_of_homotopy (equiv.mk (trunc_functor n f) _ ⬝e !trunc_equiv),
+   intro x, induction x, reflexivity
+  end
+
+  definition is_conn_fun_trunc_elim {n k : ℕ₋₂} {A B : Type} [is_trunc n B] (f : A → B)
+    [H2 : is_conn_fun k f] : is_conn_fun k (trunc.elim f : trunc n A → B) :=
+  begin
+    eapply algebra.le_by_cases k n: intro H,
+    { exact is_conn_fun_trunc_elim_of_le f H },
+    { exact is_conn_fun_trunc_elim_of_ge f H }
+  end
+
+  lemma is_conn_fun_tr (n : ℕ₋₂) (A : Type) : is_conn_fun n (tr : A → trunc n A) :=
+  begin
+    apply is_conn_fun.intro,
+    intro P,
+    fconstructor,
+    { intro f' b, induction b with a, exact f' a },
+    { intro f', reflexivity }
+  end
+
+  definition is_contr_of_is_conn_of_is_trunc {n : ℕ₋₂} {A : Type} (H : is_trunc n A)
+    (K : is_conn n A) : is_contr A :=
+  is_contr_equiv_closed (trunc_equiv n A) _
+
+  definition is_trunc_succ_succ_of_is_trunc_loop (n : ℕ₋₂) (A : Type*) (H : is_trunc (n.+1) (Ω A))
+    (H2 : is_conn 0 A) : is_trunc (n.+2) A :=
+  begin
+    apply is_trunc_succ_of_is_trunc_loop, apply minus_one_le_succ,
+    refine is_conn.elim -1 _ _, exact H
+  end
+
+  lemma is_trunc_of_is_trunc_loopn (m n : ℕ) (A : Type*) (H : is_trunc n (Ω[m] A))
+    (H2 : is_conn (m.-1) A) : is_trunc (m + n) A :=
+  begin
+    revert A H H2; induction m with m IH: intro A H H2,
+    { rewrite [nat.zero_add], exact H },
+    rewrite [succ_add],
+    apply is_trunc_succ_succ_of_is_trunc_loop,
+    { apply IH,
+      { exact is_trunc_equiv_closed _ !loopn_succ_in _ },
+      apply is_conn_loop },
+    exact is_conn_of_le _ (zero_le_of_nat m)
+  end
+
+  lemma is_trunc_of_is_set_loopn (m : ℕ) (A : Type*) (H : is_set (Ω[m] A))
+    (H2 : is_conn (m.-1) A) : is_trunc m A :=
+  is_trunc_of_is_trunc_loopn m 0 A H H2
+
 end is_conn
 
 /-
@@ -430,12 +582,173 @@ section
   definition is_trunc_ptruncconntype [instance] {n k : ℕ₋₂} (X : n-Type*[k]) :
     is_trunc n (ptruncconntype._trans_of_to_pconntype X) :=
   trunctype.struct X
+end
 
-  definition ptruncconntype_eq {n k : ℕ₋₂} {X Y : n-Type*[k]} (p : X ≃* Y) : X = Y :=
+namespace is_conn
+
+open sigma sigma.ops prod prod.ops
+
+definition pconntype.sigma_char [constructor] (k : ℕ₋₂) :
+  Type*[k] ≃ Σ(X : Type*), is_conn k X :=
+equiv.MK (λX, ⟨pconntype.to_pType X, _⟩)
+         (λX, pconntype.mk (carrier X.1) X.2 pt)
+         begin intro X, induction X with X HX, induction X, reflexivity end
+         begin intro X, induction X, reflexivity end
+
+definition is_embedding_pconntype_to_pType (k : ℕ₋₂) : is_embedding (@pconntype.to_pType k) :=
 begin
-    induction X with X Xt Xp Xc, induction Y with Y Yt Yp Yc,
-    note q := pType_eq_elim (eq_of_pequiv p),
-    cases q with r s, esimp at *, induction r,
-    exact ap0111 (ptruncconntype.mk X) !is_prop.elim (eq_of_pathover_idp s) !is_prop.elim
+  intro X Y, fapply is_equiv_of_equiv_of_homotopy,
+  { exact eq_equiv_fn_eq (pconntype.sigma_char k) _ _ ⬝e subtype_eq_equiv _ _ },
+  intro p, induction p, reflexivity
 end
+
+definition pconntype_eq_equiv {k : ℕ₋₂} (X Y : Type*[k]) : (X = Y) ≃ (X ≃* Y) :=
+equiv.mk _ (is_embedding_pconntype_to_pType k X Y) ⬝e pType_eq_equiv X Y
+
+definition pconntype_eq {k : ℕ₋₂} {X Y : Type*[k]} (e : X ≃* Y) : X = Y :=
+(pconntype_eq_equiv X Y)⁻¹ᵉ e
+
+definition ptruncconntype.sigma_char [constructor] (n k : ℕ₋₂) :
+  n-Type*[k] ≃ Σ(X : Type*), is_trunc n X × is_conn k X :=
+equiv.MK (λX, ⟨ptruncconntype._trans_of_to_pconntype_1 X, (_, _)⟩)
+         (λX, ptruncconntype.mk (carrier X.1) X.2.1 pt X.2.2)
+         begin intro X, induction X with X HX, induction HX, induction X, reflexivity end
+         begin intro X, induction X, reflexivity end
+
+definition ptruncconntype.sigma_char_pconntype [constructor] (n k : ℕ₋₂) :
+  n-Type*[k] ≃ Σ(X : Type*[k]), is_trunc n X :=
+equiv.MK (λX, ⟨ptruncconntype.to_pconntype X, _⟩)
+         (λX, ptruncconntype.mk (pconntype._trans_of_to_pType X.1) X.2 pt _)
+         begin intro X, induction X with X HX, induction HX, induction X, reflexivity end
+         begin intro X, induction X, reflexivity end
+
+definition is_embedding_ptruncconntype_to_pconntype (n k : ℕ₋₂) :
+  is_embedding (@ptruncconntype.to_pconntype n k) :=
+begin
+  intro X Y, fapply is_equiv_of_equiv_of_homotopy,
+  { exact eq_equiv_fn_eq (ptruncconntype.sigma_char_pconntype n k) _ _ ⬝e subtype_eq_equiv _ _ },
+  intro p, induction p, reflexivity
 end
+
+definition ptruncconntype_eq_equiv {n k : ℕ₋₂} (X Y : n-Type*[k]) : (X = Y) ≃ (X ≃* Y) :=
+equiv.mk _ (is_embedding_ptruncconntype_to_pconntype n k X Y) ⬝e pconntype_eq_equiv X Y
+
+definition ptruncconntype_eq {n k : ℕ₋₂} {X Y : n-Type*[k]} (e : X ≃* Y) : X = Y :=
+(ptruncconntype_eq_equiv X Y)⁻¹ᵉ e
+
+definition ptruncconntype_functor [constructor] {n n' k k' : ℕ₋₂} (p : n = n') (q : k = k')
+  (X : n-Type*[k]) : n'-Type*[k'] :=
+ptruncconntype.mk X (is_trunc_of_eq p _) pt (is_conn_of_eq q _)
+
+definition ptruncconntype_equiv [constructor] {n n' k k' : ℕ₋₂} (p : n = n') (q : k = k') :
+  n-Type*[k] ≃ n'-Type*[k'] :=
+equiv.MK (ptruncconntype_functor p q) (ptruncconntype_functor p⁻¹ q⁻¹)
+         (λX, ptruncconntype_eq pequiv.rfl) (λX, ptruncconntype_eq pequiv.rfl)
+
+
+/- the k-connected cover of X, the fiber of the map X → ∥X∥ₖ. -/
+open trunc_index
+
+definition connect (k : ℕ) (X : Type*) : Type* :=
+pfiber (ptr k X)
+
+definition is_conn_connect (k : ℕ) (X : Type*) : is_conn k (connect k X) :=
+is_conn_fun_tr k X (tr pt)
+
+definition connconnect [constructor] (k : ℕ) (X : Type*) : Type*[k]  :=
+pconntype.mk (connect k X) (is_conn_connect k X) pt
+
+definition connect_intro [constructor] {k : ℕ} {X : Type*} {Y : Type*} (H : is_conn k X)
+  (f : X →* Y) : X →* connect k Y :=
+pmap.mk (λx, fiber.mk (f x) (is_conn.elim (k.-1) _ (ap tr (respect_pt f)) x))
+  begin
+    fapply fiber_eq, exact respect_pt f, apply is_conn.elim_β
+  end
+
+definition ppoint_connect_intro [constructor] {k : ℕ} {X : Type*} {Y : Type*} (H : is_conn k X)
+  (f : X →* Y) : ppoint (ptr k Y) ∘* connect_intro H f ~* f :=
+begin
+  induction f with f f₀, induction Y with Y y₀, esimp at (f,f₀), induction f₀,
+  fapply phomotopy.mk,
+  { intro x, reflexivity },
+  { symmetry, esimp, apply point_fiber_eq }
+end
+
+definition connect_intro_ppoint [constructor] {k : ℕ} {X : Type*} {Y : Type*} (H : is_conn k X)
+  (f : X →* connect k Y) : connect_intro H (ppoint (ptr k Y) ∘* f) ~* f :=
+begin
+  cases f with f f₀,
+  fapply phomotopy.mk,
+  { intro x, fapply fiber_eq, reflexivity,
+    refine @is_conn.elim (k.-1) _ _ _ (λx', !is_trunc_eq) _ x,
+    refine !is_conn.elim_β ⬝ _,
+    refine _ ⬝ !idp_con⁻¹,
+    symmetry, refine _ ⬝ !con_idp, exact fiber_eq_pr2 f₀ },
+  { esimp, refine whisker_left _ !fiber_eq_eta ⬝ !fiber_eq_con ⬝ apd011 fiber_eq !idp_con _, esimp,
+    apply eq_pathover_constant_left,
+    refine whisker_right _ (whisker_right _ (whisker_right _ !is_conn.elim_β)) ⬝pv _,
+    esimp [connect], refine _ ⬝vp !con_idp,
+    apply move_bot_of_left, refine !idp_con ⬝ !con_idp⁻¹ ⬝ph _,
+    refine !con.assoc ⬝ !con.assoc ⬝pv _, apply whisker_tl,
+    note r := eq_bot_of_square (transpose (whisker_left_idp_square (fiber_eq_pr2 f₀))⁻¹ᵛ),
+    refine !con.assoc⁻¹ ⬝ whisker_right _ r⁻¹ ⬝pv _, clear r,
+    apply move_top_of_left,
+    refine whisker_right_idp (ap_con tr idp (ap point f₀))⁻¹ᵖ ⬝pv _,
+    exact (ap_con_idp_left tr (ap point f₀))⁻¹ʰ }
+end
+
+definition connect_intro_equiv [constructor] {k : ℕ} {X : Type*} (Y : Type*) (H : is_conn k X) :
+  (X →* connect k Y) ≃ (X →* Y) :=
+begin
+  fapply equiv.MK,
+  { intro f, exact ppoint (ptr k Y) ∘*  f },
+  { intro g, exact connect_intro H g },
+  { intro g, apply eq_of_phomotopy, exact ppoint_connect_intro H g },
+  { intro f, apply eq_of_phomotopy, exact connect_intro_ppoint H f }
+end
+
+definition connect_intro_pequiv [constructor] {k : ℕ} {X : Type*} (Y : Type*) (H : is_conn k X) :
+  ppmap X (connect k Y) ≃* ppmap X Y :=
+pequiv_of_equiv (connect_intro_equiv Y H) (eq_of_phomotopy !pcompose_pconst)
+
+definition connect_pequiv {k : ℕ} {X : Type*} (H : is_conn k X) : connect k X ≃* X :=
+@pfiber_pequiv_of_is_contr _ _ (ptr k X) H
+
+definition loop_connect (k : ℕ) (X : Type*) : Ω (connect (k+1) X) ≃* connect k (Ω X) :=
+loop_pfiber (ptr (k+1) X) ⬝e*
+pfiber_pequiv_of_square pequiv.rfl (loop_ptrunc_pequiv k X)
+  (phomotopy_of_phomotopy_pinv_left (ap1_ptr k X))
+
+definition loopn_connect (k : ℕ) (X : Type*) : Ω[k+1] (connect k X) ≃* Ω[k+1] X :=
+loopn_pfiber (k+1) (ptr k X) ⬝e*
+@pfiber_pequiv_of_is_contr _ _ _ (@is_contr_loop_of_is_trunc (k+1) _ !is_trunc_trunc)
+
+definition is_conn_of_is_conn_succ_nat (n : ℕ) (A : Type) [is_conn (n+1) A] : is_conn n A :=
+is_conn_of_is_conn_succ n A
+
+definition connect_functor (k : ℕ) {X Y : Type*} (f : X →* Y) : connect k X →* connect k Y :=
+pfiber_functor f (ptrunc_functor k f) (ptr_natural k f)⁻¹*
+
+definition connect_intro_pequiv_natural {k : ℕ} {X X' : Type*} {Y Y' : Type*} (f : X' →* X)
+  (g : Y →* Y') (H : is_conn k X) (H' : is_conn k X') :
+  psquare (connect_intro_pequiv Y H) (connect_intro_pequiv Y' H')
+          (ppcompose_left (connect_functor k g) ∘* ppcompose_right f)
+          (ppcompose_left g ∘* ppcompose_right f) :=
+begin
+  refine _ ⬝v* _, exact connect_intro_pequiv Y H',
+  { fapply phomotopy.mk,
+    { intro h, apply eq_of_phomotopy, apply passoc },
+    { xrewrite [▸*, pcompose_right_eq_of_phomotopy, pcompose_left_eq_of_phomotopy,
+        -+eq_of_phomotopy_trans],
+      apply ap eq_of_phomotopy, apply passoc_pconst_middle }},
+  { fapply phomotopy.mk,
+    { intro h, apply eq_of_phomotopy,
+      refine !passoc⁻¹* ⬝* pwhisker_right h (ppoint_natural _ _ _) ⬝* !passoc },
+    { xrewrite [▸*, +pcompose_left_eq_of_phomotopy, -+eq_of_phomotopy_trans],
+      apply ap eq_of_phomotopy,
+      refine !trans_assoc ⬝ idp ◾** !passoc_pconst_right ⬝ _,
+      refine !trans_assoc ⬝ idp ◾** !pcompose_pconst_phomotopy ⬝ _,
+      apply symm_trans_eq_of_eq_trans, symmetry, apply passoc_pconst_right }}
+end
+
+end is_conn

hott/homotopy/cylinder.hlean

@@ -67,7 +67,7 @@ section
     (Pseg : Π(a : A), Pbase (f a) = Ptop a)
     (a : A) : ap (elim Pbase Ptop Pseg) (seg a) = Pseg a :=
   begin
-    apply eq_of_fn_eq_fn_inv !(pathover_constant (seg a)),
+    apply inj_inv !(pathover_constant (seg a)),
     rewrite [▸*,-apd_eq_pathover_of_eq_ap,↑elim,rec_seg],
   end
 

hott/homotopy/freudenthal.hlean

@@ -17,12 +17,12 @@ namespace freudenthal section
   /-
     This proof is ported from Agda
     This is the 95% version of the Freudenthal Suspension Theorem, which means that we don't
-    prove that loop_psusp_unit : A →* Ω(psusp A) is 2n-connected (if A is n-connected),
+    prove that loop_susp_unit : A →* Ω(susp A) is 2n-connected (if A is n-connected),
     but instead we only prove that it induces an equivalence on the first 2n homotopy groups.
   -/
 
   private definition up (a : A) : north = north :> susp A :=
-  loop_psusp_unit A a
+  loop_susp_unit A a
 
   definition code_merid : A → ptrunc (n + n) A → ptrunc (n + n) A :=
   begin
@@ -49,9 +49,9 @@ namespace freudenthal section
   definition is_equiv_code_merid (a : A) : is_equiv (code_merid a) :=
   begin
     have Πa, is_trunc n.-2.+1 (is_equiv (code_merid a)),
-      from λa, is_trunc_of_le _ !minus_one_le_succ,
+      from λa, is_trunc_of_le _ !minus_one_le_succ _,
     refine is_conn.elim (n.-1) _ _ a,
-    { esimp, exact homotopy_closed id (homotopy.symm (code_merid_β_right))}
+    { esimp, exact homotopy_closed id code_merid_β_right⁻¹ʰᵗʸ _ }
   end
 
   definition code_merid_equiv [constructor] (a : A) : trunc (n + n) A ≃ trunc (n + n) A :=
@@ -60,7 +60,7 @@ namespace freudenthal section
   definition code_merid_inv_pt (x : trunc (n + n) A) : (code_merid_equiv pt)⁻¹ x = x :=
   begin
     refine ap010 @(is_equiv.inv _) _ x ⬝ _,
-    { exact homotopy_closed id (homotopy.symm code_merid_β_right)},
+    { exact homotopy_closed id code_merid_β_right⁻¹ʰᵗʸ _ },
     { apply is_conn.elim_β},
     { reflexivity}
   end
@@ -127,7 +127,7 @@ namespace freudenthal section
 
   theorem decode_coh (a : A) : decode_north =[merid a] decode_south :=
   begin
-    apply arrow_pathover_left, intro c, esimp at *,
+    apply arrow_pathover_left, intro c,
     induction c with a',
     rewrite [↑code, elim_type_merid],
     refine @wedge_extension.ext _ _ n n _ _ (λ a a', tr (up a') =[merid a] decode_south
@@ -155,77 +155,88 @@ namespace freudenthal section
   end
 
   parameters (A n)
-  definition equiv' : trunc (n + n) A ≃ trunc (n + n) (Ω (psusp A)) :=
+  definition equiv' : trunc (n + n) A ≃ trunc (n + n) (Ω (susp A)) :=
   equiv.MK decode_north encode decode_encode encode_decode_north
 
-  definition pequiv' : ptrunc (n + n) A ≃* ptrunc (n + n) (Ω (psusp A)) :=
+  definition pequiv' : ptrunc (n + n) A ≃* ptrunc (n + n) (Ω (susp A)) :=
   pequiv_of_equiv equiv' decode_north_pt
 
   -- We don't prove this:
-  -- theorem freudenthal_suspension : is_conn_fun (n+n) (loop_psusp_unit A) := sorry
+  -- theorem freudenthal_suspension : is_conn_fun (n+n) (loop_susp_unit A) := sorry
 
 end end freudenthal
 
 open algebra group
-definition freudenthal_pequiv (A : Type*) {n k : ℕ} [is_conn n A] (H : k ≤ 2 * n)
-  : ptrunc k A ≃* ptrunc k (Ω (psusp A)) :=
+definition freudenthal_pequiv {n k : ℕ} (H : k ≤ 2 * n) (A : Type*) [is_conn n A]
+  : ptrunc k A ≃* ptrunc k (Ω (susp A)) :=
 have H' : k ≤[ℕ₋₂] n + n,
   by rewrite [mul.comm at H, -algebra.zero_add n at {1}]; exact of_nat_le_of_nat H,
 ptrunc_pequiv_ptrunc_of_le H' (freudenthal.pequiv' A n)
 
-definition freudenthal_equiv {A : Type*} {n k : ℕ} [is_conn n A] (H : k ≤ 2 * n)
-  : trunc k A ≃ trunc k (Ω (psusp A)) :=
-freudenthal_pequiv A H
+definition freudenthal_equiv {n k : ℕ} (H : k ≤ 2 * n) (A : Type*) [is_conn n A]
+  : trunc k A ≃ trunc k (Ω (susp A)) :=
+freudenthal_pequiv H A
 
-definition freudenthal_homotopy_group_pequiv (A : Type*) {n k : ℕ} [is_conn n A] (H : k ≤ 2 * n)
-  : π[k + 1] (psusp A) ≃* π[k] A  :=
+definition freudenthal_homotopy_group_pequiv {n k : ℕ} (H : k ≤ 2 * n) (A : Type*) [is_conn n A]
+  : π[k + 1] (susp A) ≃* π[k] A  :=
 calc
-  π[k + 1] (psusp A) ≃* π[k] (Ω (psusp A)) : homotopy_group_succ_in (psusp A) k
-    ... ≃* Ω[k] (ptrunc k (Ω (psusp A)))     : homotopy_group_pequiv_loop_ptrunc k (Ω (psusp A))
-    ... ≃* Ω[k] (ptrunc k A)                 : loopn_pequiv_loopn k (freudenthal_pequiv A H)
+  π[k + 1] (susp A) ≃* π[k] (Ω (susp A)) : homotopy_group_succ_in k (susp A)
+    ... ≃* Ω[k] (ptrunc k (Ω (susp A)))  : homotopy_group_pequiv_loop_ptrunc k (Ω (susp A))
+    ... ≃* Ω[k] (ptrunc k A)             : loopn_pequiv_loopn k (freudenthal_pequiv H A)
     ... ≃* π[k] A                        : (homotopy_group_pequiv_loop_ptrunc k A)⁻¹ᵉ*
 
-definition freudenthal_homotopy_group_isomorphism (A : Type*) {n k : ℕ} [is_conn n A]
-  (H : k + 1 ≤ 2 * n) : πg[k+2] (psusp A) ≃g πg[k + 1] A :=
+definition freudenthal_homotopy_group_isomorphism {n k : ℕ} (H : k + 1 ≤ 2 * n)
+  (A : Type*) [is_conn n A] : πg[k+2] (susp A) ≃g πg[k + 1] A :=
 begin
   fapply isomorphism_of_equiv,
-  { exact equiv_of_pequiv (freudenthal_homotopy_group_pequiv A H)},
+  { exact equiv_of_pequiv (freudenthal_homotopy_group_pequiv H A)},
   { intro g h,
     refine _ ⬝ !homotopy_group_pequiv_loop_ptrunc_inv_con,
-    apply ap !homotopy_group_pequiv_loop_ptrunc⁻¹ᵉ*,
+    refine ap !homotopy_group_pequiv_loop_ptrunc⁻¹ᵉ* _,
     refine ap (loopn_pequiv_loopn _ _) _ ⬝ !loopn_pequiv_loopn_con,
     refine ap !homotopy_group_pequiv_loop_ptrunc _ ⬝ !homotopy_group_pequiv_loop_ptrunc_con,
     apply homotopy_group_succ_in_con}
 end
 
-  definition to_pmap_freudenthal_pequiv {A : Type*} (n k : ℕ) [is_conn n A] (H : k ≤ 2 * n)
-    : freudenthal_pequiv A H ~* ptrunc_functor k (loop_psusp_unit A) :=
+definition to_pmap_freudenthal_pequiv (n k : ℕ) (H : k ≤ 2 * n) (A : Type*) [is_conn n A]
+  : freudenthal_pequiv H A ~* ptrunc_functor k (loop_susp_unit A) :=
 begin
   fapply phomotopy.mk,
   { intro x, induction x with a, reflexivity },
   { refine !idp_con ⬝ _, refine _ ⬝ ap02 _ !idp_con⁻¹, refine _ ⬝ !ap_compose, apply ap_compose }
 end
 
-  definition ptrunc_elim_freudenthal_pequiv {A B : Type*} (n k : ℕ) [is_conn n A] (H : k ≤ 2 * n)
+definition ptrunc_elim_freudenthal_pequiv (n k : ℕ) (H : k ≤ 2 * n) {A B : Type*} [is_conn n A]
   (f : A →* Ω B) [is_trunc (k.+1) (B)] :
-    ptrunc.elim k (Ω→ (psusp.elim f)) ∘* freudenthal_pequiv A H ~* ptrunc.elim k f :=
+  ptrunc.elim k (Ω→ (susp_elim f)) ∘* freudenthal_pequiv H A ~* ptrunc.elim k f :=
 begin
   refine pwhisker_left _ !to_pmap_freudenthal_pequiv ⬝* _,
   refine !ptrunc_elim_ptrunc_functor ⬝* _,
-    exact ptrunc_elim_phomotopy k !ap1_psusp_elim,
+  exact ptrunc_elim_phomotopy k !ap1_susp_elim,
+end
+
+definition freudenthal_pequiv_trunc_index' (A : Type*) (n : ℕ) (k : ℕ₋₂) [HA : is_conn n A]
+  (H : k ≤ of_nat (2 * n)) : ptrunc k A ≃* ptrunc k (Ω (susp A)) :=
+begin
+  assert lem : Π(l : ℕ₋₂), l ≤ 0 → ptrunc l A ≃* ptrunc l (Ω (susp A)),
+  { intro l H', exact ptrunc_pequiv_ptrunc_of_le H' (freudenthal_pequiv (zero_le (2 * n)) A) },
+  cases k with k, { exact lem -2 (minus_two_le 0) },
+  cases k with k, { exact lem -1 (succ_le_succ (minus_two_le -1)) },
+  rewrite [-of_nat_add_two at *, add_two_sub_two at HA],
+  exact freudenthal_pequiv (le_of_of_nat_le_of_nat H) A
 end
 
 namespace susp
 
-  definition iterate_psusp_stability_pequiv (A : Type*) {k n : ℕ} [is_conn 0 A]
-    (H : k ≤ 2 * n) : π[k + 1] (iterate_psusp (n + 1) A) ≃* π[k] (iterate_psusp n A) :=
-  have is_conn n (iterate_psusp n A), by rewrite [-zero_add n]; exact _,
-  freudenthal_homotopy_group_pequiv (iterate_psusp n A) H
+definition iterate_susp_stability_pequiv_of_is_conn_0 (A : Type*) {k n : ℕ} [is_conn 0 A]
+  (H : k ≤ 2 * n) : π[k + 1] (iterate_susp (n + 1) A) ≃* π[k] (iterate_susp n A) :=
+have is_conn n (iterate_susp n A), by rewrite [-zero_add n]; exact _,
+freudenthal_homotopy_group_pequiv H (iterate_susp n A)
 
-  definition iterate_psusp_stability_isomorphism (A : Type*) {k n : ℕ} [is_conn 0 A]
-    (H : k + 1 ≤ 2 * n) : πg[k+2] (iterate_psusp (n + 1) A) ≃g πg[k+1] (iterate_psusp n A) :=
-  have is_conn n (iterate_psusp n A), by rewrite [-zero_add n]; exact _,
-  freudenthal_homotopy_group_isomorphism (iterate_psusp n A) H
+definition iterate_susp_stability_isomorphism_of_is_conn_0 {k n : ℕ} (H : k + 1 ≤ 2 * n)
+  (A : Type*) [is_conn 0 A] : πg[k+2] (iterate_susp (n + 1) A) ≃g πg[k+1] (iterate_susp n A) :=
+have is_conn n (iterate_susp n A), by rewrite [-zero_add n]; exact _,
+freudenthal_homotopy_group_isomorphism H (iterate_susp n A)
 
 definition stability_helper1 {k n : ℕ} (H : k + 2 ≤ 2 * n) : k ≤ 2 * pred n :=
 begin
@@ -233,34 +244,28 @@ namespace susp
   apply pred_le_pred, apply pred_le_pred, exact H
 end
 
-  definition stability_helper2 (A : Type) {k n : ℕ} (H : k + 2 ≤ 2 * n) :
-    is_conn (pred n) (iterate_susp (n + 1) A) :=
-  have Π(n : ℕ), n = -2 + (succ n + 1),
+definition stability_helper2 {k n : ℕ} (H : k + 2 ≤ 2 * n) (A : Type*) :
+  is_conn (pred n) (iterate_susp n A) :=
+have Π(n : ℕ), n = -1 + (n + 1),
 begin intro n, induction n with n IH, reflexivity, exact ap succ IH end,
 begin
   cases n with n,
   { exfalso, exact not_succ_le_zero _ H },
-    { esimp, rewrite [this n], apply is_conn_iterate_susp}
+  { esimp, rewrite [this n], exact is_conn_iterate_susp -1 _ A }
 end
 
-  definition iterate_susp_stability_pequiv (A : Type) {k n : ℕ}
-    (H : k + 2 ≤ 2 * n) : π[k + 1] (pointed.MK (iterate_susp (n + 2) A) !north) ≃*
-                          π[k    ] (pointed.MK (iterate_susp (n + 1) A) !north) :=
-  have is_conn (pred n) (carrier (pointed.MK (iterate_susp (n + 1) A) !north)), from
-    stability_helper2 A H,
-  freudenthal_homotopy_group_pequiv (pointed.MK (iterate_susp (n + 1) A) !north)
-                                    (stability_helper1 H)
+definition iterate_susp_stability_pequiv {k n : ℕ} (H : k + 2 ≤ 2 * n) (A : Type*) :
+  π[k + 1] (iterate_susp (n + 1) A) ≃* π[k] (iterate_susp n A) :=
+have is_conn (pred n) (iterate_susp n A), from stability_helper2 H A,
+freudenthal_homotopy_group_pequiv (stability_helper1 H) (iterate_susp n A)
 
-  definition iterate_susp_stability_isomorphism (A : Type) {k n : ℕ}
-    (H : k + 3 ≤ 2 * n) : πg[k+1 +1] (pointed.MK (iterate_susp (n + 2) A) !north) ≃g
-                          πg[k+1]    (pointed.MK (iterate_susp (n + 1) A) !north) :=
-  have is_conn (pred n) (carrier (pointed.MK (iterate_susp (n + 1) A) !north)), from
-    @stability_helper2 A (k+1) n H,
-  freudenthal_homotopy_group_isomorphism (pointed.MK (iterate_susp (n + 1) A) !north)
-                                         (stability_helper1 H)
+definition iterate_susp_stability_isomorphism {k n : ℕ} (H : k + 3 ≤ 2 * n) (A : Type*) :
+  πg[k+2] (iterate_susp (n + 1) A) ≃g πg[k+1] (iterate_susp n A) :=
+have is_conn (pred n) (iterate_susp n A), from @stability_helper2 (k+1) n H A,
+freudenthal_homotopy_group_isomorphism (stability_helper1 H) (iterate_susp n A)
 
-  definition iterated_freudenthal_pequiv (A : Type*) {n k m : ℕ} [HA : is_conn n A] (H : k ≤ 2 * n)
-    : ptrunc k A ≃* ptrunc k (Ω[m] (iterate_psusp m A)) :=
+definition iterated_freudenthal_pequiv {n k m : ℕ} (H : k ≤ 2 * n) (A : Type*) [HA : is_conn n A]
+  : ptrunc k A ≃* ptrunc k (Ω[m] (iterate_susp m A)) :=
 begin
   revert A n k HA H, induction m with m IH: intro A n k HA H,
   { reflexivity },
@@ -269,13 +274,14 @@ namespace susp
       succ k ≤ succ (2 * n) : succ_le_succ H
          ... ≤ 2 * succ n   : self_le_succ,
     exact calc
-        ptrunc k A ≃* ptrunc k (Ω (psusp A))   : freudenthal_pequiv A H
-          ... ≃* Ω (ptrunc (succ k) (psusp A)) : loop_ptrunc_pequiv
-          ... ≃* Ω (ptrunc (succ k) (Ω[m] (iterate_psusp m (psusp A)))) :
-                   loop_pequiv_loop (IH (psusp A) (succ n) (succ k) _ H2)
-          ... ≃* ptrunc k (Ω[succ m] (iterate_psusp m (psusp A))) : loop_ptrunc_pequiv
-          ... ≃* ptrunc k (Ω[succ m] (iterate_psusp (succ m) A)) :
-                   ptrunc_pequiv_ptrunc _ (loopn_pequiv_loopn _ !iterate_psusp_succ_in)}
+      ptrunc k A ≃* ptrunc k (Ω (susp A))   : freudenthal_pequiv H A
+        ... ≃* Ω (ptrunc (succ k) (susp A)) : loop_ptrunc_pequiv
+        ... ≃* Ω (ptrunc (succ k) (Ω[m] (iterate_susp m (susp A)))) :
+                 loop_pequiv_loop (IH (susp A) (succ n) (succ k) _ H2)
+        ... ≃* ptrunc k (Ω[succ m] (iterate_susp m (susp A))) : loop_ptrunc_pequiv
+        ... ≃* ptrunc k (Ω[succ m] (iterate_susp (succ m) A)) :
+                 ptrunc_pequiv_ptrunc _ (loopn_pequiv_loopn _ !iterate_susp_succ_in)}
 end
 
+
 end susp

hott/homotopy/homotopy_group.hlean

@@ -7,7 +7,7 @@ Authors: Floris van Doorn, Clive Newstead
 
 import .LES_of_homotopy_groups .sphere .complex_hopf
 
-open eq is_trunc trunc_index pointed algebra trunc nat is_conn fiber pointed unit
+open eq is_trunc trunc_index pointed algebra trunc nat is_conn fiber pointed unit group
 
 namespace is_trunc
 
@@ -17,7 +17,7 @@ namespace is_trunc
   begin
     apply is_trunc_trunc_of_is_trunc,
     apply is_contr_loop_of_is_trunc,
-    apply @is_trunc_of_le A n _,
+    refine @is_trunc_of_le A n _ _ _,
     apply trunc_index.le_of_succ_le_succ,
     rewrite [succ_sub_two_succ k],
     exact of_nat_le_of_nat H,
@@ -32,36 +32,24 @@ namespace is_trunc
     : is_contr (π[k] A) :=
   begin
     have H3 : is_contr (ptrunc k A), from is_conn_of_le A (of_nat_le_of_nat H),
-      have H4 : is_contr (Ω[k](ptrunc k A)), from !is_trunc_loop_of_is_trunc,
-      apply is_trunc_equiv_closed_rev,
-      { apply equiv_of_pequiv (homotopy_group_pequiv_loop_ptrunc k A)}
+    have H4 : is_contr (Ω[k](ptrunc k A)), from !is_trunc_loopn_of_is_trunc,
+    exact is_trunc_equiv_closed_rev _ (equiv_of_pequiv (homotopy_group_pequiv_loop_ptrunc k A)) _
   end
 
   -- Corollary 8.3.3
-  section
-  open sphere sphere.ops sphere_index
-  theorem homotopy_group_sphere_le (n k : ℕ) (H : k < n) : is_contr (π[k] (S* n)) :=
+  open sphere sphere.ops
+  theorem homotopy_group_sphere_le (n k : ℕ) (H : k < n) : is_contr (π[k] (S n)) :=
   begin
     cases n with n,
     { exfalso, apply not_lt_zero, exact H},
     { have H2 : k ≤ n, from le_of_lt_succ H,
       apply @(trivial_homotopy_group_of_is_conn _ H2) }
   end
-  end
 
   theorem is_contr_HG_fiber_of_is_connected {A B : Type*} (k n : ℕ) (f : A →* B)
     [H : is_conn_fun n f] (H2 : k ≤ n) : is_contr (π[k] (pfiber f)) :=
   @(trivial_homotopy_group_of_is_conn (pfiber f) H2) (H pt)
 
-  theorem homotopy_group_trunc_of_le (A : Type*) (n k : ℕ) (H : k ≤ n)
-    : π[k] (ptrunc n A) ≃* π[k] A :=
-  begin
-    refine !homotopy_group_pequiv_loop_ptrunc ⬝e* _,
-    refine loopn_pequiv_loopn _ (ptrunc_ptrunc_pequiv_left _ _) ⬝e* _,
-    exact of_nat_le_of_nat H,
-    exact !homotopy_group_pequiv_loop_ptrunc⁻¹ᵉ*,
-  end
-
   /- Corollaries of the LES of homotopy groups -/
   local attribute ab_group.to_group [coercion]
   local attribute is_equiv_tinverse [instance]
@@ -81,16 +69,9 @@ namespace is_trunc
       refine is_conn_fun_of_le f (zero_le_of_nat n)},
     { /- k > 0 -/
      have H2' : k ≤ n, from le.trans !self_le_succ H2,
-      exact
-      @is_equiv_of_trivial _
-        (LES_of_homotopy_groups f) _
-        (is_exact_LES_of_homotopy_groups f (k, 2))
-        (is_exact_LES_of_homotopy_groups f (succ k, 0))
+     exact LES_is_equiv_of_trivial f (succ k) 0
              (@is_contr_HG_fiber_of_is_connected A B k n f H H2')
-        (@is_contr_HG_fiber_of_is_connected A B (succ k) n f H H2)
-        (@pgroup_of_group _ (group_LES_of_homotopy_groups f k 0) idp)
-        (@pgroup_of_group _ (group_LES_of_homotopy_groups f k 1) idp)
-        (homomorphism.struct (homomorphism_LES_of_homotopy_groups_fun f (k, 0)))},
+             (@is_contr_HG_fiber_of_is_connected A B (succ k) n f H H2) },
   end
 
   theorem is_equiv_π_of_is_connected.{u v} {A : pType.{u}} {B : pType.{v}} {n k : ℕ} (f : A →* B)
@@ -98,12 +79,12 @@ namespace is_trunc
   begin
     have π→[k] pdown.{v u} ∘* π→[k] (plift_functor f) ∘* π→[k] pup.{u v} ~* π→[k] f,
     begin
-      refine pwhisker_left _ !homotopy_group_functor_compose⁻¹* ⬝* _,
-      refine !homotopy_group_functor_compose⁻¹* ⬝* _,
+      refine pwhisker_left _ !homotopy_group_functor_pcompose⁻¹* ⬝* _,
+      refine !homotopy_group_functor_pcompose⁻¹* ⬝* _,
       apply homotopy_group_functor_phomotopy, apply plift_functor_phomotopy
     end,
     have π→[k] pdown.{v u} ∘ π→[k] (plift_functor f) ∘ π→[k] pup.{u v} ~ π→[k] f, from this,
-    apply is_equiv.homotopy_closed, rotate 1,
+    apply is_equiv.homotopy_closed,
     { exact this},
     { do 2 apply is_equiv_compose,
       { apply is_equiv_homotopy_group_functor, apply to_is_equiv !equiv_lift},
@@ -131,7 +112,7 @@ namespace is_trunc
     (H : Πa k, is_equiv (π→[k + 1] (pmap_of_map f a))) : is_equiv f :=
   begin
     revert A B HA HB f H' H, induction n with n IH: intros,
-    { apply is_equiv_of_is_contr},
+    { exact is_equiv_of_is_contr _ _ _ },
     have Πa, is_equiv (Ω→ (pmap_of_map f a)),
     begin
       intro a,
@@ -143,7 +124,7 @@ namespace is_trunc
       have Π(b : A) (p : a = b),
         is_equiv (pmap.to_fun (π→[k + 1] (pmap_of_map (ap f) p))),
       begin
-        intro b p, induction p, apply is_equiv.homotopy_closed, exact this,
+        intro b p, induction p, refine is_equiv.homotopy_closed _ _ this,
         refine homotopy_group_functor_phomotopy _ _,
         apply ap1_pmap_of_map
       end,
@@ -152,9 +133,10 @@ namespace is_trunc
            pmap.to_fun (π→[k + 1] (pmap_of_map (ap f) p))),
       begin
         apply is_equiv_compose, exact this a p,
+        exact is_equiv_trunc_functor _ _ _
       end,
-      apply is_equiv.homotopy_closed, exact this,
-      refine !homotopy_group_functor_compose⁻¹* ⬝* _,
+      refine is_equiv.homotopy_closed _ _ this,
+      refine !homotopy_group_functor_pcompose⁻¹* ⬝* _,
       apply homotopy_group_functor_phomotopy,
       fapply phomotopy.mk,
       { esimp, intro q, refine !idp_con⁻¹},
@@ -174,13 +156,13 @@ namespace is_trunc
     begin
       apply is_equiv_compose
               (π→[k + 1] (pointed_eta_pequiv B ⬝e* (pequiv_of_eq_pt (respect_pt f))⁻¹ᵉ*)),
-      apply is_equiv_compose (π→[k + 1] f),
-      all_goals apply is_equiv_homotopy_group_functor,
+      refine is_equiv_compose (π→[k + 1] f) _ _ _,
+      all_goals exact is_equiv_homotopy_group_functor _ _ _,
     end,
-    refine @(is_equiv.homotopy_closed _) _ this _,
+    refine is_equiv.homotopy_closed _ _ this,
     apply to_homotopy,
-    refine pwhisker_left _ !homotopy_group_functor_compose⁻¹* ⬝* _,
-    refine !homotopy_group_functor_compose⁻¹* ⬝* _,
+    refine pwhisker_left _ !homotopy_group_functor_pcompose⁻¹* ⬝* _,
+    refine !homotopy_group_functor_pcompose⁻¹* ⬝* _,
     apply homotopy_group_functor_phomotopy, apply phomotopy_pmap_of_map
   end
 
@@ -188,12 +170,12 @@ namespace is_trunc
   definition is_contr_of_trivial_homotopy (n : ℕ₋₂) (A : Type) [is_trunc n A] [is_conn 0 A]
     (H : Πk a, is_contr (π[k] (pointed.MK A a))) : is_contr A :=
   begin
-    fapply is_trunc_is_equiv_closed_rev, { exact λa, ⋆},
+    refine is_trunc_is_equiv_closed_rev _ (λa, ⋆) _ _,
     apply whitehead_principle n,
     { apply is_equiv_trunc_functor_of_is_conn_fun, apply is_conn_fun_to_unit_of_is_conn },
     intro a k,
-    apply @is_equiv_of_is_contr,
-    refine trivial_homotopy_group_of_is_trunc _ !zero_lt_succ,
+    refine is_equiv_of_is_contr _ _ _,
+    exact trivial_homotopy_group_of_is_trunc _ !zero_lt_succ,
   end
 
   definition is_contr_of_trivial_homotopy_nat (n : ℕ) (A : Type) [is_trunc n A] [is_conn 0 A]
@@ -223,6 +205,86 @@ namespace is_trunc
     cases A with A a, exact H k H'
   end
 
+  definition is_trunc_of_trivial_homotopy {n : ℕ} {m : ℕ₋₂} {A : Type} (H : is_trunc m A)
+    (H2 : Πk a, k > n → is_contr (π[k] (pointed.MK A a))) : is_trunc n A :=
+  begin
+    refine is_trunc_is_equiv_closed_rev _ (@tr n A) _ _,
+    apply whitehead_principle m,
+    { apply is_equiv_trunc_functor_of_is_conn_fun,
+      note z := is_conn_fun_tr n A,
+      apply is_conn_fun_of_le _ (of_nat_le_of_nat (zero_le n)), },
+    intro a k,
+    apply @nat.lt_ge_by_cases n (k+1),
+    { intro H3, apply @is_equiv_of_is_contr, exact H2 _ _ H3,
+      refine @trivial_homotopy_group_of_is_trunc _ _ _ _ H3 },
+    { intro H3, apply @(is_equiv_π_of_is_connected _ H3), apply is_conn_fun_tr }
+  end
+
+  definition is_trunc_of_trivial_homotopy_pointed {n : ℕ} {m : ℕ₋₂} {A : Type*} (H : is_trunc m A)
+    (Hconn : is_conn 0 A) (H2 : Πk, k > n → is_contr (π[k] A)) : is_trunc n A :=
+  begin
+    apply is_trunc_of_trivial_homotopy H,
+    intro k a H3, revert a, apply is_conn.elim -1,
+    cases A with A a₀, exact H2 k H3
+  end
+
+  definition is_trunc_of_is_trunc_succ {n : ℕ} {A : Type} (H : is_trunc (n.+1) A)
+    (H2 : Πa, is_contr (π[n+1] (pointed.MK A a))) : is_trunc n A :=
+  begin
+    apply is_trunc_of_trivial_homotopy H,
+    intro k a H3, induction H3 with k H3 IH, exact H2 a,
+    apply @trivial_homotopy_group_of_is_trunc _ (n+1) _ H, exact succ_le_succ H3
+  end
+
+  definition is_trunc_of_is_trunc_succ_pointed {n : ℕ} {A : Type*} (H : is_trunc (n.+1) A)
+    (Hconn : is_conn 0 A) (H2 : is_contr (π[n+1] A)) : is_trunc n A :=
+  begin
+    apply is_trunc_of_trivial_homotopy_pointed H Hconn,
+    intro k H3, induction H3 with k H3 IH, exact H2,
+    apply @trivial_homotopy_group_of_is_trunc _ (n+1) _ H, exact succ_le_succ H3
+  end
+
+  definition ab_group_homotopy_group_of_is_conn (n : ℕ) (A : Type*) [H : is_conn 1 A] :
+    ab_group (π[n] A) :=
+  begin
+    have is_conn 0 A, from !is_conn_of_is_conn_succ,
+    cases n with n,
+    { unfold [homotopy_group, ptrunc], exact ab_group_of_is_contr _ _ },
+    cases n with n,
+    { unfold [homotopy_group, ptrunc], exact ab_group_of_is_contr _ _ },
+    exact ab_group_homotopy_group (n+2) A
+  end
+
+  definition is_contr_of_trivial_homotopy' (n : ℕ₋₂) (A : Type) [is_trunc n A] [is_conn -1 A]
+    (H : Πk a, is_contr (π[k] (pointed.MK A a))) : is_contr A :=
+  begin
+    assert aa : trunc -1 A,
+    { apply center },
+    assert H3 : is_conn 0 A,
+    { induction aa with a, exact H 0 a },
+    exact is_contr_of_trivial_homotopy n A H
+  end
+
+  definition is_conn_of_trivial_homotopy (n : ℕ₋₂) (m : ℕ) (A : Type) [is_trunc n A] [is_conn 0 A]
+    (H : Π(k : ℕ) a, k ≤ m → is_contr (π[k] (pointed.MK A a))) : is_conn m A :=
+  begin
+    apply is_contr_of_trivial_homotopy_nat m (trunc m A),
+    intro k a H2,
+    induction a with a,
+    apply is_trunc_equiv_closed_rev,
+      exact equiv_of_pequiv (homotopy_group_ptrunc_of_le H2 (pointed.MK A a)),
+    exact H k a H2
+  end
+
+  definition is_conn_of_trivial_homotopy_pointed (n : ℕ₋₂) (m : ℕ) (A : Type*) [is_trunc n A]
+    (H : Π(k : ℕ), k ≤ m → is_contr (π[k] A)) : is_conn m A :=
+  begin
+    have is_conn 0 A, proof H 0 !zero_le qed,
+    apply is_conn_of_trivial_homotopy n m A,
+    intro k a H2, revert a, apply is_conn.elim -1,
+    cases A with A a, exact H k H2
+  end
+
   definition is_conn_fun_of_equiv_on_homotopy_groups.{u} (n : ℕ) {A B : Type.{u}} (f : A → B)
     [is_equiv (trunc_functor 0 f)]
     (H1 : Πa k, k ≤ n → is_equiv (homotopy_group_functor k (pmap_of_map f a)))

hott/homotopy/hopf.hlean

@@ -8,7 +8,7 @@ H-spaces and the Hopf construction
 
 import types.equiv .wedge .join
 
-open eq eq.ops equiv is_equiv is_conn is_trunc trunc susp join
+open eq eq.ops equiv is_equiv is_conn is_trunc trunc susp join pointed
 
 namespace hopf
 
@@ -37,7 +37,7 @@ section
   begin
     apply is_conn_fun.elim -1 (is_conn_fun_from_unit -1 A 1)
                            (λa, trunctype.mk' -1 (is_equiv (λx, a * x))),
-    intro z, change is_equiv (λx : A, 1 * x), apply is_equiv.homotopy_closed id,
+    intro z, change is_equiv (λx : A, 1 * x), refine is_equiv.homotopy_closed id _ _,
     intro x, apply inverse, apply one_mul
   end
 
@@ -45,7 +45,7 @@ section
   begin
     apply is_conn_fun.elim -1 (is_conn_fun_from_unit -1 A 1)
                            (λa, trunctype.mk' -1 (is_equiv (λx, x * a))),
-    intro z, change is_equiv (λx : A, x * 1), apply is_equiv.homotopy_closed id,
+    intro z, change is_equiv (λx : A, x * 1), refine is_equiv.homotopy_closed id _ _,
     intro x, apply inverse, apply mul_one
   end
 end
@@ -186,15 +186,15 @@ section
   (equiv.MK decode' encode decode_encode encode_decode')⁻¹ᵉ
 
   definition main_lemma_point
-    : ptrunc 1 (Ω(psusp A)) ≃* pointed.MK A 1 :=
+    : ptrunc 1 (Ω(susp A)) ≃* pointed.MK A 1 :=
   pointed.pequiv_of_equiv main_lemma idp
 
-  protected definition delooping : Ω (ptrunc 2 (psusp A)) ≃* pointed.MK A 1 :=
-  loop_ptrunc_pequiv 1 (psusp A) ⬝e* main_lemma_point
+  protected definition delooping : Ω (ptrunc 2 (susp A)) ≃* pointed.MK A 1 :=
+  loop_ptrunc_pequiv 1 (susp A) ⬝e* main_lemma_point
 
   /- characterization of the underlying pointed maps -/
   definition to_pmap_main_lemma_point_pinv
-    : main_lemma_point⁻¹ᵉ* ~* !ptr ∘* loop_psusp_unit (pointed.MK A 1) :=
+    : main_lemma_point⁻¹ᵉ* ~* !ptr ∘* loop_susp_unit (pointed.MK A 1) :=
   begin
     fapply phomotopy.mk,
     { intro a, reflexivity },
@@ -202,7 +202,7 @@ section
   end
 
   definition to_pmap_delooping_pinv :
-    delooping⁻¹ᵉ* ~* Ω→ !ptr ∘* loop_psusp_unit (pointed.MK A 1) :=
+    delooping⁻¹ᵉ* ~* Ω→ !ptr ∘* loop_susp_unit (pointed.MK A 1) :=
   begin
     refine !trans_pinv ⬝* _,
     refine pwhisker_left _ !to_pmap_main_lemma_point_pinv ⬝* _,
@@ -211,12 +211,12 @@ section
   end
 
   definition hopf_delooping_elim {B : Type*} (f : pointed.MK A 1 →* Ω B) [H2 : is_trunc 2 B] :
-    Ω→(ptrunc.elim 2 (psusp.elim f)) ∘* (hopf.delooping A coh)⁻¹ᵉ* ~* f :=
+    Ω→(ptrunc.elim 2 (susp_elim f)) ∘* (hopf.delooping A coh)⁻¹ᵉ* ~* f :=
   begin
     refine pwhisker_left _ !to_pmap_delooping_pinv ⬝* _,
     refine !passoc⁻¹* ⬝* _,
     refine pwhisker_right _ (!ap1_pcompose⁻¹* ⬝* ap1_phomotopy !ptrunc_elim_ptr) ⬝* _,
-    apply ap1_psusp_elim
+    apply ap1_susp_elim
   end
 
 end

hott/homotopy/imaginaroid.hlean

@@ -8,7 +8,7 @@ Cayley-Dickson construction via imaginaroids
 
 import algebra.group cubical.square types.pi .hopf
 
-open eq eq.ops equiv susp hopf
+open eq eq.ops equiv susp hopf pointed
 open [notation] sum
 
 namespace imaginaroid
@@ -70,7 +70,7 @@ section
     { reflexivity },
     { reflexivity },
     { apply eq_pathover, rewrite ap_id,
-      rewrite (ap_compose' (λy, -y)),
+      rewrite [-(ap_compose' (λy, -y))],
       krewrite susp.elim_merid, rewrite ap_inv,
       krewrite susp.elim_merid, rewrite neg_neg,
       rewrite inv_inv, apply hrefl }
@@ -85,7 +85,7 @@ section
     { reflexivity },
     { reflexivity },
     { apply eq_pathover, rewrite ap_id,
-      krewrite (ap_compose' (λy, y*)),
+      krewrite [-(ap_compose' (λy, y*))],
       do 2 krewrite susp.elim_merid, rewrite neg_neg,
       apply hrefl }
   end
@@ -96,7 +96,7 @@ section
     { reflexivity },
     { reflexivity },
     { apply eq_pathover,
-      krewrite [ap_compose' (λy, y*),ap_compose' (λy, -y) (λy, y*)],
+      krewrite [-ap_compose' (λy, y*),-ap_compose' (λy, -y) (λy, y*)],
       do 3 krewrite susp.elim_merid, rewrite ap_inv, krewrite susp.elim_merid,
       apply hrefl }
   end

hott/homotopy/interval.hlean

@@ -7,7 +7,7 @@ Declaration of the interval
 -/
 
 import .susp types.eq types.prod cubical.square
-open eq susp unit equiv is_trunc nat prod
+open eq susp unit equiv is_trunc nat prod pointed
 
 definition interval : Type₀ := susp unit
 
@@ -44,7 +44,7 @@ namespace interval
   theorem elim_seg {P : Type} (P0 P1 : P) (Ps : P0 = P1)
     : ap (interval.elim P0 P1 Ps) seg = Ps :=
   begin
-    apply eq_of_fn_eq_fn_inv !(pathover_constant seg),
+    apply inj_inv !(pathover_constant seg),
     rewrite [▸*,-apd_eq_pathover_of_eq_ap,↑interval.elim,rec_seg],
   end
 

hott/homotopy/join.hlean

@@ -45,7 +45,7 @@ namespace join
     (Pglue : Π(x : A)(y : B), Pinl x = Pinr y) (x : A) (y : B)
     : ap (join.elim Pinl Pinr Pglue) (glue x y) = Pglue x y :=
   begin
-    apply equiv.eq_of_fn_eq_fn_inv !(pathover_constant (glue x y)),
+    apply equiv.inj_inv !(pathover_constant (glue x y)),
     rewrite [▸*,-apd_eq_pathover_of_eq_ap,↑join.elim],
     apply join.rec_glue
   end
@@ -57,11 +57,11 @@ namespace join
 
   protected definition hsquare {a a' : A} {b b' : B} (p : a = a') (q : b = b') :
     square (ap inl p) (ap inr q) (glue a b) (glue a' b') :=
-  eq.rec_on p (eq.rec_on q hrfl)
+  by induction p; induction q; exact hrfl
 
   protected definition vsquare {a a' : A} {b b' : B} (p : a = a') (q : b = b') :
     square (glue a b) (glue a' b') (ap inl p) (ap inr q) :=
-  eq.rec_on p (eq.rec_on q vrfl)
+  by induction p; induction q; exact vrfl
 
 end
 
@@ -120,7 +120,7 @@ end join
 namespace join
 
   variables {A₁ A₂ B₁ B₂ : Type}
-  protected definition functor [reducible]
+  definition join_functor [reducible]
     (f : A₁ → A₂) (g : B₁ → B₂) : join A₁ B₁ → join A₂ B₂ :=
   begin
     intro x, induction x with a b a b,
@@ -132,12 +132,12 @@ namespace join
     : join.diamond a a' b b' → join.diamond (f a) (f a') (g b) (g b') :=
   begin
     unfold join.diamond, intro s,
-    note s' := aps (join.functor f g) s,
+    note s' := aps (join_functor f g) s,
     do 2 rewrite eq.ap_inv at s',
     do 4 rewrite join.elim_glue at s', exact s'
   end
 
-  protected definition equiv_closed
+  definition join_equiv_join
     : A₁ ≃ A₂ → B₁ ≃ B₂ → join A₁ B₁ ≃ join A₂ B₂ :=
   begin
     intros H K,
@@ -152,13 +152,13 @@ namespace join
       { apply ap inl, apply to_right_inv },
       { apply ap inr, apply to_right_inv },
       { apply eq_pathover, rewrite ap_id,
-        rewrite (ap_compose' (join.elim _ _ _)),
+        rewrite [-(ap_compose' (join.elim _ _ _))],
         do 2 krewrite join.elim_glue, apply join.hsquare } },
     { intro x, induction x with a b a b,
       { apply ap inl, apply to_left_inv },
       { apply ap inr, apply to_left_inv },
       { apply eq_pathover, rewrite ap_id,
-        rewrite (ap_compose' (join.elim _ _ _)),
+        rewrite [-(ap_compose' (join.elim _ _ _))],
         do 2 krewrite join.elim_glue, apply join.hsquare } }
   end
 
@@ -170,7 +170,7 @@ namespace join
     cases p, apply pathover_idp_of_eq, apply join.symm_diamond
   end
 
-  protected definition empty (A : Type) : join empty A ≃ A :=
+  definition join_empty (A : Type) : join empty A ≃ A :=
   begin
     fapply equiv.MK,
     { intro x, induction x with z a z a,
@@ -185,7 +185,7 @@ namespace join
       { induction z } }
   end
 
-  protected definition bool (A : Type) : join bool A ≃ susp A :=
+  definition join_bool (A : Type) : join bool A ≃ susp A :=
   begin
     fapply equiv.MK,
     { intro ba, induction ba with [b, a, b, a],
@@ -202,7 +202,7 @@ namespace join
       { reflexivity },
       { reflexivity },
       { esimp, apply eq_pathover, rewrite ap_id,
-        rewrite (ap_compose' (join.elim _ _ _)),
+        rewrite [-(ap_compose' (join.elim _ _ _))],
         rewrite [susp.elim_merid,ap_con,ap_inv],
         krewrite [join.elim_glue,join.elim_glue],
         esimp, rewrite [inv_inv,idp_con],
@@ -212,13 +212,13 @@ namespace join
       { apply glue },
       { induction b,
         { esimp, apply eq_pathover, rewrite ap_id,
-          rewrite (ap_compose' (susp.elim _ _ _)),
+          rewrite [-(ap_compose' (susp.elim _ _ _))],
           krewrite join.elim_glue, rewrite ap_inv,
           krewrite susp.elim_merid,
           apply square_of_eq_top, apply inverse,
           rewrite con.assoc, apply con.left_inv },
         { esimp, apply eq_pathover, rewrite ap_id,
-          rewrite (ap_compose' (susp.elim _ _ _)),
+          rewrite [-(ap_compose' (susp.elim _ _ _))],
           krewrite join.elim_glue, esimp,
           apply square_of_eq_top,
           rewrite [idp_con,con.right_inv] } } }
@@ -229,7 +229,7 @@ end join
 namespace join
   variables (A B C : Type)
 
-  protected definition is_contr [HA : is_contr A] :
+  definition is_contr_join [HA : is_contr A] :
     is_contr (join A B) :=
   begin
     fapply is_contr.mk, exact inl (center A),
@@ -239,24 +239,24 @@ namespace join
     generalize center_eq a, intro p, cases p, apply idp_con,
   end
 
-  protected definition swap : join A B → join B A :=
+  definition join_swap : join A B → join B A :=
   begin
     intro x, induction x with a b a b, exact inr a, exact inl b,
     apply !glue⁻¹
   end
 
-  protected definition swap_involutive (x : join A B) :
-    join.swap B A (join.swap A B x) = x :=
+  definition join_swap_involutive (x : join A B) :
+    join_swap B A (join_swap A B x) = x :=
   begin
     induction x with a b a b, do 2 reflexivity,
     apply eq_pathover, rewrite ap_id,
-    apply hdeg_square, esimp[join.swap],
-    apply concat, apply ap_compose' (join.elim _ _ _),
+    apply hdeg_square,
+    apply concat, apply ap_compose (join.elim _ _ _),
     krewrite [join.elim_glue, ap_inv, join.elim_glue], apply inv_inv,
   end
 
-  protected definition symm : join A B ≃ join B A :=
-  by fapply equiv.MK; do 2 apply join.swap; do 2 apply join.swap_involutive
+  definition join_symm : join A B ≃ join B A :=
+  by fapply equiv.MK; do 2 apply join_swap; do 2 apply join_swap_involutive
 
 end join
 
@@ -482,49 +482,55 @@ section join_switch
 
 end join_switch
 
-  protected definition switch_equiv (A B C : Type) : join (join A B) C ≃ join (join C B) A :=
+  definition join_switch_equiv (A B C : Type) : join (join A B) C ≃ join (join C B) A :=
   by apply equiv.MK; do 2 apply join.switch_involutive
 
-  protected definition assoc (A B C : Type) : join (join A B) C ≃ join A (join B C) :=
-  calc join (join A B) C ≃ join (join C B) A : join.switch_equiv
-                     ... ≃ join A (join C B) : join.symm
-                     ... ≃ join A (join B C) : join.equiv_closed erfl (join.symm C B)
+  definition join_assoc (A B C : Type) : join (join A B) C ≃ join A (join B C) :=
+  calc join (join A B) C ≃ join (join C B) A : join_switch_equiv
+                     ... ≃ join A (join C B) : join_symm
+                     ... ≃ join A (join B C) : join_equiv_join erfl (join_symm C B)
 
-  protected definition ap_assoc_inv_glue_inl {A B : Type} (C : Type) (a : A) (b : B)
-    : ap (to_inv (join.assoc A B C)) (glue a (inl b)) = ap inl (glue a b) :=
+  definition ap_join_assoc_inv_glue_inl {A B : Type} (C : Type) (a : A) (b : B)
+    : ap (to_inv (join_assoc A B C)) (glue a (inl b)) = ap inl (glue a b) :=
   begin
-    unfold join.assoc, rewrite ap_compose, krewrite join.elim_glue,
+    unfold join_assoc, rewrite ap_compose, krewrite join.elim_glue,
     rewrite ap_compose, krewrite join.elim_glue, rewrite ap_inv, krewrite join.elim_glue,
-    unfold switch_coh, unfold join.symm, unfold join.swap, esimp, rewrite eq.inv_inv
+    unfold switch_coh, unfold join_symm, unfold join_swap, esimp, rewrite inv_inv
   end
 
   protected definition ap_assoc_inv_glue_inr {A C : Type} (B : Type) (a : A) (c : C)
-    : ap (to_inv (join.assoc A B C)) (glue a (inr c)) = glue (inl a) c :=
+    : ap (to_inv (join_assoc A B C)) (glue a (inr c)) = glue (inl a) c :=
   begin
-    unfold join.assoc, rewrite ap_compose, krewrite join.elim_glue,
+    unfold join_assoc, rewrite ap_compose, krewrite join.elim_glue,
     rewrite ap_compose, krewrite join.elim_glue, rewrite ap_inv, krewrite join.elim_glue,
-    unfold switch_coh, unfold join.symm, unfold join.swap, esimp, rewrite eq.inv_inv
+    unfold switch_coh, unfold join_symm, unfold join_swap, esimp, rewrite inv_inv
   end
 
 end join
 
 namespace join
 
-  open sphere sphere_index sphere.ops
-  protected definition spheres (n m : ℕ₋₁) : join (S n) (S m) ≃ S (n+1+m) :=
+  open sphere sphere.ops
+
+  definition join_susp (A B : Type) : join (susp A) B ≃ susp (join A B) :=
+  calc join (susp A) B
+           ≃ join (join bool A) B
+           : join_equiv_join (join_bool A)⁻¹ᵉ erfl
+       ... ≃ join bool (join A B)
+           : join_assoc
+       ... ≃ susp (join A B)
+           : join_bool (join A B)
+
+  definition join_sphere (n m : ℕ) : join (S n) (S m) ≃ S (n+m+1) :=
   begin
-    apply equiv.trans (join.symm (S n) (S m)),
+    refine join_symm (S n) (S m) ⬝e _,
     induction m with m IH,
-    { exact join.empty (S n) },
-    { calc join (S m.+1) (S n)
-           ≃ join (join bool (S m)) (S n)
-           : join.equiv_closed (equiv.symm (join.bool (S m))) erfl
-       ... ≃ join bool (join (S m) (S n))
-           : join.assoc
-       ... ≃ join bool (S (n+1+m))
-           : join.equiv_closed erfl IH
-       ... ≃ sphere (n+1+m.+1)
-           : join.bool (S (n+1+m)) }
+    { exact join_bool (S n) },
+    { calc join (S (m+1)) (S n)
+           ≃ susp (join (S m) (S n))
+           : join_susp (S m) (S n)
+       ... ≃ sphere (n+m+2)
+           : susp.equiv IH }
   end
 
 end join

hott/homotopy/quaternionic_hopf.hlean

@@ -9,19 +9,18 @@ The H-space structure on S³ and the quaternionic Hopf fibration
 
 import .complex_hopf .imaginaroid
 
-open eq equiv is_equiv circle is_conn trunc is_trunc sphere_index sphere susp
-open imaginaroid
+open eq equiv is_equiv circle is_conn trunc is_trunc sphere susp imaginaroid pointed bool join
 
 namespace hopf
 
-  definition involutive_neg_empty [instance] : involutive_neg empty :=
-  ⦃ involutive_neg, neg := empty.elim, neg_neg := by intro a; induction a ⦄
+  definition involutive_neg_bool [instance] : involutive_neg bool :=
+  ⦃ involutive_neg, neg := bnot, neg_neg := by intro a; induction a: reflexivity ⦄
 
   definition involutive_neg_circle [instance] : involutive_neg circle :=
-  by change involutive_neg (susp (susp empty)); exact _
+  by change involutive_neg (susp bool); exact _
 
   definition has_star_circle [instance] : has_star circle :=
-  by change has_star (susp (susp empty)); exact _
+  by change has_star (susp bool); exact _
 
   -- this is the "natural" conjugation defined using the base-loop recursor
   definition circle_star [reducible] : S¹ → S¹ :=
@@ -52,7 +51,7 @@ namespace hopf
         (ap (λw, w ⬝ (tr_constant seg1 base)⁻¹) (con.right_inv seg2)⁻¹),
       apply con.assoc },
     { apply eq_pathover, krewrite elim_merid, rewrite elim_seg2,
-      apply square_of_eq, rewrite [↑loop,con_inv,inv_inv,idp_con],
+      apply square_of_eq, rewrite [↑circle.loop,con_inv,inv_inv,idp_con],
       apply con.assoc }
   end
 
@@ -63,9 +62,9 @@ namespace hopf
     rewrite circle_star_eq, induction x,
     { reflexivity },
     { apply eq_pathover, rewrite ap_constant,
-      krewrite [ap_compose' (λz : S¹ × S¹, circle_mul z.1 z.2)
+      krewrite [-ap_compose' (λz : S¹ × S¹, circle_mul z.1 z.2)
                             (λa : S¹, (a, circle_star a))],
-      rewrite [ap_compose' (prod_functor (λa : S¹, a) circle_star)
+      rewrite [-ap_compose' (prod_functor (λa : S¹, a) circle_star)
                            (λa : S¹, (a, a))],
       rewrite ap_diagonal,
       krewrite [ap_prod_functor (λa : S¹, a) circle_star loop loop],
@@ -85,10 +84,11 @@ namespace hopf
       { apply is_prop.elimo } }
   end
 
+  open sphere.ops
+
   definition imaginaroid_sphere_zero [instance]
-    : imaginaroid (sphere (-1.+1)) :=
-  ⦃ imaginaroid,
-    neg_neg := susp_neg_neg,
+    : imaginaroid (S 0) :=
+  ⦃ imaginaroid, involutive_neg_bool,
     mul := circle_mul,
     one_mul := circle_base_mul,
     mul_one := circle_mul_base,
@@ -96,12 +96,9 @@ namespace hopf
     norm := circle_norm,
     star_mul := circle_star_mul ⦄
 
-  local attribute sphere [reducible]
-  open sphere.ops
-
   definition sphere_three_h_space [instance] : h_space (S 3) :=
   @h_space_equiv_closed (join S¹ S¹)
-      (cd_h_space (S -1.+1) circle_assoc) (S 3) (join.spheres 1 1)
+      (cd_h_space (S 0) circle_assoc) (S 3) (join_sphere 1 1)
 
   definition is_conn_sphere_three : is_conn 0 (S 3) :=
   begin
@@ -115,10 +112,13 @@ namespace hopf
 
   local attribute is_conn_sphere_three [instance]
 
-  definition quaternionic_hopf : S 7 → S 4 :=
+  definition quaternionic_hopf' : S 7 → S 4 :=
   begin
     intro x, apply @sigma.pr1 (susp (S 3)) (hopf (S 3)),
-    apply inv (hopf.total (S 3)), apply inv (join.spheres 3 3), exact x
+    apply inv (hopf.total (S 3)), apply inv (join_sphere 3 3), exact x
   end
 
+  definition quaternionic_hopf [constructor] : S 7 →* S 4 :=
+  pmap.mk quaternionic_hopf' idp
+
 end hopf

hott/homotopy/red_susp.hlean

@@ -34,7 +34,7 @@ section
   definition red_susp [constructor] : Type* := pointed.MK red_susp' base'
   parameter {A}
 
-  definition base : red_susp :=
+  definition base [reducible] : red_susp :=
   base'
 
   definition equator (a : A) : base = base :=
@@ -94,6 +94,12 @@ attribute red_susp.rec_on red_susp.elim_on [unfold 3]
 
 namespace red_susp
 
+  protected definition pelim' [unfold 4] {A P : Type*} (f : A →* Ω P) : red_susp' A → P :=
+  red_susp.elim pt f (respect_pt f)
+
+  protected definition pelim [constructor] {A P : Type*} (f : A →* Ω P) : red_susp A →* P :=
+  pmap.mk (red_susp.pelim' f) idp
+
   definition susp_of_red_susp [unfold 2] {A : Type*} (x : red_susp A) : susp A :=
   begin
     induction x,

hott/homotopy/smash.hlean

@@ -109,7 +109,7 @@ namespace smash
     (Pgl : Πa : A, Pmk a pt = Pl) (Pgr : Πb : B, Pmk pt b = Pr) (a : A) :
     ap (smash.elim Pmk Pl Pr Pgl Pgr) (gluel a) = Pgl a :=
   begin
-    apply eq_of_fn_eq_fn_inv !(pathover_constant (@gluel A B a)),
+    apply inj_inv !(pathover_constant (@gluel A B a)),
     rewrite [▸*,-apd_eq_pathover_of_eq_ap,↑smash.elim,rec_gluel],
   end
 
@@ -117,7 +117,7 @@ namespace smash
     (Pgl : Πa : A, Pmk a pt = Pl) (Pgr : Πb : B, Pmk pt b = Pr) (b : B) :
     ap (smash.elim Pmk Pl Pr Pgl Pgr) (gluer b) = Pgr b :=
   begin
-    apply eq_of_fn_eq_fn_inv !(pathover_constant (@gluer A B b)),
+    apply inj_inv !(pathover_constant (@gluer A B b)),
     rewrite [▸*,-apd_eq_pathover_of_eq_ap,↑smash.elim,rec_gluer],
   end
 

hott/homotopy/sphere.hlean

@@ -8,7 +8,7 @@ Declaration of the n-spheres
 
 import .susp types.trunc
 
-open eq nat susp bool is_trunc unit pointed algebra
+open eq nat susp bool is_trunc unit pointed algebra equiv
 
 /-
   We can define spheres with the following possible indices:
@@ -16,303 +16,49 @@ open eq nat susp bool is_trunc unit pointed algebra
   - nat (forgetting that S^-1 = empty)
   - nat, but counting wrong (S^0 = empty, S^1 = bool, ...)
   - some new type "integers >= -1"
-  We choose the last option here.
+  We choose the second option here.
 -/
 
- /- Sphere levels -/
-
-inductive sphere_index : Type₀ :=
-| minus_one : sphere_index
-| succ : sphere_index → sphere_index
-
-notation `ℕ₋₁` := sphere_index
-
-namespace trunc_index
-  definition sub_one [reducible] (n : ℕ₋₁) : ℕ₋₂ :=
-  sphere_index.rec_on n -2 (λ n k, k.+1)
-  postfix `..-1`:(max+1) := sub_one
-
-  definition of_sphere_index [reducible] (n : ℕ₋₁) : ℕ₋₂ :=
-  n..-1.+1
-
-  -- we use a double dot to distinguish with the notation .-1 in trunc_index (of type ℕ → ℕ₋₂)
-end trunc_index
-
-namespace sphere_index
-  /-
-     notation for sphere_index is -1, 0, 1, ...
-     from 0 and up this comes from a coercion from num to sphere_index (via nat)
-  -/
-
-  postfix `.+1`:(max+1) := sphere_index.succ
-  postfix `.+2`:(max+1) := λ(n : sphere_index), (n .+1 .+1)
-  notation `-1` := minus_one
-
-  definition has_zero_sphere_index [instance] : has_zero ℕ₋₁ :=
-  has_zero.mk (succ minus_one)
-
-  definition has_one_sphere_index [instance] : has_one ℕ₋₁ :=
-  has_one.mk (succ (succ minus_one))
-
-  definition add_plus_one (n m : ℕ₋₁) : ℕ₋₁ :=
-  sphere_index.rec_on m n (λ k l, l .+1)
-
-  -- addition of sphere_indices, where (-1 + -1) is defined to be -1.
-  protected definition add (n m : ℕ₋₁) : ℕ₋₁ :=
-  sphere_index.cases_on m
-    (sphere_index.cases_on n -1 id)
-    (sphere_index.rec n (λn' r, succ r))
-
-  inductive le (a : ℕ₋₁) : ℕ₋₁ → Type :=
-  | sp_refl : le a a
-  | step : Π {b}, le a b → le a (b.+1)
-
-  infix ` +1+ `:65 := sphere_index.add_plus_one
-
-  definition has_add_sphere_index [instance] [priority 2000] [reducible] : has_add ℕ₋₁ :=
-  has_add.mk sphere_index.add
-
-  definition has_le_sphere_index [instance] : has_le ℕ₋₁ :=
-  has_le.mk sphere_index.le
-
-  definition sub_one [reducible] (n : ℕ) : ℕ₋₁ :=
-  nat.rec_on n -1 (λ n k, k.+1)
-
-  postfix `..-1`:(max+1) := sub_one
-
-  definition of_nat [coercion] [reducible] (n : ℕ) : ℕ₋₁ :=
-  n..-1.+1
-
-  -- we use a double dot to distinguish with the notation .-1 in trunc_index (of type ℕ → ℕ₋₂)
-
-  definition add_one [reducible] (n : ℕ₋₁) : ℕ :=
-  sphere_index.rec_on n 0 (λ n k, nat.succ k)
-
-  definition add_plus_one_of_nat (n m : ℕ) : (n +1+ m) = sphere_index.of_nat (n + m + 1) :=
-  begin
-    induction m with m IH,
-    { reflexivity },
-    { exact ap succ IH}
-  end
-
-  definition succ_sub_one (n : ℕ) : (nat.succ n)..-1 = n :> ℕ₋₁ :=
-  idp
-
-  definition add_sub_one (n m : ℕ) : (n + m)..-1 = n..-1 +1+ m..-1 :> ℕ₋₁ :=
-  begin
-    induction m with m IH,
-    { reflexivity },
-    { exact ap succ IH }
-  end
-
-  definition succ_le_succ {n m : ℕ₋₁} (H : n ≤ m) : n.+1 ≤[ℕ₋₁] m.+1 :=
-  by induction H with m H IH; apply le.sp_refl; exact le.step IH
-
-  definition minus_one_le (n : ℕ₋₁) : -1 ≤[ℕ₋₁] n :=
-  by induction n with n IH; apply le.sp_refl; exact le.step IH
-
-  open decidable
-  protected definition has_decidable_eq [instance] : Π(n m : ℕ₋₁), decidable (n = m)
-  | has_decidable_eq -1     -1     := inl rfl
-  | has_decidable_eq (n.+1) -1     := inr (by contradiction)
-  | has_decidable_eq -1     (m.+1) := inr (by contradiction)
-  | has_decidable_eq (n.+1) (m.+1) :=
-      match has_decidable_eq n m with
-      | inl xeqy := inl (by rewrite xeqy)
-      | inr xney := inr (λ h : succ n = succ m, by injection h with xeqy; exact absurd xeqy xney)
-      end
-
-  definition not_succ_le_minus_two {n : sphere_index} (H : n .+1 ≤[ℕ₋₁] -1) : empty :=
-  by cases H
-
-  protected definition le_trans {n m k : ℕ₋₁} (H1 : n ≤[ℕ₋₁] m) (H2 : m ≤[ℕ₋₁] k) : n ≤[ℕ₋₁] k :=
-  begin
-    induction H2 with k H2 IH,
-    { exact H1},
-    { exact le.step IH}
-  end
-
-  definition le_of_succ_le_succ {n m : ℕ₋₁} (H : n.+1 ≤[ℕ₋₁] m.+1) : n ≤[ℕ₋₁] m :=
-  begin
-    cases H with m H',
-    { apply le.sp_refl},
-    { exact sphere_index.le_trans (le.step !le.sp_refl) H'}
-  end
-
-  theorem not_succ_le_self {n : ℕ₋₁} : ¬n.+1 ≤[ℕ₋₁] n :=
-  begin
-    induction n with n IH: intro H,
-    { exact not_succ_le_minus_two H},
-    { exact IH (le_of_succ_le_succ H)}
-  end
-
-  protected definition le_antisymm {n m : ℕ₋₁} (H1 : n ≤[ℕ₋₁] m) (H2 : m ≤[ℕ₋₁] n) : n = m :=
-  begin
-    induction H2 with n H2 IH,
-    { reflexivity},
-    { exfalso, apply @not_succ_le_self n, exact sphere_index.le_trans H1 H2}
-  end
-
-  protected definition le_succ {n m : ℕ₋₁} (H1 : n ≤[ℕ₋₁] m): n ≤[ℕ₋₁] m.+1 :=
-  le.step H1
-
-  definition add_plus_one_minus_one (n : ℕ₋₁) : n +1+ -1 = n := idp
-  definition add_plus_one_succ (n m : ℕ₋₁) : n +1+ (m.+1) = (n +1+ m).+1 := idp
-  definition minus_one_add_plus_one (n : ℕ₋₁) : -1 +1+ n = n :=
-  begin induction n with n IH, reflexivity, exact ap succ IH end
-  definition succ_add_plus_one (n m : ℕ₋₁) : (n.+1) +1+ m = (n +1+ m).+1 :=
-  begin induction m with m IH, reflexivity, exact ap succ IH end
-
-  definition sphere_index_of_nat_add_one (n : ℕ₋₁) : sphere_index.of_nat (add_one n) = n.+1 :=
-  begin induction n with n IH, reflexivity, exact ap succ IH end
-
-  definition add_one_succ (n : ℕ₋₁) : add_one (n.+1) = succ (add_one n) :=
-  by reflexivity
-
-  definition add_one_sub_one (n : ℕ) : add_one (n..-1) = n :=
-  begin induction n with n IH, reflexivity, exact ap nat.succ IH end
-
-  definition add_one_of_nat (n : ℕ) : add_one n = nat.succ n :=
-  ap nat.succ (add_one_sub_one n)
-
-  definition sphere_index.of_nat_succ (n : ℕ)
-    : sphere_index.of_nat (nat.succ n) = (sphere_index.of_nat n).+1 :=
-  begin induction n with n IH, reflexivity, exact ap succ IH end
-
-  /-
-    warning: if this coercion is available, the coercion ℕ → ℕ₋₂ is the composition of the coercions
-    ℕ → ℕ₋₁ → ℕ₋₂. We don't want this composition as coercion, because it has worse computational
-    properties. You can rewrite it with trans_to_of_sphere_index_eq defined below.
-  -/
-  attribute trunc_index.of_sphere_index [coercion]
-
-end sphere_index open sphere_index
-
-definition weak_order_sphere_index [trans_instance] [reducible] : weak_order sphere_index :=
-weak_order.mk le sphere_index.le.sp_refl @sphere_index.le_trans @sphere_index.le_antisymm
-
-namespace trunc_index
-  definition sub_two_eq_sub_one_sub_one (n : ℕ) : n.-2 = n..-1..-1 :=
-  begin
-    induction n with n IH,
-    { reflexivity},
-    { exact ap trunc_index.succ IH}
-  end
-
-  definition of_nat_sub_one (n : ℕ)
-    : (sphere_index.of_nat n)..-1 = (trunc_index.sub_two n).+1 :=
-  begin
-    induction n with n IH,
-    { reflexivity},
-    { exact ap trunc_index.succ IH}
-  end
-
-  definition sub_one_of_sphere_index (n : ℕ)
-    : of_sphere_index n..-1 = (trunc_index.sub_two n).+1 :=
-  begin
-    induction n with n IH,
-    { reflexivity},
-    { exact ap trunc_index.succ IH}
-  end
-
-  definition succ_sub_one (n : ℕ₋₁) : n.+1..-1 = n :> ℕ₋₂ :=
-  idp
-
-  definition of_sphere_index_of_nat (n : ℕ)
-    : of_sphere_index (sphere_index.of_nat n) = of_nat n :> ℕ₋₂ :=
-  begin
-    induction n with n IH,
-    { reflexivity},
-    { exact ap trunc_index.succ IH}
-  end
-
-  definition trans_to_of_sphere_index_eq (n : ℕ)
-    : trunc_index._trans_to_of_sphere_index n = of_nat n :> ℕ₋₂ :=
-  of_sphere_index_of_nat n
-
-  definition trunc_index_of_nat_add_one (n : ℕ₋₁)
-    : trunc_index.of_nat (add_one n) = (of_sphere_index n).+1 :=
-  begin induction n with n IH, reflexivity, exact ap succ IH end
-
-  definition of_sphere_index_succ (n : ℕ₋₁) : of_sphere_index (n.+1) = (of_sphere_index n).+1 :=
-  begin induction n with n IH, reflexivity, exact ap succ IH end
-
-end trunc_index
-
-open sphere_index equiv
-
-definition sphere (n : ℕ₋₁) : Type₀ := iterate_susp (add_one n) empty
+definition sphere (n : ℕ) : Type* := iterate_susp n pbool
 
 namespace sphere
 
-  export [notation] sphere_index
-
-  definition base {n : ℕ} : sphere n := north
-  definition pointed_sphere [instance] [constructor] (n : ℕ) : pointed (sphere n) :=
-  pointed.mk base
-  definition psphere [constructor] (n : ℕ) : Type* := pointed.mk' (sphere n)
-
-
   namespace ops
     abbreviation S := sphere
-    notation `S*` := psphere
   end ops
   open sphere.ops
 
-  definition sphere_minus_one : S -1 = empty := idp
-  definition sphere_succ [unfold_full] (n : ℕ₋₁) : S n.+1 = susp (S n) := idp
-  definition psphere_succ [unfold_full] (n : ℕ) : S* (n + 1) = psusp (S* n) := idp
-  definition psphere_eq_iterate_susp (n : ℕ)
-    : S* n = pointed.MK (iterate_susp (succ n) empty) !north :=
-  begin
-    esimp,
-    apply ap (λx, pointed.MK (susp x) (@north x)); apply ap (λx, iterate_susp x empty),
-    apply add_one_sub_one
-  end
+  definition sphere_succ [unfold_full] (n : ℕ) : S (n+1) = susp (S n) := idp
+  definition sphere_eq_iterate_susp (n : ℕ) : S n = iterate_susp n pbool := idp
 
-  definition equator [constructor] (n : ℕ) : S* n →* Ω (S* (succ n)) :=
-  loop_psusp_unit (S* n)
+  definition equator [constructor] (n : ℕ) : S n →* Ω (S (succ n)) :=
+  loop_susp_unit (S n)
 
-  definition surf {n : ℕ} : Ω[n] (S* n) :=
+  definition surf {n : ℕ} : Ω[n] (S n) :=
   begin
     induction n with n s,
-    { exact south },
-    { exact (loopn_succ_in (S* (succ n)) n)⁻¹ᵉ* (apn n (equator n) s) }
+    { exact tt },
+    { exact (loopn_succ_in n (S (succ n)))⁻¹ᵉ* (apn n (equator n) s) }
   end
 
-  definition bool_of_sphere [unfold 1] : S 0 → bool :=
-  proof susp.rec ff tt (λx, empty.elim x) qed
+  definition sphere_equiv_bool [constructor] : S 0 ≃ bool := by reflexivity
 
-  definition sphere_of_bool [unfold 1] : bool → S 0
-  | ff := proof north qed
-  | tt := proof south qed
+  definition sphere_pequiv_pbool [constructor] : S 0 ≃* pbool := by reflexivity
 
-  definition sphere_equiv_bool [constructor] : S 0 ≃ bool :=
-  equiv.MK bool_of_sphere
-           sphere_of_bool
-           (λb, match b with | tt := idp | ff := idp end)
-           (λx, proof susp.rec_on x idp idp (empty.rec _) qed)
+  definition sphere_pequiv_iterate_susp (n : ℕ) : sphere n ≃* iterate_susp n pbool :=
+  by reflexivity
 
-  definition psphere_pequiv_pbool [constructor] : S* 0 ≃* pbool :=
-  pequiv_of_equiv sphere_equiv_bool idp
-
-  definition sphere_eq_bool : S 0 = bool :=
-  ua sphere_equiv_bool
-
-  definition sphere_eq_pbool : S* 0 = pbool :=
-  pType_eq sphere_equiv_bool idp
-
-  definition psphere_pmap_pequiv' (A : Type*) (n : ℕ) : ppmap (S* n) A ≃* Ω[n] A :=
+  definition sphere_pmap_pequiv' (A : Type*) (n : ℕ) : ppmap (S n) A ≃* Ω[n] A :=
   begin
     revert A, induction n with n IH: intro A,
-    { refine _ ⬝e* !pmap_pbool_pequiv, exact pequiv_ppcompose_right psphere_pequiv_pbool⁻¹ᵉ* },
-    { refine psusp_adjoint_loop (S* n) A ⬝e* IH (Ω A) ⬝e* !loopn_succ_in⁻¹ᵉ*  }
+    { refine !ppmap_pbool_pequiv },
+    { refine susp_adjoint_loop (S n) A ⬝e* IH (Ω A) ⬝e* !loopn_succ_in⁻¹ᵉ*  }
   end
 
-  definition psphere_pmap_pequiv (A : Type*) (n : ℕ) : ppmap (S* n) A ≃* Ω[n] A :=
+  definition sphere_pmap_pequiv (A : Type*) (n : ℕ) : ppmap (S n) A ≃* Ω[n] A :=
   begin
     fapply pequiv_change_fun,
-    { exact psphere_pmap_pequiv' A n },
+    { exact sphere_pmap_pequiv' A n },
     { exact papn_fun A surf },
     { revert A, induction n with n IH: intro A,
       { reflexivity },
@@ -320,33 +66,29 @@ namespace sphere
         exact !loopn_succ_in_inv_natural⁻¹* _ }}
   end
 
-  protected definition elim {n : ℕ} {P : Type*} (p : Ω[n] P) : S* n →* P :=
-  !psphere_pmap_pequiv⁻¹ᵉ* p
+  protected definition elim {n : ℕ} {P : Type*} (p : Ω[n] P) : S n →* P :=
+  !sphere_pmap_pequiv⁻¹ᵉ* p
 
   -- definition elim_surf {n : ℕ} {P : Type*} (p : Ω[n] P) : apn n (sphere.elim p) surf = p :=
   -- begin
   --   induction n with n IH,
-  --   { esimp [apn,surf,sphere.elim,psphere_pmap_equiv], apply sorry},
+  --   { esimp [apn,surf,sphere.elim,sphere_pmap_equiv], apply sorry},
   --   { apply sorry}
   -- end
 
 end sphere
 
 namespace sphere
-  open is_conn trunc_index sphere_index sphere.ops
+  open is_conn trunc_index sphere.ops
 
   -- Corollary 8.2.2
-  theorem is_conn_sphere [instance] (n : ℕ₋₁) : is_conn (n..-1) (S n) :=
+  theorem is_conn_sphere [instance] (n : ℕ) : is_conn (n.-1) (S n) :=
   begin
     induction n with n IH,
-    { apply is_conn_minus_two },
-    { rewrite [trunc_index.succ_sub_one n, sphere.sphere_succ],
-      apply is_conn_susp }
+    { apply is_conn_minus_one_pointed },
+    { apply is_conn_susp, exact IH }
   end
 
-  theorem is_conn_psphere [instance] (n : ℕ) : is_conn (n.-1) (S* n) :=
-  transport (λx, is_conn x (sphere n)) (of_nat_sub_one n) (is_conn_sphere n)
-
 end sphere
 
 open sphere sphere.ops
@@ -354,44 +96,44 @@ open sphere sphere.ops
 namespace is_trunc
   open trunc_index
   variables {n : ℕ} {A : Type}
-  definition is_trunc_of_psphere_pmap_equiv_constant
-    (H : Π(a : A) (f : S* n →* pointed.Mk a) (x : S n), f x = f base) : is_trunc (n.-2.+1) A :=
+  definition is_trunc_of_sphere_pmap_equiv_constant
+    (H : Π(a : A) (f : S n →* pointed.Mk a) (x : S n), f x = f pt) : is_trunc (n.-2.+1) A :=
   begin
     apply iff.elim_right !is_trunc_iff_is_contr_loop,
     intro a,
-    apply is_trunc_equiv_closed, exact !psphere_pmap_pequiv,
+    apply is_trunc_equiv_closed, exact !sphere_pmap_pequiv,
     fapply is_contr.mk,
     { exact pmap.mk (λx, a) idp},
-    { intro f, fapply pmap_eq,
+    { intro f, apply eq_of_phomotopy, fapply phomotopy.mk,
       { intro x, esimp, refine !respect_pt⁻¹ ⬝ (!H ⬝ !H⁻¹)},
       { rewrite [▸*,con.right_inv,▸*,con.left_inv]}}
   end
 
   definition is_trunc_iff_map_sphere_constant
-    (H : Π(f : S n → A) (x : S n), f x = f base) : is_trunc (n.-2.+1) A :=
+    (H : Π(f : S n → A) (x : S n), f x = f pt) : is_trunc (n.-2.+1) A :=
   begin
-    apply is_trunc_of_psphere_pmap_equiv_constant,
+    apply is_trunc_of_sphere_pmap_equiv_constant,
     intros, cases f with f p, esimp at *, apply H
   end
 
-  definition psphere_pmap_equiv_constant_of_is_trunc' [H : is_trunc (n.-2.+1) A]
-    (a : A) (f : S* n →* pointed.Mk a) (x : S n) : f x = f base :=
+  definition sphere_pmap_equiv_constant_of_is_trunc' [H : is_trunc (n.-2.+1) A]
+    (a : A) (f : S n →* pointed.Mk a) (x : S n) : f x = f pt :=
   begin
     let H' := iff.elim_left (is_trunc_iff_is_contr_loop n A) H a,
-    note H'' := @is_trunc_equiv_closed_rev _ _ _ !psphere_pmap_pequiv H',
-    esimp at H'',
-    have p : f = pmap.mk (λx, f base) (respect_pt f),
-      by apply is_prop.elim,
+    have H'' : is_contr (S n →* pointed.Mk a), from
+      @is_trunc_equiv_closed_rev _ _ _ !sphere_pmap_pequiv H',
+    have p : f = pmap.mk (λx, f pt) (respect_pt f),
+      from !is_prop.elim,
     exact ap10 (ap pmap.to_fun p) x
   end
 
-  definition psphere_pmap_equiv_constant_of_is_trunc [H : is_trunc (n.-2.+1) A]
-    (a : A) (f : S* n →* pointed.Mk a) (x y : S n) : f x = f y :=
-  let H := psphere_pmap_equiv_constant_of_is_trunc' a f in !H ⬝ !H⁻¹
+  definition sphere_pmap_equiv_constant_of_is_trunc [H : is_trunc (n.-2.+1) A]
+    (a : A) (f : S n →* pointed.Mk a) (x y : S n) : f x = f y :=
+  let H := sphere_pmap_equiv_constant_of_is_trunc' a f in !H ⬝ !H⁻¹
 
   definition map_sphere_constant_of_is_trunc [H : is_trunc (n.-2.+1) A]
     (f : S n → A) (x y : S n) : f x = f y :=
-  psphere_pmap_equiv_constant_of_is_trunc (f base) (pmap.mk f idp) x y
+  sphere_pmap_equiv_constant_of_is_trunc (f pt) (pmap.mk f idp) x y
 
   definition map_sphere_constant_of_is_trunc_self [H : is_trunc (n.-2.+1) A]
     (f : S n → A) (x : S n) : map_sphere_constant_of_is_trunc f x x = idp :=

hott/homotopy/sphere2.hlean

@@ -14,77 +14,58 @@ In this file we calculate
 
 import .homotopy_group .freudenthal
 open eq group algebra is_equiv equiv fin prod chain_complex pointed fiber nat is_trunc trunc_index
-     sphere.ops trunc is_conn susp
+     sphere.ops trunc is_conn susp bool
 
 namespace sphere
   /- Corollaries of the complex hopf fibration combined with the LES of homotopy groups -/
   open sphere sphere.ops int circle hopf
 
-  definition π2S2 : πg[1+1] (S* 2) ≃g gℤ :=
+  definition π2S2 : πg[2] (S 2) ≃g gℤ :=
   begin
     refine _ ⬝g fundamental_group_of_circle,
-    refine _ ⬝g homotopy_group_isomorphism_of_pequiv _ pfiber_complex_phopf,
+    refine _ ⬝g homotopy_group_isomorphism_of_pequiv _ pfiber_complex_hopf,
     fapply isomorphism_of_equiv,
     { fapply equiv.mk,
-      { exact cc_to_fn (LES_of_homotopy_groups complex_phopf) (1, 2)},
-      { refine @is_equiv_of_trivial _
-        _ _
-        (is_exact_LES_of_homotopy_groups _ (1, 1))
-        (is_exact_LES_of_homotopy_groups _ (1, 2))
-        _
-        _
-        (@pgroup_of_group _ (group_LES_of_homotopy_groups complex_phopf _ _) idp)
-        (@pgroup_of_group _ (group_LES_of_homotopy_groups complex_phopf _ _) idp)
-        _,
-        { rewrite [LES_of_homotopy_groups_1, ▸*],
-          have H : 1 ≤[ℕ] 2, from !one_le_succ,
-          apply trivial_homotopy_group_of_is_conn, exact H, rexact is_conn_psphere 3},
+      { exact cc_to_fn (LES_of_homotopy_groups complex_hopf) (1, 2)},
+      { refine LES_is_equiv_of_trivial complex_hopf 1 2 _ _,
+        { have H : 1 ≤[ℕ] 2, from !one_le_succ,
+          apply trivial_homotopy_group_of_is_conn, exact H, rexact is_conn_sphere 3 },
         { refine tr_rev (λx, is_contr (ptrunctype._trans_of_to_pType x))
-                        (LES_of_homotopy_groups_1 complex_phopf 2) _,
-          apply trivial_homotopy_group_of_is_conn, apply le.refl, rexact is_conn_psphere 3},
-        { exact homomorphism.struct (homomorphism_LES_of_homotopy_groups_fun _ (0, 2))}}},
+                        (LES_of_homotopy_groups_1 complex_hopf 2) _,
+          apply trivial_homotopy_group_of_is_conn, apply le.refl, rexact is_conn_sphere 3 }}},
     { exact homomorphism.struct (homomorphism_LES_of_homotopy_groups_fun _ (0, 2))}
   end
 
   open circle
-  definition πnS3_eq_πnS2 (n : ℕ) : πg[n+2 +1] (S* 3) ≃g πg[n+2 +1] (S* 2) :=
+  definition πnS3_eq_πnS2 (n : ℕ) : πg[n+3] (S 3) ≃g πg[n+3] (S 2) :=
   begin
     fapply isomorphism_of_equiv,
     { fapply equiv.mk,
-      { exact cc_to_fn (LES_of_homotopy_groups complex_phopf) (n+3, 0)},
-      { have H : is_trunc 1 (pfiber complex_phopf),
-        from @(is_trunc_equiv_closed_rev _ pfiber_complex_phopf) is_trunc_circle,
-        refine @is_equiv_of_trivial _
-        _ _
-        (is_exact_LES_of_homotopy_groups _ (n+2, 2))
-        (is_exact_LES_of_homotopy_groups _ (n+3, 0))
-        _
-        _
-        (@pgroup_of_group _ (group_LES_of_homotopy_groups complex_phopf _ _) idp)
-        (@pgroup_of_group _ (group_LES_of_homotopy_groups complex_phopf _ _) idp)
-        _,
-        { rewrite [▸*, LES_of_homotopy_groups_2 _ (n +[ℕ] 2)],
-          have H2 : 1 ≤[ℕ] n + 1, from !one_le_succ,
+      { exact cc_to_fn (LES_of_homotopy_groups complex_hopf) (n+3, 0)},
+      { have H : is_trunc 1 (pfiber complex_hopf),
+        from is_trunc_equiv_closed_rev _ pfiber_complex_hopf is_trunc_circle,
+        refine LES_is_equiv_of_trivial complex_hopf (n+3) 0 _ _,
+        { have H2 : 1 ≤[ℕ] n + 1, from !one_le_succ,
           exact @trivial_ghomotopy_group_of_is_trunc _ _ _ H H2 },
         { refine tr_rev (λx, is_contr (ptrunctype._trans_of_to_pType x))
-                        (LES_of_homotopy_groups_2 complex_phopf _) _,
+                        (LES_of_homotopy_groups_2 complex_hopf _) _,
           have H2 : 1 ≤[ℕ] n + 2, from !one_le_succ,
-          apply trivial_ghomotopy_group_of_is_trunc _ _ _ H2},
-        { exact homomorphism.struct (homomorphism_LES_of_homotopy_groups_fun _ (n+2, 0))}}},
+          apply trivial_ghomotopy_group_of_is_trunc _ _ _ H2 }}},
     { exact homomorphism.struct (homomorphism_LES_of_homotopy_groups_fun _ (n+2, 0))}
   end
 
   definition sphere_stability_pequiv (k n : ℕ) (H : k + 2 ≤ 2 * n) :
-    π[k + 1] (S* (n+1)) ≃* π[k] (S* n) :=
-  begin rewrite [+ psphere_eq_iterate_susp], exact iterate_susp_stability_pequiv empty H end
+    π[k + 1] (S (n+1)) ≃* π[k] (S n) :=
+  iterate_susp_stability_pequiv H pbool
 
   definition stability_isomorphism (k n : ℕ) (H : k + 3 ≤ 2 * n)
-    : πg[k+1 +1] (S* (n+1)) ≃g πg[k+1] (S* n) :=
-  begin rewrite [+ psphere_eq_iterate_susp], exact iterate_susp_stability_isomorphism empty H end
+    : πg[k+1 +1] (S (n+1)) ≃g πg[k+1] (S n) :=
+  iterate_susp_stability_isomorphism H pbool
 
   open int circle hopf
-  definition πnSn (n : ℕ) : πg[n+1] (S* (succ n)) ≃g gℤ :=
+  definition πnSn (n : ℕ) [H : is_succ n] : πg[n] (S (n)) ≃g gℤ :=
   begin
+    induction H with n,
     cases n with n IH,
     { exact fundamental_group_of_circle },
     { induction n with n IH,
@@ -93,34 +74,19 @@ namespace sphere
         rexact add_mul_le_mul_add n 1 2 }}
   end
 
-  theorem not_is_trunc_sphere (n : ℕ) : ¬is_trunc n (S* (succ n)) :=
+  theorem not_is_trunc_sphere (n : ℕ) : ¬is_trunc n (S (n+1)) :=
   begin
     intro H,
-    note H2 := trivial_ghomotopy_group_of_is_trunc (S* (succ n)) n n !le.refl,
-    have H3 : is_contr ℤ, from is_trunc_equiv_closed _ (equiv_of_isomorphism (πnSn n)),
+    note H2 := trivial_ghomotopy_group_of_is_trunc (S (n+1)) n n !le.refl,
+    have H3 : is_contr ℤ, from is_trunc_equiv_closed _ (equiv_of_isomorphism (πnSn (n+1))) _,
     have H4 : (0 : ℤ) ≠ (1 : ℤ), from dec_star,
     apply H4,
     apply is_prop.elim,
   end
 
-  section
-    open sphere_index
-
-    definition not_is_trunc_sphere' (n : ℕ₋₁) : ¬is_trunc n (S (n.+1)) :=
+  definition π3S2 : πg[3] (S 2) ≃g gℤ :=
   begin
-      cases n with n,
-      { esimp [sphere.ops.S, sphere], intro H,
-        have H2 : is_prop bool, from @(is_trunc_equiv_closed -1 sphere_equiv_bool) H,
-        have H3 : bool.tt ≠ bool.ff, from dec_star, apply H3, apply is_prop.elim},
-      { intro H, apply not_is_trunc_sphere (add_one n),
-        rewrite [▸*, trunc_index_of_nat_add_one, -add_one_succ,
-                 sphere_index_of_nat_add_one],
-        exact H}
+    refine _ ⬝g πnSn 3, symmetry, rexact πnS3_eq_πnS2 0
   end
 
-  end
-
-  definition π3S2 : πg[2+1] (S* 2) ≃g gℤ :=
-  (πnS3_eq_πnS2 0)⁻¹ᵍ ⬝g πnSn 2
-
 end sphere

hott/homotopy/susp.hlean

@@ -6,17 +6,33 @@ Authors: Floris van Doorn, Ulrik Buchholtz
 Declaration of suspension
 -/
 
-import hit.pushout types.pointed cubical.square .connectedness
+import hit.pushout types.pointed2 cubical.square .connectedness
 
-open pushout unit eq equiv
+open pushout unit eq equiv pointed is_equiv
 
-definition susp (A : Type) : Type := pushout (λ(a : A), star) (λ(a : A), star)
+definition susp' (A : Type) : Type := pushout (λ(a : A), star) (λ(a : A), star)
+
+namespace susp
+
+  definition north' {A : Type} : susp' A :=
+  inl star
+
+  definition pointed_susp [instance] [constructor] (X : Type)
+    : pointed (susp' X) :=
+  pointed.mk north'
+
+end susp open susp
+
+definition susp [constructor] (X : Type) : Type* :=
+pointed.MK (susp' X) north'
+
+notation `⅀` := susp
 
 namespace susp
   variable {A : Type}
 
   definition north {A : Type} : susp A :=
-  inl star
+  north'
 
   definition south {A : Type} : susp A :=
   inr star
@@ -25,7 +41,7 @@ namespace susp
   glue a
 
   protected definition rec {P : susp A → Type} (PN : P north) (PS : P south)
-    (Pm : Π(a : A), PN =[merid a] PS) (x : susp A) : P x :=
+    (Pm : Π(a : A), PN =[merid a] PS) (x : susp' A) : P x :=
   begin
     induction x with u u,
     { cases u, exact PN},
@@ -33,7 +49,7 @@ namespace susp
     { apply Pm},
   end
 
-  protected definition rec_on [reducible] {P : susp A → Type} (y : susp A)
+  protected definition rec_on [reducible] {P : susp A → Type} (y : susp' A)
     (PN : P north) (PS : P south) (Pm : Π(a : A), PN =[merid a] PS) : P y :=
   susp.rec PN PS Pm y
 
@@ -43,25 +59,25 @@ namespace susp
   !rec_glue
 
   protected definition elim {P : Type} (PN : P) (PS : P) (Pm : A → PN = PS)
-    (x : susp A) : P :=
+    (x : susp' A) : P :=
   susp.rec PN PS (λa, pathover_of_eq _ (Pm a)) x
 
-  protected definition elim_on [reducible] {P : Type} (x : susp A)
+  protected definition elim_on [reducible] {P : Type} (x : susp' A)
     (PN : P) (PS : P)  (Pm : A → PN = PS) : P :=
   susp.elim PN PS Pm x
 
   theorem elim_merid {P : Type} {PN PS : P} (Pm : A → PN = PS) (a : A)
     : ap (susp.elim PN PS Pm) (merid a) = Pm a :=
   begin
-    apply eq_of_fn_eq_fn_inv !(pathover_constant (merid a)),
+    apply inj_inv !(pathover_constant (merid a)),
     rewrite [▸*,-apd_eq_pathover_of_eq_ap,↑susp.elim,rec_merid],
   end
 
   protected definition elim_type (PN : Type) (PS : Type) (Pm : A → PN ≃ PS)
-    (x : susp A) : Type :=
+    (x : susp' A) : Type :=
   pushout.elim_type (λx, PN) (λx, PS) Pm x
 
-  protected definition elim_type_on [reducible] (x : susp A)
+  protected definition elim_type_on [reducible] (x : susp' A)
     (PN : Type) (PS : Type)  (Pm : A → PN ≃ PS) : Type :=
   susp.elim_type PN PS Pm x
 
@@ -79,7 +95,7 @@ namespace susp
 
 end susp
 
-attribute susp.north susp.south [constructor]
+attribute susp.north' susp.north susp.south [constructor]
 attribute susp.rec susp.elim [unfold 6] [recursor 6]
 attribute susp.elim_type [unfold 5]
 attribute susp.rec_on susp.elim_on [unfold 3]
@@ -94,28 +110,23 @@ namespace susp
     [H : is_conn n A] : is_conn (n .+1) (susp A) :=
   is_contr.mk (tr north)
   begin
-    apply trunc.rec,
-    fapply susp.rec,
+    intro x, induction x with x, induction x,
     { reflexivity },
     { exact (trunc.rec (λa, ap tr (merid a)) (center (trunc n A))) },
-    { intro a,
-      generalize (center (trunc n A)),
-      apply trunc.rec,
-      intro a',
+    { generalize (center (trunc n A)),
+      intro x, induction x with a',
       apply pathover_of_tr_eq,
       rewrite [eq_transport_Fr,idp_con],
-      revert H, induction n with [n, IH],
-      { intro H, apply is_prop.elim },
-      { intros H,
-        change ap (@tr n .+2 (susp A)) (merid a) = ap tr (merid a'),
+      revert H, induction n with n IH: intro H,
+      { apply is_prop.elim },
+      { change ap (@tr n .+2 (susp A)) (merid a) = ap tr (merid a'),
         generalize a',
         apply is_conn_fun.elim n
               (is_conn_fun_from_unit n A a)
               (λx : A, trunctype.mk' n (ap (@tr n .+2 (susp A)) (merid a) = ap tr (merid x))),
         intros,
         change ap (@tr n .+2 (susp A)) (merid a) = ap tr (merid a),
-        reflexivity
-      }
+        reflexivity }
     }
   end
 
@@ -152,7 +163,7 @@ namespace susp
   variables {A B : Type} (f : A → B)
   include f
 
-  protected definition functor [unfold 4] : susp A → susp B :=
+  definition susp_functor' [unfold 4] : susp A → susp B :=
   begin
     intro x, induction x with a,
     { exact north },
@@ -164,19 +175,19 @@ namespace susp
   include Hf
 
   open is_equiv
-  protected definition is_equiv_functor [instance] [constructor] : is_equiv (susp.functor f) :=
-  adjointify (susp.functor f) (susp.functor f⁻¹)
+  protected definition is_equiv_functor [instance] [constructor] : is_equiv (susp_functor' f) :=
+  adjointify (susp_functor' f) (susp_functor' f⁻¹)
   abstract begin
     intro sb, induction sb with b, do 2 reflexivity,
     apply eq_pathover,
-    rewrite [ap_id,ap_compose' (susp.functor f) (susp.functor f⁻¹)],
+    rewrite [ap_id,-ap_compose' (susp_functor' f) (susp_functor' f⁻¹)],
     krewrite [susp.elim_merid,susp.elim_merid], apply transpose,
     apply susp.merid_square (right_inv f b)
   end end
   abstract begin
     intro sa, induction sa with a, do 2 reflexivity,
     apply eq_pathover,
-    rewrite [ap_id,ap_compose' (susp.functor f⁻¹) (susp.functor f)],
+    rewrite [ap_id,-ap_compose' (susp_functor' f⁻¹) (susp_functor' f)],
     krewrite [susp.elim_merid,susp.elim_merid], apply transpose,
     apply susp.merid_square (left_inv f a)
   end end
@@ -188,74 +199,85 @@ namespace susp
   variables {A B : Type} (f : A ≃ B)
 
   protected definition equiv : susp A ≃ susp B :=
-  equiv.mk (susp.functor f) _
+  equiv.mk (susp_functor' f) _
 end susp
 
-namespace susp
-  open pointed
-  definition pointed_susp [instance] [constructor] (X : Type)
-    : pointed (susp X) :=
-  pointed.mk north
-end susp
-
-open susp
-definition psusp [constructor] (X : Type) : Type* :=
-pointed.mk' (susp X)
-
-notation `⅀` := psusp
-
 namespace susp
   open pointed is_trunc
-  variables {X Y Z : Type*}
+  variables {X X' Y Y' Z : Type*}
 
-  definition is_conn_psusp [instance] (n : trunc_index) (A : Type*)
-    [H : is_conn n A] : is_conn (n .+1) (psusp A) :=
-  is_conn_susp n A
-
-  definition psusp_functor [constructor] (f : X →* Y) : psusp X →* psusp Y :=
+  definition susp_functor [constructor] (f : X →* Y) : susp X →* susp Y :=
   begin
     fconstructor,
-    { exact susp.functor f },
+    { exact susp_functor' f },
     { reflexivity }
   end
 
-  definition is_equiv_psusp_functor [constructor] (f : X →* Y) [Hf : is_equiv f]
-    : is_equiv (psusp_functor f) :=
+  notation `⅀→`:(max+5) := susp_functor
+
+  definition is_equiv_susp_functor [constructor] (f : X →* Y) [Hf : is_equiv f]
+    : is_equiv (susp_functor f) :=
   susp.is_equiv_functor f
 
-  definition psusp_equiv [constructor] (f : X ≃* Y) : psusp X ≃* psusp Y :=
+  definition susp_pequiv [constructor] (f : X ≃* Y) : susp X ≃* susp Y :=
   pequiv_of_equiv (susp.equiv f) idp
 
-  definition psusp_functor_compose (g : Y →* Z) (f : X →* Y)
-    : psusp_functor (g ∘* f) ~* psusp_functor g ∘* psusp_functor f :=
+  definition susp_functor_pcompose (g : Y →* Z) (f : X →* Y) :
+    susp_functor (g ∘* f) ~* susp_functor g ∘* susp_functor f :=
   begin
-    fconstructor,
-    { intro a, induction a,
+    fapply phomotopy.mk,
+    { intro x, induction x,
       { reflexivity },
       { reflexivity },
       { apply eq_pathover, apply hdeg_square,
-        rewrite [▸*,ap_compose' _ (psusp_functor f)],
-        krewrite +susp.elim_merid } },
-    { reflexivity }
+        refine !elim_merid ⬝ _ ⬝ (ap_compose (susp_functor g) _ _)⁻¹ᵖ,
+        refine _ ⬝ ap02 _ !elim_merid⁻¹, exact !elim_merid⁻¹ }},
+    { reflexivity },
   end
 
-  -- adjunction from Coq-HoTT
+  definition susp_functor_phomotopy {f g : X →* Y} (p : f ~* g) :
+    susp_functor f ~* susp_functor g :=
+  begin
+    fapply phomotopy.mk,
+    { intro x, induction x,
+      { reflexivity },
+      { reflexivity },
+      { apply eq_pathover, apply hdeg_square, esimp, refine !elim_merid ⬝ _ ⬝ !elim_merid⁻¹ᵖ,
+        exact ap merid (p a), }},
+    { reflexivity },
+  end
 
-  definition loop_psusp_unit [constructor] (X : Type*) : X →* Ω(psusp X) :=
+  notation `⅀⇒`:(max+5) := susp_functor_phomotopy
+
+  definition susp_functor_pid (A : Type*) : susp_functor (pid A) ~* pid (susp A) :=
+  begin
+    fapply phomotopy.mk,
+    { intro x, induction x,
+      { reflexivity },
+      { reflexivity },
+      { apply eq_pathover_id_right, apply hdeg_square, apply elim_merid }},
+    { reflexivity },
+  end
+
+  /- adjunction originally  ported from Coq-HoTT,
+     but we proved some additional naturality conditions -/
+
+  definition loop_susp_unit [constructor] (X : Type*) : X →* Ω(susp X) :=
   begin
     fconstructor,
     { intro x, exact merid x ⬝ (merid pt)⁻¹ },
     { apply con.right_inv },
   end
 
-  definition loop_psusp_unit_natural (f : X →* Y)
-    : loop_psusp_unit Y ∘* f ~* ap1 (psusp_functor f) ∘* loop_psusp_unit X :=
+  definition loop_susp_unit_natural (f : X →* Y)
+    : psquare (loop_susp_unit X) (loop_susp_unit Y) f (Ω→ (susp_functor f)) :=
   begin
+    apply ptranspose,
     induction X with X x, induction Y with Y y, induction f with f pf, esimp at *, induction pf,
-    fconstructor,
-    { intro x', esimp [psusp_functor], symmetry,
+    fapply phomotopy.mk,
+    { intro x', symmetry,
       exact
-        !idp_con ⬝
+        !ap1_gen_idp_left ⬝
         (!ap_con ⬝
         whisker_left _ !ap_inv) ⬝
         (!elim_merid ◾ (inverse2 !elim_merid)) },
@@ -265,18 +287,19 @@ namespace susp
       rewrite inverse2_right_inv,
       refine _ ⬝ !con.assoc',
       rewrite [ap_con_right_inv],
-      xrewrite [idp_con_idp, -ap_compose (concat idp)] },
+      rewrite [ap1_gen_idp_left_con],
+      rewrite [-ap_compose (concat idp)] },
   end
 
-  definition loop_psusp_counit [constructor] (X : Type*) : psusp (Ω X) →* X :=
+  definition loop_susp_counit [constructor] (X : Type*) : susp (Ω X) →* X :=
   begin
-    fconstructor,
+    fapply pmap.mk,
     { intro x, induction x, exact pt, exact pt, exact a },
     { reflexivity },
   end
 
-  definition loop_psusp_counit_natural (f : X →* Y)
-    : f ∘* loop_psusp_counit X ~* loop_psusp_counit Y ∘* (psusp_functor (ap1 f)) :=
+  definition loop_susp_counit_natural (f : X →* Y)
+    : psquare (loop_susp_counit X) (loop_susp_counit Y) (⅀→ (Ω→ f)) f :=
   begin
     induction X with X x, induction Y with Y y, induction f with f pf, esimp at *, induction pf,
     fconstructor,
@@ -284,161 +307,219 @@ namespace susp
        { reflexivity },
       { reflexivity },
       { esimp, apply eq_pathover, apply hdeg_square,
-        xrewrite [ap_compose' f, ap_compose' (susp.elim (f x) (f x) (λ (a : f x = f x), a)),▸*],
-        xrewrite [+elim_merid,▸*,idp_con] }},
+        xrewrite [-ap_compose' f, -ap_compose' (susp.elim (f x) (f x) (λ (a : f x = f x), a)),▸*],
+        xrewrite [+elim_merid, ap1_gen_idp_left] }},
     { reflexivity }
   end
 
-  definition loop_psusp_counit_unit (X : Type*)
-    : ap1 (loop_psusp_counit X) ∘* loop_psusp_unit (Ω X) ~* pid (Ω X) :=
+  definition loop_susp_counit_unit (X : Type*)
+    : ap1 (loop_susp_counit X) ∘* loop_susp_unit (Ω X) ~* pid (Ω X) :=
   begin
     induction X with X x, fconstructor,
     { intro p, esimp,
-      refine !idp_con ⬝
+      refine !ap1_gen_idp_left ⬝
              (!ap_con ⬝
              whisker_left _ !ap_inv) ⬝
              (!elim_merid ◾ inverse2 !elim_merid) },
     { rewrite [▸*,inverse2_right_inv (elim_merid id idp)],
       refine !con.assoc ⬝ _,
-      xrewrite [ap_con_right_inv (susp.elim x x (λa, a)) (merid idp),idp_con_idp,-ap_compose] }
+      xrewrite [ap_con_right_inv (susp.elim x x (λa, a)) (merid idp),ap1_gen_idp_left_con,
+        -ap_compose] }
   end
 
-  definition loop_psusp_unit_counit (X : Type*)
-    : loop_psusp_counit (psusp X) ∘* psusp_functor (loop_psusp_unit X) ~* pid (psusp X) :=
+  definition loop_susp_unit_counit (X : Type*)
+    : loop_susp_counit (susp X) ∘* susp_functor (loop_susp_unit X) ~* pid (susp X) :=
   begin
     induction X with X x, fconstructor,
     { intro x', induction x',
       { reflexivity },
       { exact merid pt },
       { apply eq_pathover,
-        xrewrite [▸*, ap_id, ap_compose' (susp.elim north north (λa, a)), +elim_merid,▸*],
+        xrewrite [▸*, ap_id, -ap_compose' (susp.elim north north (λa, a)), +elim_merid,▸*],
         apply square_of_eq, exact !idp_con ⬝ !inv_con_cancel_right⁻¹ }},
     { reflexivity }
   end
 
-  definition psusp.elim [constructor] {X Y : Type*} (f : X →* Ω Y) : psusp X →* Y :=
-  loop_psusp_counit Y ∘* psusp_functor f
+  definition susp_elim [constructor] {X Y : Type*} (f : X →* Ω Y) : susp X →* Y :=
+  loop_susp_counit Y ∘* susp_functor f
 
-  definition loop_psusp_intro [constructor] {X Y : Type*} (f : psusp X →* Y) : X →* Ω Y :=
-  ap1 f ∘* loop_psusp_unit X
+  definition loop_susp_intro [constructor] {X Y : Type*} (f : susp X →* Y) : X →* Ω Y :=
+  ap1 f ∘* loop_susp_unit X
 
-  definition psusp_adjoint_loop_right_inv {X Y : Type*} (g : X →* Ω Y) :
-    loop_psusp_intro (psusp.elim g) ~* g :=
+  definition susp_elim_susp_functor {A B C : Type*} (g : B →* Ω C) (f : A →* B) :
+    susp_elim g ∘* susp_functor f ~* susp_elim (g ∘* f) :=
+  begin
+    refine !passoc ⬝* _, exact pwhisker_left _ !susp_functor_pcompose⁻¹*
+  end
+
+  definition susp_elim_phomotopy {A B : Type*} {f g : A →* Ω B} (p : f ~* g) : susp_elim f ~* susp_elim g :=
+  pwhisker_left _ (susp_functor_phomotopy p)
+
+  definition susp_elim_natural {X Y Z : Type*} (g : Y →* Z) (f : X →* Ω Y)
+    : g ∘* susp_elim f ~* susp_elim (Ω→ g ∘* f) :=
+  begin
+    refine _ ⬝* pwhisker_left _ !susp_functor_pcompose⁻¹*,
+    refine !passoc⁻¹* ⬝* _ ⬝* !passoc,
+    exact pwhisker_right _ !loop_susp_counit_natural
+  end
+
+  definition loop_susp_intro_natural {X Y Z : Type*} (g : susp Y →* Z) (f : X →* Y) :
+    loop_susp_intro (g ∘* susp_functor f) ~* loop_susp_intro g ∘* f :=
+  pwhisker_right _ !ap1_pcompose ⬝* !passoc ⬝* pwhisker_left _ !loop_susp_unit_natural ⬝*
+  !passoc⁻¹*
+
+  definition susp_adjoint_loop_right_inv {X Y : Type*} (g : X →* Ω Y) :
+    loop_susp_intro (susp_elim g) ~* g :=
   begin
     refine !pwhisker_right !ap1_pcompose ⬝* _,
     refine !passoc ⬝* _,
-    refine !pwhisker_left !loop_psusp_unit_natural⁻¹* ⬝* _,
+    refine !pwhisker_left !loop_susp_unit_natural ⬝* _,
     refine !passoc⁻¹* ⬝* _,
-    refine !pwhisker_right !loop_psusp_counit_unit ⬝* _,
+    refine !pwhisker_right !loop_susp_counit_unit ⬝* _,
     apply pid_pcompose
   end
 
-  definition psusp_adjoint_loop_left_inv {X Y : Type*} (f : psusp X →* Y) :
-    psusp.elim (loop_psusp_intro f) ~* f :=
+  definition susp_adjoint_loop_left_inv {X Y : Type*} (f : susp X →* Y) :
+    susp_elim (loop_susp_intro f) ~* f :=
   begin
-    refine !pwhisker_left !psusp_functor_compose ⬝* _,
+    refine !pwhisker_left !susp_functor_pcompose ⬝* _,
     refine !passoc⁻¹* ⬝* _,
-    refine !pwhisker_right !loop_psusp_counit_natural⁻¹* ⬝* _,
+    refine !pwhisker_right !loop_susp_counit_natural⁻¹* ⬝* _,
     refine !passoc ⬝* _,
-    refine !pwhisker_left !loop_psusp_unit_counit ⬝* _,
+    refine !pwhisker_left !loop_susp_unit_counit ⬝* _,
     apply pcompose_pid
   end
 
-  definition psusp_adjoint_loop_unpointed [constructor] (X Y : Type*) : psusp X →* Y ≃ X →* Ω Y :=
+  definition susp_adjoint_loop_unpointed [constructor] (X Y : Type*) : susp X →* Y ≃ X →* Ω Y :=
   begin
     fapply equiv.MK,
-    { exact loop_psusp_intro },
-    { exact psusp.elim },
-    { intro g, apply eq_of_phomotopy, exact psusp_adjoint_loop_right_inv g },
-    { intro f, apply eq_of_phomotopy, exact psusp_adjoint_loop_left_inv f }
+    { exact loop_susp_intro },
+    { exact susp_elim },
+    { intro g, apply eq_of_phomotopy, exact susp_adjoint_loop_right_inv g },
+    { intro f, apply eq_of_phomotopy, exact susp_adjoint_loop_left_inv f }
   end
 
-  definition psusp_adjoint_loop_pconst (X Y : Type*) :
-    psusp_adjoint_loop_unpointed X Y (pconst (psusp X) Y) ~* pconst X (Ω Y) :=
+  definition susp_functor_pconst_homotopy [unfold 3] {X Y : Type*} (x : susp X) :
+    susp_functor (pconst X Y) x = pt :=
   begin
-    refine pwhisker_right _ !ap1_pconst ⬝* _,
-    apply pconst_pcompose
+    induction x,
+    { reflexivity },
+    { exact (merid pt)⁻¹ },
+    { apply eq_pathover, refine !elim_merid ⬝ph _ ⬝hp !ap_constant⁻¹, exact square_of_eq !con.right_inv⁻¹ }
   end
 
-  definition psusp_adjoint_loop [constructor] (X Y : Type*) : ppmap (psusp X) Y ≃* ppmap X (Ω Y) :=
+  definition susp_functor_pconst [constructor] (X Y : Type*) :
+    susp_functor (pconst X Y) ~* pconst (susp X) (susp Y) :=
   begin
-    apply pequiv_of_equiv (psusp_adjoint_loop_unpointed X Y),
-    apply eq_of_phomotopy,
-    apply psusp_adjoint_loop_pconst
+    fapply phomotopy.mk,
+    { exact susp_functor_pconst_homotopy },
+    { reflexivity }
   end
 
-  definition ap1_psusp_elim {A : Type*} {X : Type*} (p : A →* Ω X) :
-    Ω→(psusp.elim p) ∘* loop_psusp_unit A ~* p :=
-  psusp_adjoint_loop_right_inv p
+  definition susp_pfunctor [constructor] (X Y : Type*) : ppmap X Y →* ppmap (susp X) (susp Y) :=
+  pmap.mk susp_functor (eq_of_phomotopy !susp_functor_pconst)
 
-  definition psusp_adjoint_loop_nat_right (f : psusp X →* Y) (g : Y →* Z)
-    : psusp_adjoint_loop X Z (g ∘* f) ~* ap1 g ∘* psusp_adjoint_loop X Y f :=
+  definition susp_pelim [constructor] (X Y : Type*) : ppmap X (Ω Y) →* ppmap (susp X) Y :=
+  ppcompose_left (loop_susp_counit Y) ∘* susp_pfunctor X (Ω Y)
+
+  definition loop_susp_pintro [constructor] (X Y : Type*) : ppmap (susp X) Y →* ppmap X (Ω Y) :=
+  ppcompose_right (loop_susp_unit X) ∘* pap1 (susp X) Y
+
+  definition loop_susp_pintro_natural_left (f : X' →* X) :
+    psquare (loop_susp_pintro X Y) (loop_susp_pintro X' Y)
+            (ppcompose_right (susp_functor f)) (ppcompose_right f) :=
+  !pap1_natural_left ⬝h* ppcompose_right_psquare (loop_susp_unit_natural f)
+
+  definition loop_susp_pintro_natural_right (f : Y →* Y') :
+    psquare (loop_susp_pintro X Y) (loop_susp_pintro X Y')
+            (ppcompose_left f) (ppcompose_left (Ω→ f)) :=
+  !pap1_natural_right ⬝h* !ppcompose_left_ppcompose_right⁻¹*
+
+  definition is_equiv_loop_susp_pintro [constructor] (X Y : Type*) :
+    is_equiv (loop_susp_pintro X Y) :=
   begin
-    esimp [psusp_adjoint_loop],
+    fapply adjointify,
+    { exact susp_pelim X Y },
+    { intro g, apply eq_of_phomotopy, exact susp_adjoint_loop_right_inv g },
+    { intro f, apply eq_of_phomotopy, exact susp_adjoint_loop_left_inv f }
+  end
+
+  definition susp_adjoint_loop [constructor] (X Y : Type*) : ppmap (susp X) Y ≃* ppmap X (Ω Y) :=
+  pequiv_of_pmap (loop_susp_pintro X Y) (is_equiv_loop_susp_pintro X Y)
+
+  definition susp_adjoint_loop_natural_right (f : Y →* Y') :
+    psquare (susp_adjoint_loop X Y) (susp_adjoint_loop X Y')
+            (ppcompose_left f) (ppcompose_left (Ω→ f)) :=
+  loop_susp_pintro_natural_right f
+
+  definition susp_adjoint_loop_natural_left (f : X' →* X) :
+    psquare (susp_adjoint_loop X Y) (susp_adjoint_loop X' Y)
+            (ppcompose_right (susp_functor f)) (ppcompose_right f) :=
+  loop_susp_pintro_natural_left f
+
+  definition ap1_susp_elim {A : Type*} {X : Type*} (p : A →* Ω X) :
+    Ω→(susp_elim p) ∘* loop_susp_unit A ~* p :=
+  susp_adjoint_loop_right_inv p
+
+  /- the underlying homotopies of susp_adjoint_loop_natural_* -/
+  definition susp_adjoint_loop_nat_right (f : susp X →* Y) (g : Y →* Z)
+    : susp_adjoint_loop X Z (g ∘* f) ~* ap1 g ∘* susp_adjoint_loop X Y f :=
+  begin
+    esimp [susp_adjoint_loop],
     refine _ ⬝* !passoc,
     apply pwhisker_right,
     apply ap1_pcompose
   end
 
-  definition psusp_adjoint_loop_nat_left (f : Y →* Ω Z) (g : X →* Y)
-    : (psusp_adjoint_loop X Z)⁻¹ᵉ (f ∘* g) ~* (psusp_adjoint_loop Y Z)⁻¹ᵉ f ∘* psusp_functor g :=
+  definition susp_adjoint_loop_nat_left (f : Y →* Ω Z) (g : X →* Y)
+    : (susp_adjoint_loop X Z)⁻¹ᵉ (f ∘* g) ~* (susp_adjoint_loop Y Z)⁻¹ᵉ f ∘* susp_functor g :=
   begin
-    esimp [psusp_adjoint_loop],
+    esimp [susp_adjoint_loop],
     refine _ ⬝* !passoc⁻¹*,
     apply pwhisker_left,
-    apply psusp_functor_compose
+    apply susp_functor_pcompose
   end
 
   /- iterated suspension -/
-  definition iterate_susp (n : ℕ) (A : Type) : Type := iterate susp n A
-  definition iterate_psusp (n : ℕ) (A : Type*) : Type* := iterate (λX, psusp X) n A
+  definition iterate_susp (n : ℕ) (A : Type*) : Type* := iterate (λX, susp X) n A
 
   open is_conn trunc_index nat
-  definition iterate_susp_succ (n : ℕ) (A : Type) :
+  definition iterate_susp_succ (n : ℕ) (A : Type*) :
     iterate_susp (succ n) A = susp (iterate_susp n A) :=
   idp
 
-  definition is_conn_iterate_susp [instance] (n : ℕ₋₂) (m : ℕ) (A : Type)
+  definition is_conn_iterate_susp [instance] (n : ℕ₋₂) (m : ℕ) (A : Type*)
     [H : is_conn n A] : is_conn (n + m) (iterate_susp m A) :=
   begin induction m with m IH, exact H, exact @is_conn_susp _ _ IH end
 
-  definition is_conn_iterate_psusp [instance] (n : ℕ₋₂) (m : ℕ) (A : Type*)
-    [H : is_conn n A] : is_conn (n + m) (iterate_psusp m A) :=
-  begin induction m with m IH, exact H, exact @is_conn_susp _ _ IH end
-
   -- Separate cases for n = 0, which comes up often
-  definition is_conn_iterate_susp_zero [instance] (m : ℕ) (A : Type)
+  definition is_conn_iterate_susp_zero [instance] (m : ℕ) (A : Type*)
     [H : is_conn 0 A] : is_conn m (iterate_susp m A) :=
   begin induction m with m IH, exact H, exact @is_conn_susp _ _ IH end
 
-  definition is_conn_iterate_psusp_zero [instance] (m : ℕ) (A : Type*)
-    [H : is_conn 0 A] : is_conn m (iterate_psusp m A) :=
-  begin induction m with m IH, exact H, exact @is_conn_susp _ _ IH end
-
-  definition iterate_psusp_functor (n : ℕ) {A B : Type*} (f : A →* B) :
-    iterate_psusp n A →* iterate_psusp n B :=
+  definition iterate_susp_functor (n : ℕ) {A B : Type*} (f : A →* B) :
+    iterate_susp n A →* iterate_susp n B :=
   begin
     induction n with n g,
     { exact f },
-    { exact psusp_functor g }
+    { exact susp_functor g }
   end
 
-  definition iterate_psusp_succ_in (n : ℕ) (A : Type*) :
-    iterate_psusp (succ n) A ≃* iterate_psusp n (psusp A) :=
+  definition iterate_susp_succ_in (n : ℕ) (A : Type*) :
+    iterate_susp (succ n) A ≃* iterate_susp n (susp A) :=
   begin
     induction n with n IH,
     { reflexivity},
-    { exact psusp_equiv IH}
+    { exact susp_pequiv IH}
   end
 
-  definition iterate_psusp_adjoint_loopn [constructor] (X Y : Type*) (n : ℕ) :
-    ppmap (iterate_psusp n X) Y ≃* ppmap X (Ω[n] Y) :=
+  definition iterate_susp_adjoint_loopn [constructor] (X Y : Type*) (n : ℕ) :
+    ppmap (iterate_susp n X) Y ≃* ppmap X (Ω[n] Y) :=
   begin
     revert X Y, induction n with n IH: intro X Y,
     { reflexivity },
-    { refine !psusp_adjoint_loop ⬝e* !IH ⬝e* _, apply pequiv_ppcompose_left,
+    { refine !susp_adjoint_loop ⬝e* !IH ⬝e* _, apply ppmap_pequiv_ppmap_right,
       symmetry, apply loopn_succ_in }
   end
 
-
 end susp

hott/homotopy/vankampen.hlean

@@ -59,7 +59,7 @@ namespace pushout
   protected definition code_equiv (x : BL + TR) (y : TL) :
     @hom C _ x (sum.inl (f y)) ≃ @hom C _ x (sum.inr (g y)) :=
   begin
-    refine @is_prop.elim_set _ _ _ _ _ (ksurj y), { apply @is_trunc_equiv: apply is_set_hom},
+    refine @prop_trunc.elim_set _ _ _ _ _ (ksurj y), { apply @is_trunc_equiv: apply is_set_hom},
     { intro v, cases v with s p,
       exact code_equiv_pt x p},
     intro v v', cases v with s p, cases v' with s' p',
@@ -74,7 +74,7 @@ namespace pushout
     refine @set_quotient.rec_prop _ _ _ _ _ h, {intro l, apply is_trunc_eq, apply is_set_hom},
     intro l,
     have ksurj (k s) = tr (fiber.mk s idp), from !is_prop.elim,
-    refine ap (λz, to_fun (@is_prop.elim_set _ _ _ _ _ z) (class_of l)) this ⬝ _,
+    refine ap (λz, to_fun (@prop_trunc.elim_set _ _ _ _ _ z) (class_of l)) this ⬝ _,
     change class_of ([iE k F G (tr idp), DE k F G s, iD k F G (tr idp)] ++ l) =
            class_of (DE k F G s :: l) :> @hom C _ _ _,
     refine eq_of_rel (tr _) ⬝ (eq_of_rel (tr _)),
@@ -172,9 +172,9 @@ namespace pushout
     { rewrite [decode_list_pair, decode_list_nil], exact ap tr !con.left_inv},
     { apply decode_list_singleton},
     { apply decode_list_singleton},
-    { rewrite [+decode_list_pair], induction h with p, apply ap tr, rewrite [-+ap_compose'],
+    { rewrite [+decode_list_pair], induction h with p, apply ap tr, rewrite [+ap_compose'],
       exact !ap_con_eq_con_ap⁻¹},
-    { rewrite [+decode_list_pair], induction h with p, apply ap tr, rewrite [-+ap_compose'],
+    { rewrite [+decode_list_pair], induction h with p, apply ap tr, rewrite [+ap_compose'],
       apply ap_con_eq_con_ap}
   end
 
@@ -231,7 +231,6 @@ namespace pushout
 --       revert c, apply @set_quotient.rec_prop, { intro z, apply is_trunc_pathover},
 --       intro l,
 --       refine _ ⬝op ap decode_point !quotient.elim_type_eq_of_rel⁻¹,
--- -- REPORT THIS!!! esimp fails here, but works after this change
 --   --esimp,
 --       change pathover (λ (a : pushout f g), trunc 0 (eq (pushout_of_sum x) a))
 --       (decode_point (class_of l))

hott/homotopy/wedge.hlean

@@ -9,22 +9,34 @@ import hit.pushout .connectedness types.unit
 
 open eq pushout pointed unit trunc_index
 
-definition wedge (A B : Type*) : Type := ppushout (pconst punit A) (pconst punit B)
-local attribute wedge [reducible]
-definition pwedge (A B : Type*) : Type* := pointed.mk' (wedge A B)
-infixr ` ∨ ` := pwedge
+definition wedge' (A B : Type*) : Type := ppushout (pconst punit A) (pconst punit B)
+local attribute wedge' [reducible]
+definition wedge [constructor] (A B : Type*) : Type* := pointed.mk' (wedge' A B)
+infixr ` ∨ ` := wedge
 
 namespace wedge
 
+  protected definition glue {A B : Type*} : inl pt = inr pt :> wedge A B :=
+  pushout.glue ⋆
+
   protected definition rec {A B : Type*} {P : wedge A B → Type} (Pinl : Π(x : A), P (inl x))
-    (Pinr : Π(x : B), P (inr x)) (Pglue : pathover P (Pinl pt) (glue ⋆) (Pinr pt))
-    (y : wedge A B) : P y :=
+    (Pinr : Π(x : B), P (inr x)) (Pglue : pathover P (Pinl pt) wedge.glue (Pinr pt))
+    (y : wedge' A B) : P y :=
   by induction y; apply Pinl; apply Pinr; induction x; exact Pglue
 
   protected definition elim {A B : Type*} {P : Type} (Pinl : A → P)
-    (Pinr : B → P) (Pglue : Pinl pt = Pinr pt) (y : wedge A B) : P :=
+    (Pinr : B → P) (Pglue : Pinl pt = Pinr pt) (y : wedge' A B) : P :=
   by induction y with a b x; exact Pinl a; exact Pinr b; induction x; exact Pglue
 
+  protected definition rec_glue {A B : Type*} {P : wedge A B → Type} (Pinl : Π(x : A), P (inl x))
+    (Pinr : Π(x : B), P (inr x)) (Pglue : pathover P (Pinl pt) wedge.glue (Pinr pt)) :
+    apd (wedge.rec Pinl Pinr Pglue) wedge.glue = Pglue :=
+  !pushout.rec_glue
+
+  protected definition elim_glue {A B : Type*} {P : Type} (Pinl : A → P) (Pinr : B → P)
+    (Pglue : Pinl pt = Pinr pt) : ap (wedge.elim Pinl Pinr Pglue) wedge.glue = Pglue :=
+  !pushout.elim_glue
+
 end wedge
 
 attribute wedge.rec wedge.elim [recursor 7] [unfold 7]
@@ -32,13 +44,13 @@ attribute wedge.rec wedge.elim [recursor 7] [unfold 7]
 namespace wedge
 
   -- TODO maybe find a cleaner proof
-  protected definition unit (A : Type*) : A ≃* pwedge punit A :=
+  protected definition unit (A : Type*) : A ≃* wedge punit A :=
   begin
     fapply pequiv_of_pmap,
     { fapply pmap.mk, intro a, apply pinr a, apply respect_pt },
     { fapply is_equiv.adjointify, intro x, fapply pushout.elim_on x,
       exact λ x, Point A, exact id, intro u, reflexivity,
-      intro x, fapply pushout.rec_on x, intro u, cases u, esimp, apply (glue unit.star)⁻¹,
+      intro x, fapply pushout.rec_on x, intro u, cases u, esimp, apply wedge.glue⁻¹,
       intro a, reflexivity,
       intro u, cases u, esimp, apply eq_pathover,
       refine _ ⬝hp !ap_id⁻¹, fapply eq_hconcat, apply ap_compose inr,

hott/init/datatypes.hlean

@@ -58,9 +58,8 @@ sigma.rec (λ a b, a) p
 definition sigma.pr2 [reducible] [unfold 3] {A : Type} {B : A → Type} (p : sigma B) : B (sigma.pr1 p) :=
 sigma.rec (λ a b, b) p
 
--- pos_num and num are two auxiliary datatypes used when parsing numerals such as 13, 0, 26.
--- The parser will generate the terms (pos (bit1 (bit1 (bit0 one)))), zero, and (pos (bit0 (bit1 (bit1 one)))).
--- This representation can be coerced in whatever we want (e.g., naturals, integers, reals, etc).
+-- pos_num and num are two auxiliary datatypes used when parsing numerals such as 13, 0, 26
+-- in an [priority n] flag.
 inductive pos_num : Type :=
 | one  : pos_num
 | bit1 : pos_num → pos_num

hott/init/equiv.hlean

@@ -45,10 +45,10 @@ namespace is_equiv
   is_equiv.mk id id (λa, idp) (λa, idp) (λa, idp)
 
   -- The composition of two equivalences is, again, an equivalence.
-  definition is_equiv_compose [constructor] [Hf : is_equiv f] [Hg : is_equiv g]
+  definition is_equiv_compose [constructor] (Hf : is_equiv f) (Hg : is_equiv g)
     : is_equiv (g ∘ f) :=
-  is_equiv.mk (g ∘ f) (f⁻¹ ∘ g⁻¹)
-             abstract (λc, ap g (right_inv f (g⁻¹ c)) ⬝ right_inv g c) end
+  is_equiv.mk (g ∘ f) (f⁻¹ᶠ ∘ g⁻¹ᶠ)
+             abstract (λc, ap g (right_inv f (g⁻¹ᶠ c)) ⬝ right_inv g c) end
              abstract (λa, ap (inv f) (left_inv g (f a)) ⬝ left_inv f a) end
              abstract (λa, (whisker_left _ (adj g (f a))) ⬝
                   (ap_con g _ _)⁻¹ ⬝
@@ -105,19 +105,23 @@ namespace is_equiv
   end
 
   -- Any function pointwise equal to an equivalence is an equivalence as well.
-  definition homotopy_closed [constructor] {A B : Type} (f : A → B) {f' : A → B} [Hf : is_equiv f]
-    (Hty : f ~ f') : is_equiv f' :=
+  definition homotopy_closed [constructor] {A B : Type} (f : A → B) {f' : A → B} (Hty : f ~ f')
+    (Hf : is_equiv f) : is_equiv f' :=
   adjointify f'
              (inv f)
              (λ b, (Hty (inv f b))⁻¹ ⬝ right_inv f b)
              (λ a, (ap (inv f) (Hty a))⁻¹ ⬝ left_inv f a)
 
-  definition inv_homotopy_closed [constructor] {A B : Type} {f : A → B} {f' : B → A}
-    [Hf : is_equiv f] (Hty : f⁻¹ ~ f') : is_equiv f :=
+  definition inv_homotopy_closed [constructor] {A B : Type} {f : A → B} (f' : B → A)
+    (Hf : is_equiv f) (Hty : f⁻¹ᶠ ~ f') : is_equiv f :=
   adjointify f
              f'
-             (λ b, ap f !Hty⁻¹ ⬝ right_inv f b)
-             (λ a, !Hty⁻¹ ⬝ left_inv f a)
+             (λ b, ap f !Hty⁻¹ᵖ ⬝ right_inv f b)
+             (λ a, !Hty⁻¹ᵖ ⬝ left_inv f a)
+
+  definition inv_homotopy_inv {A B : Type} {f g : A → B} [is_equiv f] [is_equiv g] (p : f ~ g)
+    : f⁻¹ᶠ ~ g⁻¹ᶠ :=
+  λb, (left_inv g (f⁻¹ᶠ b))⁻¹ ⬝ ap g⁻¹ᶠ ((p (f⁻¹ᶠ b))⁻¹ ⬝ right_inv f b)
 
   definition is_equiv_up [instance] [constructor] (A : Type)
     : is_equiv (up : A → lift A) :=
@@ -136,61 +140,59 @@ namespace is_equiv
   -- over all of B.
 
   definition is_equiv_rect (P : B → Type) (g : Πa, P (f a)) (b : B) : P b :=
-  right_inv f b ▸ g (f⁻¹ b)
+  right_inv f b ▸ g (f⁻¹ᶠ b)
 
-  definition is_equiv_rect' (P : A → B → Type) (g : Πb, P (f⁻¹ b) b) (a : A) : P a (f a) :=
+  definition is_equiv_rect' (P : A → B → Type) (g : Πb, P (f⁻¹ᶠ b) b) (a : A) : P a (f a) :=
   left_inv f a ▸ g (f a)
 
   definition is_equiv_rect_comp (P : B → Type)
       (df : Π (x : A), P (f x)) (x : A) : is_equiv_rect f P df (f x) = df x :=
   calc
     is_equiv_rect f P df (f x)
-          = right_inv f (f x) ▸ df (f⁻¹ (f x))   : by esimp
-      ... = ap f (left_inv f x) ▸ df (f⁻¹ (f x)) : by rewrite -adj
-      ... = left_inv f x ▸ df (f⁻¹ (f x))        : by rewrite -tr_compose
+          = right_inv f (f x) ▸ df (f⁻¹ᶠ (f x))   : by esimp
+      ... = ap f (left_inv f x) ▸ df (f⁻¹ᶠ (f x)) : by rewrite -adj
+      ... = left_inv f x ▸ df (f⁻¹ᶠ (f x))        : by rewrite -tr_compose
       ... = df x                                 : by rewrite (apdt df (left_inv f x))
 
-  theorem adj_inv (b : B) : left_inv f (f⁻¹ b) = ap f⁻¹ (right_inv f b) :=
+  theorem adj_inv (b : B) : left_inv f (f⁻¹ᶠ b) = ap f⁻¹ᶠ (right_inv f b) :=
   is_equiv_rect f _
     (λa, eq.cancel_right (left_inv f (id a))
            (whisker_left _ !ap_id⁻¹ ⬝ (ap_con_eq_con_ap (left_inv f) (left_inv f a))⁻¹) ⬝
-      !ap_compose ⬝ ap02 f⁻¹ (adj f a)⁻¹)
+      !ap_compose ⬝ ap02 f⁻¹ᶠ (adj f a)⁻¹)
     b
 
   --The inverse of an equivalence is, again, an equivalence.
-  definition is_equiv_inv [instance] [constructor] [priority 500] : is_equiv f⁻¹ :=
-  is_equiv.mk f⁻¹ f (left_inv f) (right_inv f) (adj_inv f)
+  definition is_equiv_inv [instance] [constructor] [priority 500] : is_equiv f⁻¹ᶠ :=
+  is_equiv.mk f⁻¹ᶠ f (left_inv f) (right_inv f) (adj_inv f)
 
   -- The 2-out-of-3 properties
   definition cancel_right (g : B → C) [Hgf : is_equiv (g ∘ f)] : (is_equiv g) :=
-  have Hfinv : is_equiv f⁻¹, from is_equiv_inv f,
-  @homotopy_closed _ _ _ _ (is_equiv_compose (g ∘ f) f⁻¹) (λb, ap g (@right_inv _ _ f _ b))
+  homotopy_closed _ (λb, ap g (right_inv f b)) (is_equiv_compose (g ∘ f) f⁻¹ᶠ _ _)
 
   definition cancel_left (g : C → A) [Hgf : is_equiv (f ∘ g)] : (is_equiv g) :=
-  have Hfinv : is_equiv f⁻¹, from is_equiv_inv f,
-  @homotopy_closed _ _ _ _ (is_equiv_compose f⁻¹ (f ∘ g)) (λa, left_inv f (g a))
+  homotopy_closed _ (λa, left_inv f (g a)) (is_equiv_compose f⁻¹ᶠ (f ∘ g) _ _)
 
-  definition eq_of_fn_eq_fn' [unfold 4] {x y : A} (q : f x = f y) : x = y :=
-  (left_inv f x)⁻¹ ⬝ ap f⁻¹ q ⬝ left_inv f y
+  definition inj' [unfold 4] {x y : A} (q : f x = f y) : x = y :=
+  (left_inv f x)⁻¹ ⬝ ap f⁻¹ᶠ q ⬝ left_inv f y
 
-  definition ap_eq_of_fn_eq_fn' {x y : A} (q : f x = f y) : ap f (eq_of_fn_eq_fn' f q) = q :=
+  definition ap_inj' {x y : A} (q : f x = f y) : ap f (inj' f q) = q :=
   !ap_con ⬝ whisker_right _ !ap_con
           ⬝ ((!ap_inv ⬝ inverse2 (adj f _)⁻¹)
-            ◾ (inverse (ap_compose f f⁻¹ _))
+            ◾ (inverse (ap_compose f f⁻¹ᶠ _))
             ◾ (adj f _)⁻¹)
           ⬝ con_ap_con_eq_con_con (right_inv f) _ _
           ⬝ whisker_right _ !con.left_inv
           ⬝ !idp_con
 
-  definition eq_of_fn_eq_fn'_ap {x y : A} (q : x = y) : eq_of_fn_eq_fn' f (ap f q) = q :=
+  definition inj'_ap {x y : A} (q : x = y) : inj' f (ap f q) = q :=
   by induction q; apply con.left_inv
 
   definition is_equiv_ap [instance] [constructor] (x y : A) : is_equiv (ap f : x = y → f x = f y) :=
   adjointify
     (ap f)
-    (eq_of_fn_eq_fn' f)
-    (ap_eq_of_fn_eq_fn' f)
-    (eq_of_fn_eq_fn'_ap f)
+    (inj' f)
+    (ap_inj' f)
+    (inj'_ap f)
 
   end
 
@@ -200,16 +202,16 @@ namespace is_equiv
 
   section rewrite_rules
     variables {a : A} {b : B}
-    definition eq_of_eq_inv (p : a = f⁻¹ b) : f a = b :=
+    definition eq_of_eq_inv (p : a = f⁻¹ᶠ b) : f a = b :=
     ap f p ⬝ right_inv f b
 
-    definition eq_of_inv_eq (p : f⁻¹ b = a) : b = f a :=
+    definition eq_of_inv_eq (p : f⁻¹ᶠ b = a) : b = f a :=
     (eq_of_eq_inv p⁻¹)⁻¹
 
-    definition inv_eq_of_eq (p : b = f a) : f⁻¹ b = a :=
-    ap f⁻¹ p ⬝ left_inv f a
+    definition inv_eq_of_eq (p : b = f a) : f⁻¹ᶠ b = a :=
+    ap f⁻¹ᶠ p ⬝ left_inv f a
 
-    definition eq_inv_of_eq (p : f a = b) : a = f⁻¹ b :=
+    definition eq_inv_of_eq (p : f a = b) : a = f⁻¹ᶠ b :=
     (inv_eq_of_eq p⁻¹)⁻¹
   end rewrite_rules
 
@@ -218,33 +220,33 @@ namespace is_equiv
   section pre_compose
     variables (α : A → C) (β : B → C)
 
-    definition homotopy_of_homotopy_inv_pre (p : β ~ α ∘ f⁻¹) : β ∘ f ~ α :=
+    definition homotopy_of_homotopy_inv_pre (p : β ~ α ∘ f⁻¹ᶠ) : β ∘ f ~ α :=
     λ a, p (f a) ⬝ ap α (left_inv f a)
 
-    definition homotopy_of_inv_homotopy_pre (p : α ∘ f⁻¹ ~ β) : α ~ β ∘ f :=
+    definition homotopy_of_inv_homotopy_pre (p : α ∘ f⁻¹ᶠ ~ β) : α ~ β ∘ f :=
     λ a, (ap α (left_inv f a))⁻¹ ⬝ p (f a)
 
-    definition inv_homotopy_of_homotopy_pre (p : α ~ β ∘ f) : α ∘ f⁻¹ ~ β :=
-    λ b, p (f⁻¹ b) ⬝ ap β (right_inv f b)
+    definition inv_homotopy_of_homotopy_pre (p : α ~ β ∘ f) : α ∘ f⁻¹ᶠ ~ β :=
+    λ b, p (f⁻¹ᶠ b) ⬝ ap β (right_inv f b)
 
-    definition homotopy_inv_of_homotopy_pre (p : β ∘ f ~ α) : β ~ α ∘ f⁻¹  :=
-    λ b, (ap β (right_inv f b))⁻¹ ⬝ p (f⁻¹ b)
+    definition homotopy_inv_of_homotopy_pre (p : β ∘ f ~ α) : β ~ α ∘ f⁻¹ᶠ  :=
+    λ b, (ap β (right_inv f b))⁻¹ ⬝ p (f⁻¹ᶠ b)
   end pre_compose
 
   section post_compose
     variables (α : C → A) (β : C → B)
 
-    definition homotopy_of_homotopy_inv_post (p : α ~ f⁻¹ ∘ β) : f ∘ α ~ β :=
+    definition homotopy_of_homotopy_inv_post (p : α ~ f⁻¹ᶠ ∘ β) : f ∘ α ~ β :=
     λ c, ap f (p c) ⬝ (right_inv f (β c))
 
-    definition homotopy_of_inv_homotopy_post (p : f⁻¹ ∘ β ~ α) : β ~ f ∘ α :=
+    definition homotopy_of_inv_homotopy_post (p : f⁻¹ᶠ ∘ β ~ α) : β ~ f ∘ α :=
     λ c, (right_inv f (β c))⁻¹ ⬝ ap f (p c)
 
-    definition inv_homotopy_of_homotopy_post (p : β ~ f ∘ α) : f⁻¹ ∘ β ~ α :=
-    λ c, ap f⁻¹ (p c) ⬝ (left_inv f (α c))
+    definition inv_homotopy_of_homotopy_post (p : β ~ f ∘ α) : f⁻¹ᶠ ∘ β ~ α :=
+    λ c, ap f⁻¹ᶠ (p c) ⬝ (left_inv f (α c))
 
-    definition homotopy_inv_of_homotopy_post (p : f ∘ α ~ β) : α ~ f⁻¹ ∘ β :=
-    λ c, (left_inv f (α c))⁻¹ ⬝ ap f⁻¹ (p c)
+    definition homotopy_inv_of_homotopy_post (p : f ∘ α ~ β) : α ~ f⁻¹ᶠ ∘ β :=
+    λ c, (left_inv f (α c))⁻¹ ⬝ ap f⁻¹ᶠ (p c)
   end post_compose
 
   end
@@ -264,25 +266,25 @@ namespace is_equiv
 
   include H
   definition inv_commute' (p : Π⦃a : A⦄ (b : B (g' a)), f (h b) = h' (f b)) {a : A}
-    (c : C (g' a)) : f⁻¹ (h' c) = h (f⁻¹ c) :=
-  eq_of_fn_eq_fn' f (right_inv f (h' c) ⬝ ap h' (right_inv f c)⁻¹ ⬝ (p (f⁻¹ c))⁻¹)
+    (c : C (g' a)) : f⁻¹ᶠ (h' c) = h (f⁻¹ᶠ c) :=
+  inj' f (right_inv f (h' c) ⬝ ap h' (right_inv f c)⁻¹ ⬝ (p (f⁻¹ᶠ c))⁻¹)
 
-  definition fun_commute_of_inv_commute' (p : Π⦃a : A⦄ (c : C (g' a)), f⁻¹ (h' c) = h (f⁻¹ c))
+  definition fun_commute_of_inv_commute' (p : Π⦃a : A⦄ (c : C (g' a)), f⁻¹ᶠ (h' c) = h (f⁻¹ᶠ c))
     {a : A} (b : B (g' a)) : f (h b) = h' (f b) :=
-  eq_of_fn_eq_fn' f⁻¹ (left_inv f (h b) ⬝ ap h (left_inv f b)⁻¹ ⬝ (p (f b))⁻¹)
+  inj' f⁻¹ᶠ (left_inv f (h b) ⬝ ap h (left_inv f b)⁻¹ ⬝ (p (f b))⁻¹)
 
   definition ap_inv_commute' (p : Π⦃a : A⦄ (b : B (g' a)), f (h b) = h' (f b)) {a : A}
     (c : C (g' a)) : ap f (inv_commute' @f @h @h' p c)
-                       = right_inv f (h' c) ⬝ ap h' (right_inv f c)⁻¹ ⬝ (p (f⁻¹ c))⁻¹ :=
-  !ap_eq_of_fn_eq_fn'
+                       = right_inv f (h' c) ⬝ ap h' (right_inv f c)⁻¹ ⬝ (p (f⁻¹ᶠ c))⁻¹ :=
+  !ap_inj'
 
   -- inv_commute'_fn is in types.equiv
   end
 
   -- This is inv_commute' for A ≡ unit
   definition inv_commute1' {B C : Type} (f : B → C) [is_equiv f] (h : B → B) (h' : C → C)
-    (p : Π(b : B), f (h b) = h' (f b)) (c : C) : f⁻¹ (h' c) = h (f⁻¹ c) :=
-  eq_of_fn_eq_fn' f (right_inv f (h' c) ⬝ ap h' (right_inv f c)⁻¹ ⬝ (p (f⁻¹ c))⁻¹)
+    (p : Π(b : B), f (h b) = h' (f b)) (c : C) : f⁻¹ᶠ (h' c) = h (f⁻¹ᶠ c) :=
+  inj' f (right_inv f (h' c) ⬝ ap h' (right_inv f c)⁻¹ ⬝ (p (f⁻¹ᶠ c))⁻¹)
 
 end is_equiv
 open is_equiv
@@ -312,10 +314,10 @@ namespace equiv
     (right_inv : Πb, f (g b) = b) (left_inv : Πa, g (f a) = a) : A ≃ B :=
   equiv.mk f (adjointify f g right_inv left_inv)
 
-  definition to_inv [reducible] [unfold 3] (f : A ≃ B) : B → A := f⁻¹
-  definition to_right_inv [reducible] [unfold 3] (f : A ≃ B) (b : B) : f (f⁻¹ b) = b :=
+  definition to_inv [reducible] [unfold 3] (f : A ≃ B) : B → A := f⁻¹ᶠ
+  definition to_right_inv [reducible] [unfold 3] (f : A ≃ B) (b : B) : f (f⁻¹ᶠ b) = b :=
   right_inv f b
-  definition to_left_inv [reducible] [unfold 3] (f : A ≃ B) (a : A) : f⁻¹ (f a) = a :=
+  definition to_left_inv [reducible] [unfold 3] (f : A ≃ B) (a : A) : f⁻¹ᶠ (f a) = a :=
   left_inv f a
 
   protected definition rfl [refl] [constructor] : A ≃ A :=
@@ -325,10 +327,10 @@ namespace equiv
   @equiv.rfl A
 
   protected definition symm [symm] [constructor] (f : A ≃ B) : B ≃ A :=
-  equiv.mk f⁻¹ !is_equiv_inv
+  equiv.mk f⁻¹ᶠ !is_equiv_inv
 
   protected definition trans [trans] [constructor] (f : A ≃ B) (g : B ≃ C) : A ≃ C :=
-  equiv.mk (g ∘ f) !is_equiv_compose
+  equiv.mk (g ∘ f) (is_equiv_compose g f _ _)
 
   infixl ` ⬝e `:75 := equiv.trans
   postfix `⁻¹ᵉ`:(max + 1) := equiv.symm
@@ -340,18 +342,17 @@ namespace equiv
   idp
 
   definition equiv_change_fun [constructor] (f : A ≃ B) {f' : A → B} (Heq : f ~ f') : A ≃ B :=
-  equiv.mk f' (is_equiv.homotopy_closed f Heq)
+  equiv.mk f' (is_equiv.homotopy_closed f Heq _)
 
-  definition equiv_change_inv [constructor] (f : A ≃ B) {f' : B → A} (Heq : f⁻¹ ~ f')
+  definition equiv_change_inv [constructor] (f : A ≃ B) {f' : B → A} (Heq : f⁻¹ᶠ ~ f')
     : A ≃ B :=
-  equiv.mk f (inv_homotopy_closed Heq)
+  equiv.mk f (inv_homotopy_closed _ _ Heq)
 
-  --rename: eq_equiv_fn_eq_fn_of_is_equiv
-  definition eq_equiv_fn_eq [constructor] (f : A → B) [H : is_equiv f] (a b : A) : (a = b) ≃ (f a = f b) :=
+  definition eq_equiv_fn_eq_of_is_equiv [constructor] (f : A → B) [H : is_equiv f] (a b : A) :
+    (a = b) ≃ (f a = f b) :=
   equiv.mk (ap f) !is_equiv_ap
 
-  --rename: eq_equiv_fn_eq_fn
-  definition eq_equiv_fn_eq_of_equiv [constructor] (f : A ≃ B) (a b : A) : (a = b) ≃ (f a = f b) :=
+  definition eq_equiv_fn_eq [constructor] (f : A ≃ B) (a b : A) : (a = b) ≃ (f a = f b) :=
   equiv.mk (ap f) !is_equiv_ap
 
   definition equiv_ap [constructor] (P : A → Type) {a b : A} (p : a = b) : P a ≃ P b :=
@@ -364,12 +365,21 @@ namespace equiv
     : equiv_of_eq (refl A) = equiv.refl A :=
   idp
 
-  definition eq_of_fn_eq_fn [unfold 3] (f : A ≃ B) {x y : A} (q : f x = f y) : x = y :=
-  (left_inv f x)⁻¹ ⬝ ap f⁻¹ q ⬝ left_inv f y
+  definition inj [unfold 3] (f : A ≃ B) {x y : A} (q : f x = f y) : x = y :=
+  (left_inv f x)⁻¹ ⬝ ap f⁻¹ᶠ q ⬝ left_inv f y
 
-  definition eq_of_fn_eq_fn_inv [unfold 3] (f : A ≃ B) {x y : B} (q : f⁻¹ x = f⁻¹ y) : x = y :=
+  definition inj_inv [unfold 3] (f : A ≃ B) {x y : B} (q : f⁻¹ᶠ x = f⁻¹ᶠ y) : x = y :=
   (right_inv f x)⁻¹ ⬝ ap f q ⬝ right_inv f y
 
+  definition ap_inj (f : A ≃ B) {x y : A} (q : f x = f y) : ap f (inj' f q) = q :=
+  ap_inj' f q
+
+  definition inj_ap (f : A ≃ B) {x y : A} (q : x = y) : inj' f (ap f q) = q :=
+  inj'_ap f q
+
+  definition to_inv_homotopy_inv {f g : A ≃ B} (p : f ~ g) : f⁻¹ᵉ ~ g⁻¹ᵉ :=
+  inv_homotopy_inv p
+
   --we need this theorem for the funext_of_ua proof
   theorem inv_eq {A B : Type} (eqf eqg : A ≃ B) (p : eqf = eqg) : (to_fun eqf)⁻¹ = (to_fun eqg)⁻¹ :=
   eq.rec_on p idp
@@ -382,34 +392,51 @@ namespace equiv
   definition equiv_lift [constructor] (A : Type) : A ≃ lift A := equiv.mk up _
 
   definition equiv_rect (f : A ≃ B) (P : B → Type) (g : Πa, P (f a)) (b : B) : P b :=
-  right_inv f b ▸ g (f⁻¹ b)
+  right_inv f b ▸ g (f⁻¹ᶠ b)
 
-  definition equiv_rect' (f : A ≃ B) (P : A → B → Type) (g : Πb, P (f⁻¹ b) b) (a : A) : P a (f a) :=
+  definition equiv_rect' (f : A ≃ B) (P : A → B → Type) (g : Πb, P (f⁻¹ᶠ b) b) (a : A) : P a (f a) :=
   left_inv f a ▸ g (f a)
 
   definition equiv_rect_comp (f : A ≃ B) (P : B → Type)
       (df : Π (x : A), P (f x)) (x : A) : equiv_rect f P df (f x) = df x :=
     calc
       equiv_rect f P df (f x)
-            = right_inv f (f x) ▸ df (f⁻¹ (f x))   : by esimp
-        ... = ap f (left_inv f x) ▸ df (f⁻¹ (f x)) : by rewrite -adj
-        ... = left_inv f x ▸ df (f⁻¹ (f x))        : by rewrite -tr_compose
+            = right_inv f (f x) ▸ df (f⁻¹ᶠ (f x))   : by esimp
+        ... = ap f (left_inv f x) ▸ df (f⁻¹ᶠ (f x)) : by rewrite -adj
+        ... = left_inv f x ▸ df (f⁻¹ᶠ (f x))        : by rewrite -tr_compose
         ... = df x                                 : by rewrite (apdt df (left_inv f x))
   end
 
+  definition rec_eq_of_equiv {A : Type} {P : A → A → Type} (e : Πa a', a = a' ≃ P a a')
+    {a a' : A} (Q : P a a' → Type) (H : Π(q : a = a'), Q (e a a' q)) :
+    Π(p : P a a'), Q p :=
+  equiv_rect (e a a') Q H
+
+  definition rec_idp_of_equiv {A : Type} {P : A → A → Type} (e : Πa a', a = a' ≃ P a a') {a : A}
+    (r : P a a) (s : e a a idp = r) (Q : Πa', P a a' → Type) (H : Q a r) ⦃a' : A⦄ (p : P a a') :
+    Q a' p :=
+  rec_eq_of_equiv e _ begin intro q, induction q, induction s, exact H end p
+
+  definition rec_idp_of_equiv_idp {A : Type} {P : A → A → Type} (e : Πa a', a = a' ≃ P a a') {a : A}
+    (r : P a a) (s : e a a idp = r) (Q : Πa', P a a' → Type) (H : Q a r) :
+    rec_idp_of_equiv e r s Q H r = H :=
+  begin
+    induction s, refine !is_equiv_rect_comp ⬝ _, reflexivity
+  end
+
   section
 
   variables {A B : Type} (f : A ≃ B) {a : A} {b : B}
-  definition to_eq_of_eq_inv (p : a = f⁻¹ b) : f a = b :=
+  definition to_eq_of_eq_inv (p : a = f⁻¹ᶠ b) : f a = b :=
   ap f p ⬝ right_inv f b
 
-  definition to_eq_of_inv_eq (p : f⁻¹ b = a) : b = f a :=
+  definition to_eq_of_inv_eq (p : f⁻¹ᶠ b = a) : b = f a :=
   (eq_of_eq_inv p⁻¹)⁻¹
 
-  definition to_inv_eq_of_eq (p : b = f a) : f⁻¹ b = a :=
-  ap f⁻¹ p ⬝ left_inv f a
+  definition to_inv_eq_of_eq (p : b = f a) : f⁻¹ᶠ b = a :=
+  ap f⁻¹ᶠ p ⬝ left_inv f a
 
-  definition to_eq_inv_of_eq (p : f a = b) : a = f⁻¹ b :=
+  definition to_eq_inv_of_eq (p : f a = b) : a = f⁻¹ᶠ b :=
   (inv_eq_of_eq p⁻¹)⁻¹
 
   end
@@ -420,15 +447,15 @@ namespace equiv
             {g : A → A} {g' : A → A} (h : Π{a}, B (g' a) → B (g a)) (h' : Π{a}, C (g' a) → C (g a))
 
   definition inv_commute (p : Π⦃a : A⦄ (b : B (g' a)), f (h b) = h' (f b)) {a : A}
-    (c : C (g' a)) : f⁻¹ (h' c) = h (f⁻¹ c) :=
+    (c : C (g' a)) : f⁻¹ᶠ (h' c) = h (f⁻¹ᶠ c) :=
   inv_commute' @f @h @h' p c
 
-  definition fun_commute_of_inv_commute (p : Π⦃a : A⦄ (c : C (g' a)), f⁻¹ (h' c) = h (f⁻¹ c))
+  definition fun_commute_of_inv_commute (p : Π⦃a : A⦄ (c : C (g' a)), f⁻¹ᶠ (h' c) = h (f⁻¹ᶠ c))
     {a : A} (b : B (g' a)) : f (h b) = h' (f b) :=
   fun_commute_of_inv_commute' @f @h @h' p b
 
   definition inv_commute1 {B C : Type} (f : B ≃ C) (h : B → B) (h' : C → C)
-    (p : Π(b : B), f (h b) =   h' (f b)) (c : C) : f⁻¹ (h' c) = h (f⁻¹ c) :=
+    (p : Π(b : B), f (h b) =   h' (f b)) (c : C) : f⁻¹ᶠ (h' c) = h (f⁻¹ᶠ c) :=
   inv_commute1' (to_fun f) h h' p c
 
   end
@@ -443,9 +470,75 @@ namespace is_equiv
 
   definition is_equiv_of_equiv_of_homotopy [constructor] {A B : Type} (f : A ≃ B)
     {f' : A → B} (Hty : f ~ f') : is_equiv f' :=
-  @(homotopy_closed f) f' _ Hty
+  homotopy_closed f Hty _
 
 end is_equiv
 
 export [unfold] equiv
 export [unfold] is_equiv
+
+/- properties about squares of functions -/
+namespace eq
+
+  section hsquare
+  variables {A₀₀ A₂₀ A₄₀ A₀₂ A₂₂ A₄₂ A₀₄ A₂₄ A₄₄ : Type}
+            {f₁₀ : A₀₀ → A₂₀} {f₃₀ : A₂₀ → A₄₀}
+            {f₀₁ : A₀₀ → A₀₂} {f₂₁ : A₂₀ → A₂₂} {f₄₁ : A₄₀ → A₄₂}
+            {f₁₂ : A₀₂ → A₂₂} {f₃₂ : A₂₂ → A₄₂}
+            {f₀₃ : A₀₂ → A₀₄} {f₂₃ : A₂₂ → A₂₄} {f₄₃ : A₄₂ → A₄₄}
+            {f₁₄ : A₀₄ → A₂₄} {f₃₄ : A₂₄ → A₄₄}
+
+  definition hsquare [reducible] (f₁₀ : A₀₀ → A₂₀) (f₁₂ : A₀₂ → A₂₂)
+                                 (f₀₁ : A₀₀ → A₀₂) (f₂₁ : A₂₀ → A₂₂) : Type :=
+  f₂₁ ∘ f₁₀ ~ f₁₂ ∘ f₀₁
+
+  definition hsquare_of_homotopy (p : f₂₁ ∘ f₁₀ ~ f₁₂ ∘ f₀₁) : hsquare f₁₀ f₁₂ f₀₁ f₂₁ :=
+  p
+
+  definition homotopy_of_hsquare (p : hsquare f₁₀ f₁₂ f₀₁ f₂₁) : f₂₁ ∘ f₁₀ ~ f₁₂ ∘ f₀₁ :=
+  p
+
+  definition homotopy_top_of_hsquare {f₂₁ : A₂₀ ≃ A₂₂} (p : hsquare f₁₀ f₁₂ f₀₁ f₂₁) :
+    f₁₀ ~ f₂₁⁻¹ ∘ f₁₂ ∘ f₀₁ :=
+  homotopy_inv_of_homotopy_post _ _ _ p
+
+  definition homotopy_top_of_hsquare' [is_equiv f₂₁] (p : hsquare f₁₀ f₁₂ f₀₁ f₂₁) :
+    f₁₀ ~ f₂₁⁻¹ ∘ f₁₂ ∘ f₀₁ :=
+  homotopy_inv_of_homotopy_post _ _ _ p
+
+  definition hhconcat [unfold_full] (p : hsquare f₁₀ f₁₂ f₀₁ f₂₁) (q : hsquare f₃₀ f₃₂ f₂₁ f₄₁) :
+    hsquare (f₃₀ ∘ f₁₀) (f₃₂ ∘ f₁₂) f₀₁ f₄₁ :=
+  hwhisker_right f₁₀ q ⬝hty hwhisker_left f₃₂ p
+
+  definition hvconcat [unfold_full] (p : hsquare f₁₀ f₁₂ f₀₁ f₂₁) (q : hsquare f₁₂ f₁₄ f₀₃ f₂₃) :
+    hsquare f₁₀ f₁₄ (f₀₃ ∘ f₀₁) (f₂₃ ∘ f₂₁) :=
+  hwhisker_left f₂₃ p ⬝hty hwhisker_right f₀₁ q
+
+  definition hhinverse {f₁₀ : A₀₀ ≃ A₂₀} {f₁₂ : A₀₂ ≃ A₂₂} (p : hsquare f₁₀ f₁₂ f₀₁ f₂₁) :
+    hsquare f₁₀⁻¹ᵉ f₁₂⁻¹ᵉ f₂₁ f₀₁ :=
+  λb, eq_inv_of_eq ((p (f₁₀⁻¹ᵉ b))⁻¹ ⬝ ap f₂₁ (to_right_inv f₁₀ b))
+
+  definition hvinverse {f₀₁ : A₀₀ ≃ A₀₂} {f₂₁ : A₂₀ ≃ A₂₂} (p : hsquare f₁₀ f₁₂ f₀₁ f₂₁) :
+    hsquare f₁₂ f₁₀ f₀₁⁻¹ᵉ f₂₁⁻¹ᵉ :=
+  λa, inv_eq_of_eq (p (f₀₁⁻¹ᵉ a) ⬝ ap f₁₂ (to_right_inv f₀₁ a))⁻¹
+
+  infix ` ⬝htyh `:73 := hhconcat
+  infix ` ⬝htyv `:73 := hvconcat
+  postfix `⁻¹ʰᵗʸʰ`:(max+1) := hhinverse
+  postfix `⁻¹ʰᵗʸᵛ`:(max+1) := hvinverse
+
+  definition rfl_hhconcat (q : hsquare f₃₀ f₃₂ f₂₁ f₄₁) : homotopy.rfl ⬝htyh q ~ q :=
+  homotopy.rfl
+
+  definition hhconcat_rfl (q : hsquare f₃₀ f₃₂ f₂₁ f₄₁) : q ⬝htyh homotopy.rfl ~ q :=
+  λx, !idp_con ⬝ ap_id (q x)
+
+  definition rfl_hvconcat (q : hsquare f₃₀ f₃₂ f₂₁ f₄₁) : homotopy.rfl ⬝htyv q ~ q :=
+  λx, !idp_con
+
+  definition hvconcat_rfl (q : hsquare f₃₀ f₃₂ f₂₁ f₄₁) : q ⬝htyv homotopy.rfl ~ q :=
+  λx, !ap_id
+
+  end hsquare
+
+end eq

hott/init/funext.hlean

@@ -239,15 +239,18 @@ end funext
 open funext
 
 namespace eq
-  definition eq_equiv_homotopy : (f = g) ≃ (f ~ g) :=
+  definition eq_equiv_homotopy (f g : Πx, P x) : (f = g) ≃ (f ~ g) :=
   equiv.mk apd10 _
 
   definition eq_of_homotopy [reducible] : f ~ g → f = g :=
-  (@apd10 A P f g)⁻¹
+  (@apd10 A P f g)⁻¹ᶠ
 
-  definition apd10_eq_of_homotopy (p : f ~ g) : apd10 (eq_of_homotopy p) = p :=
+  definition apd10_eq_of_homotopy_fn (p : f ~ g) : apd10 (eq_of_homotopy p) = p :=
   right_inv apd10 p
 
+  definition apd10_eq_of_homotopy (p : f ~ g) : apd10 (eq_of_homotopy p) ~ p :=
+  apd10 (right_inv apd10 p)
+
   definition eq_of_homotopy_apd10 (p : f = g) : eq_of_homotopy (apd10 p) = p :=
   left_inv apd10 p
 
@@ -278,6 +281,32 @@ namespace eq
     refine homotopy.rec_on' p _, intro q, induction q, exact H
   end
 
+  protected definition homotopy.rec_on_idp_left {A : Type} {P : A → Type} {g : Πa, P a}
+    {Q : Πf, (f ~ g) → Type} {f : Π x, P x}
+    (p : f ~ g) (H : Q g (homotopy.refl g)) : Q f p :=
+  begin
+    induction p using homotopy.rec_on, induction q, exact H
+  end
+
+  definition homotopy.rec_idp [recursor] {A : Type} {P : A → Type} {f : Πa, P a}
+    (Q : Π{g}, (f ~ g) → Type) (H : Q (homotopy.refl f)) {g : Π x, P x} (p : f ~ g) : Q p :=
+  homotopy.rec_on_idp p H
+
+  definition homotopy_rec_on_apd10 {A : Type} {P : A → Type} {f g : Πa, P a}
+    (Q : f ~ g → Type) (H : Π(q : f = g), Q (apd10 q)) (p : f = g) :
+    homotopy.rec_on (apd10 p) H = H p :=
+  begin
+    unfold [homotopy.rec_on],
+    refine ap (λp, p ▸ _) !adj ⬝ _,
+    refine !tr_compose⁻¹ ⬝ _,
+    apply apdt
+  end
+
+  definition homotopy_rec_idp_refl {A : Type} {P : A → Type} {f : Πa, P a}
+    (Q : Π{g}, f ~ g → Type) (H : Q homotopy.rfl) :
+    homotopy.rec_idp @Q H homotopy.rfl = H :=
+  !homotopy_rec_on_apd10
+
   definition eq_of_homotopy_inv {f g : Π x, P x} (H : f ~ g)
     : eq_of_homotopy (λx, (H x)⁻¹) = (eq_of_homotopy H)⁻¹ :=
   begin

hott/init/nat.hlean

@@ -102,9 +102,10 @@ namespace nat
   protected definition le_trans {n m k : ℕ} (H1 : n ≤ m) : m ≤ k → n ≤ k :=
   le.rec H1 (λp H2, le.step)
 
-  definition le_succ_of_le {n m : ℕ} (H : n ≤ m) : n ≤ succ m := nat.le_trans H !le_succ
+  definition le_succ_of_le {n m : ℕ} (H : n ≤ m) : n ≤ succ m := le.step H
 
-  definition le_of_succ_le {n m : ℕ} (H : succ n ≤ m) : n ≤ m := nat.le_trans !le_succ H
+  definition le_of_succ_le {n m : ℕ} (H : succ n ≤ m) : n ≤ m :=
+  by induction H with H m H'; exact le_succ n; exact le.step H'
 
   protected definition le_of_lt {n m : ℕ} (H : n < m) : n ≤ m := le_of_succ_le H
 

hott/init/path.hlean

@@ -14,7 +14,7 @@ open function eq
 /- Path equality -/
 
 namespace eq
-  variables {A B C : Type} {P : A → Type} {a a' x y z t : A} {b b' : B}
+  variables {A A' B B' C : Type} {P : A → Type} {a a' a'' x y z t : A} {b b' b'' : B}
 
   --notation a = b := eq a b
   notation x = y `:>`:50 A:49 := @eq A x y
@@ -22,11 +22,11 @@ namespace eq
   definition idpath [reducible] [constructor] (a : A) := refl a
 
   -- unbased path induction
-  definition rec' [reducible] [unfold 6] {P : Π (a b : A), (a = b) → Type}
+  definition rec_unbased [reducible] [unfold 6] {P : Π (a b : A), (a = b) → Type}
     (H : Π (a : A), P a a idp) {a b : A} (p : a = b) : P a b p :=
   eq.rec (H a) p
 
-  definition rec_on' [reducible] [unfold 5] {P : Π (a b : A), (a = b) → Type}
+  definition rec_on_unbased [reducible] [unfold 5] {P : Π (a b : A), (a = b) → Type}
     {a b : A} (p : a = b) (H : Π (a : A), P a a idp) : P a b p :=
   eq.rec (H a) p
 
@@ -67,11 +67,11 @@ namespace eq
     p₁ ⬝ (p₂ ⬝ p₃ ⬝ p₄) ⬝ p₅ = (p₁ ⬝ p₂) ⬝ p₃ ⬝ (p₄ ⬝ p₅) :=
   by induction p₅; induction p₄; induction p₃; reflexivity
 
-  -- The left inverse law.
+  -- The right inverse law.
   definition con.right_inv [unfold 4] (p : x = y) : p ⬝ p⁻¹ = idp :=
   by induction p; reflexivity
 
-  -- The right inverse law.
+  -- The left inverse law.
   definition con.left_inv [unfold 4] (p : x = y) : p⁻¹ ⬝ p = idp :=
   by induction p; reflexivity
 
@@ -112,6 +112,12 @@ namespace eq
     (H₁ : a = b) (H₂ : C (H₁⁻¹⁻¹)) : C H₁ :=
   eq.rec_on (inv_inv H₁) H₂
 
+  definition eq.rec_symm {A : Type} {a₀ : A} {P : Π⦃a₁⦄, a₁ = a₀ → Type}
+    (H : P idp) ⦃a₁ : A⦄ (p : a₁ = a₀) : P p :=
+  begin
+    cases p, exact H
+  end
+
   /- Theorems for moving things around in equations -/
 
   definition con_eq_of_eq_inv_con {p : x = z} {q : y = z} {r : y = x} :
@@ -234,6 +240,9 @@ namespace eq
   protected definition homotopy.refl [refl] [reducible] [unfold_full] (f : Πx, P x) : f ~ f :=
   λ x, idp
 
+  protected definition homotopy.rfl [reducible] [unfold_full] {f : Πx, P x} : f ~ f :=
+  homotopy.refl f
+
   protected definition homotopy.symm [symm] [reducible] [unfold_full] {f g : Πx, P x} (H : f ~ g)
     : g ~ f :=
   λ x, (H x)⁻¹
@@ -242,6 +251,9 @@ namespace eq
     (H1 : f ~ g) (H2 : g ~ h) : f ~ h :=
   λ x, H1 x ⬝ H2 x
 
+  infix ` ⬝hty `:75 := homotopy.trans
+  postfix `⁻¹ʰᵗʸ`:(max+1) := homotopy.symm
+
   definition hwhisker_left [unfold_full] (g : B → C) {f f' : A → B} (H : f ~ f') :
     g ∘ f ~ g ∘ f' :=
   λa, ap g (H a)
@@ -250,20 +262,33 @@ namespace eq
     g ∘ f ~ g' ∘ f :=
   λa, H (f a)
 
-  definition homotopy_of_eq {f g : Πx, P x} (H1 : f = g) : f ~ g :=
-  H1 ▸ homotopy.refl f
+  definition compose_id (f : A → B) : f ∘ id ~ f :=
+  by reflexivity
+
+  definition id_compose (f : A → B) : id ∘ f ~ f :=
+  by reflexivity
+
+  definition compose2 {A B C : Type} {g g' : B → C} {f f' : A → B}
+    (p : g ~ g') (q : f ~ f') : g ∘ f ~ g' ∘ f' :=
+  hwhisker_right f p ⬝hty hwhisker_left g' q
+
+  definition hassoc {A B C D : Type} (h : C → D) (g : B → C) (f : A → B) : (h ∘ g) ∘ f ~ h ∘ (g ∘ f) :=
+  λa, idp
+
+  definition homotopy_of_eq [unfold 5] {f g : Πx, P x} (H : f = g) : f ~ g :=
+  λa, ap (λh, h a) H
 
   definition apd10 [unfold 5] {f g : Πx, P x} (H : f = g) : f ~ g :=
-  λx, by induction H; reflexivity
+  λa, ap (λh, h a) H
 
   --the next theorem is useful if you want to write "apply (apd10' a)"
   definition apd10' [unfold 6] {f g : Πx, P x} (a : A) (H : f = g) : f a = g a :=
-  by induction H; reflexivity
+  apd10 H a
 
-  --apd10 is also ap evaluation
+  --apd10 is a special case of ap
   definition apd10_eq_ap_eval {f g : Πx, P x} (H : f = g) (a : A)
     : apd10 H a = ap (λs : Πx, P x, s a) H :=
-  by induction H; reflexivity
+  by reflexivity
 
   definition ap10 [reducible] [unfold 5] {f g : A → B} (H : f = g) : f ~ g := apd10 H
 
@@ -277,14 +302,6 @@ namespace eq
   definition ap011 [unfold 9] (f : A → B → C) (Ha : a = a') (Hb : b = b') : f a b = f a' b' :=
   by cases Ha; exact ap (f a) Hb
 
-  definition ap_eq_ap011_left (f : A → B → C) (Ha : a = a') (b : B) :
-    ap (λa, f a b) Ha = ap011 f Ha idp :=
-  by induction Ha; reflexivity
-
-  definition ap_eq_ap011_right (f : A → B → C) (a : A) (Hb : b = b') :
-    ap (f a) Hb = ap011 f idp Hb :=
-  by reflexivity
-
   /- More theorems for moving things around in equations -/
 
   definition tr_eq_of_eq_inv_tr {P : A → Type} {x y : A} {p : x = y} {u : P x} {v : P y} :
@@ -347,7 +364,7 @@ namespace eq
 
   -- Sometimes we don't have the actual function [compose].
   definition ap_compose' [unfold 8] (g : B → C) (f : A → B) {x y : A} (p : x = y) :
-    ap (λa, g (f a)) p = ap g (ap f p) :=
+    ap g (ap f p) = ap (λa, g (f a)) p :=
   by induction p; reflexivity
 
   -- The action of constant maps.
@@ -386,7 +403,6 @@ namespace eq
     (r ⬝ ap f q) ⬝ p y = (r ⬝ p x) ⬝ ap g q :=
   by induction q; reflexivity
 
-  -- TODO: try this using the simplifier, and compare proofs
   definition ap_con_con_eq_con_ap_con {f g : A → B} (p : f ~ g) {x y : A} (q : x = y)
       {z : B} (s : g y = z) :
     ap f q ⬝ (p y ⬝ s) = p x ⬝ (ap g q ⬝ s) :=
@@ -453,6 +469,22 @@ namespace eq
     ap h (ap10 p a) = ap10 (ap (λ f', h ∘ f') p) a:=
   by induction p; reflexivity
 
+  /- some lemma's about ap011 -/
+
+  definition ap_eq_ap011_left (f : A → B → C) (Ha : a = a') (b : B) :
+    ap (λa, f a b) Ha = ap011 f Ha idp :=
+  by induction Ha; reflexivity
+
+  definition ap_eq_ap011_right (f : A → B → C) (a : A) (Hb : b = b') :
+    ap (f a) Hb = ap011 f idp Hb :=
+  by reflexivity
+
+  definition ap_ap011 {A B C D : Type} (g : C → D) (f : A → B → C) {a a' : A} {b b' : B}
+    (p : a = a') (q : b = b') : ap g (ap011 f p q) = ap011 (λa b, g (f a b)) p q :=
+  begin
+    induction p, exact (ap_compose g (f a) q)⁻¹
+  end
+
 
   /- Transport and the groupoid structure of paths -/
 
@@ -527,6 +559,28 @@ namespace eq
     (p : a = a') (q : b = b') (z : P a b) : P a' b' :=
   transport (P a') q (p ▸ z)
 
+  definition transport11_con (P : A → B → Type) (p : a = a') (p' : a' = a'') (q : b = b')
+    (q' : b' = b'') (z : P a b) :
+    transport11 P (p ⬝ p') (q ⬝ q') z = transport11 P p' q' (transport11 P p q z) :=
+  begin induction p', induction q', reflexivity end
+
+  definition transport11_compose (P : A' → B' → Type) (f : A → A') (g : B → B')
+    (p : a = a') (q : b = b') (z : P (f a) (g b)) :
+    transport11 (λa b, P (f a) (g b)) p q z = transport11 P (ap f p) (ap g q) z :=
+  by induction p; induction q; reflexivity
+
+  definition transport11_ap (P : A' → B' → Type) (f : A → A') (g : B → B')
+    (p : a = a') (q : b = b') (z : P (f a) (g b)) :
+     transport11 P (ap f p) (ap g q) z =
+     transport11 (λ(a : A) (b : B), P (f a) (g b)) p q z :=
+  (transport11_compose P f g p q z)⁻¹
+
+  definition fn_transport11_eq_transport11_fn (P : A → B → Type)
+    (Q : A → B → Type) (p : a = a') (q : b = b')
+    (f : Πa b, P a b → Q a b) (z : P a b) :
+    f a' b' (transport11 P p q z) = transport11 Q p q (f a b z) :=
+  by induction p; induction q; reflexivity
+
   -- Transporting along higher-dimensional paths
   definition transport2 [unfold 7] (P : A → Type) {x y : A} {p q : x = y} (r : p = q) (z : P x) :
     p ▸ z = q ▸ z :=

hott/init/pathover.hlean

@@ -13,7 +13,7 @@ open equiv is_equiv function
 
 variables {A A' : Type} {B B' : A → Type} {B'' : A' → Type} {C : Π⦃a⦄, B a → Type}
           {a a₂ a₃ a₄ : A} {p p' : a = a₂} {p₂ : a₂ = a₃} {p₃ : a₃ = a₄} {p₁₃ : a = a₃}
-          {b b' : B a} {b₂ b₂' : B a₂} {b₃ : B a₃} {b₄ : B a₄}
+          {a' a₂' a₃' : A'} {b b' : B a} {b₂ b₂' : B a₂} {b₃ : B a₃} {b₄ : B a₄}
           {c : C b} {c₂ : C b₂}
 
 namespace eq
@@ -21,6 +21,7 @@ namespace eq
   idpatho : pathover B b (refl a) b
 
   notation b ` =[`:50 p:0 `] `:0 b₂:50 := pathover _ b p b₂
+  notation b ` =[`:50 p:0 `; `:0 B `] `:0 b₂:50 := pathover B b p b₂
 
   definition idpo [reducible] [constructor] : b =[refl a] b :=
   pathover.idpatho b
@@ -82,6 +83,9 @@ namespace eq
   definition change_path [unfold 9] (q : p = p') (r : b =[p] b₂) : b =[p'] b₂ :=
   q ▸ r
 
+  definition change_path_idp [unfold_full] (r : b =[p] b₂) : change_path idp r = r :=
+  by reflexivity
+
   -- infix ` ⬝ ` := concato
   infix ` ⬝o `:72 := concato
   infix ` ⬝op `:73 := concato_eq
@@ -103,30 +107,30 @@ namespace eq
 
   /- Some of the theorems analogous to theorems for = in init.path -/
 
-  definition cono_idpo (r : b =[p] b₂) : r ⬝o idpo =[con_idp p] r :=
-  pathover.rec_on r idpo
+  definition cono_idpo (r : b =[p] b₂) : r ⬝o idpo = r :=
+  by reflexivity
 
   definition idpo_cono (r : b =[p] b₂) : idpo ⬝o r =[idp_con p] r :=
-  pathover.rec_on r idpo
+  by induction r; constructor
 
   definition cono.assoc' (r : b =[p] b₂) (r₂ : b₂ =[p₂] b₃) (r₃ : b₃ =[p₃] b₄) :
     r ⬝o (r₂ ⬝o r₃) =[!con.assoc'] (r ⬝o r₂) ⬝o r₃ :=
-  pathover.rec_on r₃ (pathover.rec_on r₂ (pathover.rec_on r idpo))
+  by induction r₃; constructor
 
   definition cono.assoc (r : b =[p] b₂) (r₂ : b₂ =[p₂] b₃) (r₃ : b₃ =[p₃] b₄) :
     (r ⬝o r₂) ⬝o r₃ =[!con.assoc] r ⬝o (r₂ ⬝o r₃) :=
-  pathover.rec_on r₃ (pathover.rec_on r₂ (pathover.rec_on r idpo))
+  by induction r₃; constructor
 
   definition cono.right_inv (r : b =[p] b₂) : r ⬝o r⁻¹ᵒ =[!con.right_inv] idpo :=
-  pathover.rec_on r idpo
+  by induction r; constructor
 
   definition cono.left_inv (r : b =[p] b₂) : r⁻¹ᵒ ⬝o r =[!con.left_inv] idpo :=
-  pathover.rec_on r idpo
+  by induction r; constructor
 
-  definition eq_of_pathover {a' a₂' : A'} (q : a' =[p] a₂') : a' = a₂' :=
+  definition eq_of_pathover (q : a' =[p] a₂') : a' = a₂' :=
   by cases q;reflexivity
 
-  definition pathover_of_eq [unfold 5 8] (p : a = a₂) {a' a₂' : A'} (q : a' = a₂') : a' =[p] a₂' :=
+  definition pathover_of_eq [unfold 5 8] (p : a = a₂) (q : a' = a₂') : a' =[p] a₂' :=
   by cases p;cases q;constructor
 
   definition pathover_constant [constructor] (p : a = a₂) (a' a₂' : A') : a' =[p] a₂' ≃ a' = a₂' :=
@@ -155,10 +159,15 @@ namespace eq
            (to_right_inv !pathover_equiv_tr_eq)
            (to_left_inv !pathover_equiv_tr_eq)
 
-  definition eq_of_pathover_idp_pathover_of_eq {A X : Type} (x : X) {a a' : A} (p : a = a') :
-    eq_of_pathover_idp (pathover_of_eq (idpath x) p) = p :=
+  definition eq_of_pathover_idp_pathover_of_eq (a' : A') (p : a = a₂) :
+    eq_of_pathover_idp (pathover_of_eq (idpath a') p) = p :=
   by induction p; reflexivity
 
+  variable (B)
+  definition idpo_concato_eq (r : b = b') : eq_of_pathover_idp (@idpo A B a b ⬝op r) = r :=
+  by induction r; reflexivity
+  variable {B}
+
   -- definition pathover_idp (b : B a) (b' : B a) : b =[idpath a] b' ≃ b = b' :=
   -- pathover_equiv_tr_eq idp b b'
 
@@ -232,7 +241,7 @@ namespace eq
   end
 
   variable (C)
-  definition transporto (r : b =[p] b₂) (c : C b) : C b₂ :=
+  definition transporto [unfold 9] (r : b =[p] b₂) (c : C b) : C b₂ :=
   by induction r;exact c
   infix ` ▸o `:75 := transporto _
 
@@ -245,6 +254,9 @@ namespace eq
   definition apd [unfold 6] (f : Πa, B a) (p : a = a₂) : f a =[p] f a₂ :=
   by induction p; constructor
 
+  definition apd_idp [unfold_full] (f : Πa, B a) : apd f idp = @idpo A B a (f a) :=
+  by reflexivity
+
   definition apo [unfold 12] {f : A → A'} (g : Πa, B a → B'' (f a)) (q : b =[p] b₂) :
     g a b =[p] g a₂ b₂ :=
   by induction q; constructor
@@ -281,6 +293,11 @@ namespace eq
     (q : b =[p] b₂) : f b =[p] g b₂ :=
   by induction q; exact apo10 r b
 
+  definition apo011 {A : Type} {B C D : A → Type} {a a' : A} {p : a = a'} {b : B a} {b' : B a'}
+    {c : C a} {c' : C a'} (f : Π⦃a⦄, B a → C a → D a) (q : b =[p] b') (r : c =[p] c') :
+    f b c =[p] f b' c' :=
+  begin induction q, induction r using idp_rec_on, exact idpo end
+
   definition apdo011 {A : Type} {B : A → Type} {C : Π⦃a⦄, B a → Type}
     (f : Π⦃a⦄ (b : B a), C b) {a a' : A} (p : a = a') {b : B a} {b' : B a'} (q : b =[p] b')
       : f b =[apd011 C p q] f b' :=
@@ -298,6 +315,10 @@ namespace eq
     (q : f =[p] g) (r : b =[p] b₂) : f b = g b₂ :=
   eq_of_pathover (apo11 q r)
 
+  definition apd02 [unfold 8] (f : Πa, B a) {a a' : A} {p q : a = a'}
+    (r : p = q) : change_path r (apd f p) = apd f q :=
+  by induction r; reflexivity
+
   /- properties about these "ap"s, transporto and pathover_ap -/
   definition apd_con (f : Πa, B a) (p : a = a₂) (q : a₂ = a₃)
     : apd f (p ⬝ q) = apd f p ⬝o apd f q :=
@@ -306,6 +327,7 @@ namespace eq
   definition apd_inv (f : Πa, B a) (p : a = a₂) : apd f p⁻¹ = (apd f p)⁻¹ᵒ :=
   by cases p; reflexivity
 
+  /- probably more useful: apd_eq_ap -/
   definition apd_eq_pathover_of_eq_ap (f : A → A') (p : a = a₂) :
     apd f p = pathover_of_eq p (ap f p) :=
   eq.rec_on p idp
@@ -428,7 +450,7 @@ namespace eq
     (s : r = r') (s₂ : r₂ = r₂') : r ⬝o r₂ = r' ⬝o r₂' :=
   by induction s; induction s₂; reflexivity
 
-  infixl ` ◾o `:75 := concato2
+  infixl ` ◾o `:79 := concato2
   postfix [parsing_only] `⁻²ᵒ`:(max+10) := inverseo2 --this notation is abusive, should we use it?
 
   -- find a better name for this
@@ -445,5 +467,32 @@ namespace eq
       apd0111 f (ap k p) (pathover_ap B k (apo l q)) (pathover_tro _ (m c)) :=
   by induction q; reflexivity
 
+  /- some properties about eq_of_pathover -/
+  definition apd_eq_ap (f : A → A') (p : a = a₂) : eq_of_pathover (apd f p) = ap f p :=
+  begin induction p, reflexivity end
+
+  definition eq_of_pathover_idp_constant (p : a' =[idpath a] a₂') :
+    eq_of_pathover_idp p = eq_of_pathover p :=
+  begin induction p using idp_rec_on, reflexivity end
+
+  definition eq_of_pathover_change_path (r : p = p') (q : a' =[p] a₂') :
+    eq_of_pathover (change_path r q) = eq_of_pathover q :=
+  begin induction r, reflexivity end
+
+  definition eq_of_pathover_cono (q : a' =[p] a₂') (q₂ : a₂' =[p₂] a₃') :
+    eq_of_pathover (q ⬝o q₂) = eq_of_pathover q ⬝ eq_of_pathover q₂ :=
+  begin induction q₂, reflexivity end
+
+  definition eq_of_pathover_invo (q : a' =[p] a₂') :
+    eq_of_pathover q⁻¹ᵒ = (eq_of_pathover q)⁻¹ :=
+  begin induction q, reflexivity end
+
+  definition eq_of_pathover_concato_eq (q : a' =[p] a₂') (q₂ : a₂' = a₃') :
+    eq_of_pathover (q ⬝op q₂) = eq_of_pathover q ⬝ q₂ :=
+  begin induction q₂, reflexivity end
+
+  definition eq_of_pathover_eq_concato (q : a' = a₂') (q₂ : a₂' =[p₂] a₃') :
+    eq_of_pathover (q ⬝po q₂) = q ⬝ eq_of_pathover q₂ :=
+  begin induction q, induction q₂, reflexivity end
 
 end eq

hott/init/pointed.hlean

@@ -84,47 +84,77 @@ namespace pointed
 end pointed
 
 /- pointed maps -/
-structure ppi (A : Type*) (P : A → Type*) :=
+structure ppi {A : Type*} (P : A → Type) (x₀ : P pt) :=
   (to_fun : Π a : A, P a)
-  (resp_pt : to_fun (Point A) = Point (P (Point A)))
+  (resp_pt : to_fun (Point A) = x₀)
+
+definition pppi' [reducible] {A : Type*} (P : A → Type*) : Type :=
+ppi P pt
+
+definition ppi_const [constructor] {A : Type*} (P : A → Type*) : pppi' P :=
+ppi.mk (λa, pt) idp
+
+definition pppi [constructor] [reducible] {A : Type*} (P : A → Type*) : Type* :=
+pointed.MK (pppi' P) (ppi_const P)
+
+-- do we want to make this already pointed?
+definition pmap [reducible] (A B : Type*) : Type := @pppi A (λa, B)
+
+attribute ppi.to_fun [coercion]
+
+infix ` →* `:28 := pmap
+notation `Π*` binders `, ` r:(scoped P, pppi P) := r
 
--- definition pmap (A B : Type*) := @ppi A (λa, B)
-structure pmap (A B : Type*) :=
-  (to_fun : A → B)
-  (resp_pt : to_fun (Point A) = Point B)
 
 namespace pointed
-  abbreviation respect_pt [unfold 3] := @pmap.resp_pt
-  notation `map₊` := pmap
-  infix ` →* `:30 := pmap
-  attribute pmap.to_fun ppi.to_fun [coercion]
-  notation `Π*` binders `, ` r:(scoped P, ppi _ P) := r
-  -- definition pmap.mk [constructor] {A B : Type*} (f : A → B) (p : f pt = pt) : A →* B :=
+
+
+  definition pppi.mk [constructor] [reducible] {A : Type*} {P : A → Type*} (f : Πa, P a)
+    (p : f pt = pt) : pppi P :=
+  ppi.mk f p
+
+  definition pppi.to_fun [unfold 3] [coercion] [reducible] {A : Type*} {P : A → Type*} (f : pppi' P)
+    (a : A) : P a :=
+  ppi.to_fun f a
+
+	definition pmap.mk [constructor] [reducible] {A B : Type*} (f : A → B)
+    (p : f (Point A) = Point B) : A →* B :=
+	pppi.mk f p
+
+  abbreviation pmap.to_fun [unfold 3] [reducible] [coercion] {A B : Type*} (f : A →* B) : A → B :=
+  pppi.to_fun f
+
+  definition respect_pt [unfold 4] [reducible] {A : Type*} {P : A → Type} {p₀ : P pt}
+    (f : ppi P p₀) : f pt = p₀ :=
+  ppi.resp_pt f
+
+  -- notation `Π*` binders `, ` r:(scoped P, ppi _ P) := r
+  -- definition pmxap.mk [constructor] {A B : Type*} (f : A → B) (p : f pt = pt) : A →* B :=
   -- ppi.mk f p
   -- definition pmap.to_fun [coercion] [unfold 3] {A B : Type*} (f : A →* B) : A → B := f
 
 end pointed open pointed
 
 /- pointed homotopies -/
-structure phomotopy {A B : Type*} (f g : A →* B) :=
-  (homotopy : f ~ g)
-  (homotopy_pt : homotopy pt ⬝ respect_pt g = respect_pt f)
+definition phomotopy {A : Type*} {P : A → Type} {p₀ : P pt} (f g : ppi P p₀) : Type :=
+ppi (λa, f a = g a) (respect_pt f ⬝ (respect_pt g)⁻¹)
+
+-- structure phomotopy {A B : Type*} (f g : A →* B) : Type :=
+--   (homotopy : f ~ g)
+--   (homotopy_pt : homotopy pt ⬝ respect_pt g = respect_pt f)
 
 namespace pointed
-  variables {A B : Type*} {f g : A →* B}
+  variables {A : Type*} {P : A → Type} {p₀ : P pt} {f g : ppi P p₀}
 
   infix ` ~* `:50 := phomotopy
-  abbreviation to_homotopy_pt [unfold 5] := @phomotopy.homotopy_pt
-  abbreviation to_homotopy [coercion] [unfold 5] (p : f ~* g) : Πa, f a = g a :=
-  phomotopy.homotopy p
+  definition phomotopy.mk [reducible] [constructor] (h : f ~ g)
+    (p : h pt ⬝ respect_pt g = respect_pt f) : f ~* g :=
+  ppi.mk h (eq_con_inv_of_con_eq p)
 
-  /- pointed equivalences -/
-  structure pequiv (A B : Type*) extends equiv A B, pmap A B
+  definition to_homotopy [coercion] [unfold 5] [reducible] (p : f ~* g) : Πa, f a = g a := p
+  definition to_homotopy_pt [unfold 5] [reducible] (p : f ~* g) :
+    p pt ⬝ respect_pt g = respect_pt f :=
+  con_eq_of_eq_con_inv (respect_pt p)
 
-  attribute pequiv._trans_of_to_pmap pequiv._trans_of_to_equiv pequiv.to_pmap pequiv.to_equiv
-            [unfold 3]
-  attribute pequiv.to_is_equiv [instance]
-  attribute pequiv.to_pmap [coercion]
-  infix ` ≃* `:25 := pequiv
 
 end pointed

hott/init/reserved_notation.hlean

@@ -37,6 +37,14 @@ definition lt               {A : Type} [s : has_lt A]   : A → A → Type := ha
 
 definition ge [reducible] {A : Type} [s : has_le A] (a b : A) : Type := le b a
 definition gt [reducible] {A : Type} [s : has_lt A] (a b : A) : Type := lt b a
+
+/-
+  bit0 and bit1 are two auxiliary definition used when parsing numerals such as 13, 0, 26.
+  The parser will generate the terms (bit1 (bit0 (bit1 one))), zero, and
+  (bit0 (bit1 (bit0 (bit1 one)))). This works in any type with an addition, a zero and a one.
+  More specifically, there must be type class instances for the classes for has_add, has_zero and
+  has_one
+-/
 definition bit0 [reducible] {A : Type} [s  : has_add A] (a  : A)                 : A := add a a
 definition bit1 [reducible] {A : Type} [s₁ : has_one A] [s₂ : has_add A] (a : A) : A :=
 add (bit0 a) one

hott/init/trunc.hlean

@@ -145,6 +145,8 @@ namespace is_trunc
   definition center (A : Type) [H : is_contr A] : A :=
   contr_internal.center (is_trunc.to_internal -2 A)
 
+  definition center' {A : Type} (H : is_contr A) : A := center A
+
   definition center_eq [H : is_contr A] (a : A) : !center = a :=
   contr_internal.center_eq (is_trunc.to_internal -2 A) a
 
@@ -171,7 +173,7 @@ namespace is_trunc
   --in the proof the type of H is given explicitly to make it available for class inference
 
   theorem is_trunc_of_le.{l} (A : Type.{l}) {n m : ℕ₋₂} (Hnm : n ≤ m)
-    [Hn : is_trunc n A] : is_trunc m A :=
+    (Hn : is_trunc n A) : is_trunc m A :=
   begin
     induction Hnm with m Hnm IH,
     { exact Hn},
@@ -189,23 +191,21 @@ namespace is_trunc
   end
 
   -- these must be definitions, because we need them to compute sometimes
-  definition is_trunc_of_is_contr (A : Type) (n : ℕ₋₂) [H : is_contr A] : is_trunc n A :=
+  definition is_trunc_of_is_contr (A : Type) (n : ℕ₋₂) (H : is_contr A) : is_trunc n A :=
   trunc_index.rec_on n H (λn H, _)
 
-  definition is_trunc_succ_of_is_prop (A : Type) (n : ℕ₋₂) [H : is_prop A]
-      : is_trunc (n.+1) A :=
-  is_trunc_of_le A (show -1 ≤ n.+1, from succ_le_succ (minus_two_le n))
+  definition is_trunc_succ_of_is_prop (A : Type) (n : ℕ₋₂) (H : is_prop A) : is_trunc (n.+1) A :=
+  is_trunc_of_le A (show -1 ≤ n.+1, from succ_le_succ (minus_two_le n)) _
 
-  definition is_trunc_succ_succ_of_is_set (A : Type) (n : ℕ₋₂) [H : is_set A]
-      : is_trunc (n.+2) A :=
-  is_trunc_of_le A (show 0 ≤ n.+2, from succ_le_succ (succ_le_succ (minus_two_le n)))
+  definition is_trunc_succ_succ_of_is_set (A : Type) (n : ℕ₋₂) (H : is_set A) : is_trunc (n.+2) A :=
+  is_trunc_of_le A (show 0 ≤ n.+2, from succ_le_succ (succ_le_succ (minus_two_le n))) _
 
-  /- props -/
+  /- propositions -/
 
   definition is_prop.elim [H : is_prop A] (x y : A) : x = y :=
   !center
 
-  definition is_contr_of_inhabited_prop {A : Type} [H : is_prop A] (x : A) : is_contr A :=
+  definition is_contr_of_inhabited_prop {A : Type} (x : A) (H : is_prop A) : is_contr A :=
   is_contr.mk x (λy, !is_prop.elim)
 
   theorem is_prop_of_imp_is_contr {A : Type} (H : A → is_contr A) : is_prop A :=
@@ -255,68 +255,73 @@ namespace is_trunc
   local attribute is_contr_unit is_prop_empty [instance]
 
   definition is_trunc_unit [instance] (n : ℕ₋₂) : is_trunc n unit :=
-  !is_trunc_of_is_contr
+  is_trunc_of_is_contr _ _ _
 
   definition is_trunc_empty [instance] (n : ℕ₋₂) : is_trunc (n.+1) empty :=
-  !is_trunc_succ_of_is_prop
+  is_trunc_succ_of_is_prop _ _ _
 
   /- interaction with equivalences -/
 
   section
   open is_equiv equiv
 
-  definition is_contr_is_equiv_closed (f : A → B) [Hf : is_equiv f] [HA: is_contr A]
+  definition is_contr_is_equiv_closed (f : A → B) (Hf : is_equiv f) (HA: is_contr A)
     : (is_contr B) :=
   is_contr.mk (f (center A)) (λp, eq_of_eq_inv !center_eq)
 
-  definition is_contr_equiv_closed (H : A ≃ B) [HA: is_contr A] : is_contr B :=
-  is_contr_is_equiv_closed (to_fun H)
+  definition is_contr_equiv_closed (H : A ≃ B) (HA : is_contr A) : is_contr B :=
+  is_contr_is_equiv_closed (to_fun H) _ _
 
-  definition equiv_of_is_contr_of_is_contr [HA : is_contr A] [HB : is_contr B] : A ≃ B :=
+  definition is_contr_equiv_closed_rev (H : A ≃ B) (HB : is_contr B) : is_contr A :=
+  is_contr_equiv_closed H⁻¹ᵉ HB
+
+  definition equiv_of_is_contr_of_is_contr (HA : is_contr A) (HB : is_contr B) : A ≃ B :=
   equiv.mk
     (λa, center B)
     (is_equiv.adjointify (λa, center B) (λb, center A) center_eq center_eq)
 
-  theorem is_trunc_is_equiv_closed (n : ℕ₋₂) (f : A → B) [H : is_equiv f]
-    [HA : is_trunc n A] : is_trunc n B :=
+  theorem is_trunc_is_equiv_closed (n : ℕ₋₂) (f : A → B) (H : is_equiv f)
+    (HA : is_trunc n A) : is_trunc n B :=
   begin
     revert A HA B f H, induction n with n IH: intros,
-    { exact is_contr_is_equiv_closed f},
+    { exact is_contr_is_equiv_closed f _ _ },
     { apply is_trunc_succ_intro, intro x y,
       exact IH (f⁻¹ x = f⁻¹ y) _ (x = y) (ap f⁻¹)⁻¹ !is_equiv_inv }
   end
 
-  definition is_trunc_is_equiv_closed_rev (n : ℕ₋₂) (f : A → B) [H : is_equiv f]
-    [HA : is_trunc n B] : is_trunc n A :=
-  is_trunc_is_equiv_closed n f⁻¹
+  definition is_trunc_is_equiv_closed_rev (n : ℕ₋₂) (f : A → B) (H : is_equiv f)
+    (HA : is_trunc n B) : is_trunc n A :=
+  is_trunc_is_equiv_closed n f⁻¹ᶠ _ _
 
-  definition is_trunc_equiv_closed (n : ℕ₋₂) (f : A ≃ B) [HA : is_trunc n A]
-    : is_trunc n B :=
-  is_trunc_is_equiv_closed n (to_fun f)
+  definition is_trunc_equiv_closed (n : ℕ₋₂) (f : A ≃ B) (HA : is_trunc n A) : is_trunc n B :=
+  is_trunc_is_equiv_closed n (to_fun f) _ _
 
-  definition is_trunc_equiv_closed_rev (n : ℕ₋₂) (f : A ≃ B) [HA : is_trunc n B]
-    : is_trunc n A :=
-  is_trunc_is_equiv_closed n (to_inv f)
+  definition is_trunc_equiv_closed_rev (n : ℕ₋₂) (f : A ≃ B) (HA : is_trunc n B) : is_trunc n A :=
+  is_trunc_is_equiv_closed n (to_inv f) _ _
 
-  definition is_equiv_of_is_prop [constructor] [HA : is_prop A] [HB : is_prop B]
-    (f : A → B) (g : B → A) : is_equiv f :=
+  definition is_equiv_of_is_prop [constructor] (f : A → B) (g : B → A)
+    (HA : is_prop A) (HB : is_prop B) : is_equiv f :=
   is_equiv.mk f g (λb, !is_prop.elim) (λa, !is_prop.elim) (λa, !is_set.elim)
 
-  definition is_equiv_of_is_contr [constructor] [HA : is_contr A] [HB : is_contr B]
-    (f : A → B) : is_equiv f :=
+  definition is_equiv_of_is_contr [constructor] (f : A → B)
+    (HA : is_contr A) (HB : is_contr B) : is_equiv f :=
   is_equiv.mk f (λx, !center) (λb, !is_prop.elim) (λa, !is_prop.elim) (λa, !is_set.elim)
 
-  definition equiv_of_is_prop [constructor] [HA : is_prop A] [HB : is_prop B]
-    (f : A → B) (g : B → A) : A ≃ B :=
-  equiv.mk f (is_equiv_of_is_prop f g)
+  definition equiv_of_is_contr [constructor] (HA : is_contr A) (HB : is_contr B) : A ≃ B :=
+  equiv.mk (λa, center B) (is_equiv_of_is_contr _ _ _)
 
-  definition equiv_of_iff_of_is_prop [unfold 5] [HA : is_prop A] [HB : is_prop B] (H : A ↔ B) : A ≃ B :=
-  equiv_of_is_prop (iff.elim_left H) (iff.elim_right H)
+  definition equiv_of_is_prop [constructor] (f : A → B) (g : B → A)
+    (HA : is_prop A) (HB : is_prop B) : A ≃ B :=
+  equiv.mk f (is_equiv_of_is_prop f g _ _)
+
+  definition equiv_of_iff_of_is_prop [unfold 5] (H : A ↔ B) (HA : is_prop A) (HB : is_prop B) :
+    A ≃ B :=
+  equiv_of_is_prop (iff.elim_left H) (iff.elim_right H) _ _
 
   /- truncatedness of lift -/
   definition is_trunc_lift [instance] [priority 1450] (A : Type) (n : ℕ₋₂)
     [H : is_trunc n A] : is_trunc n (lift A) :=
-  is_trunc_equiv_closed _ !equiv_lift
+  is_trunc_equiv_closed _ !equiv_lift _
 
   end
 
@@ -325,11 +330,8 @@ namespace is_trunc
   open equiv
   /- A contractible type is equivalent to unit. -/
   variable (A)
-  definition equiv_unit_of_is_contr [H : is_contr A] : A ≃ unit :=
-  equiv.MK (λ (x : A), ⋆)
-           (λ (u : unit), center A)
-           (λ (u : unit), unit.rec_on u idp)
-           (λ (x : A), center_eq x)
+  definition equiv_unit_of_is_contr [constructor] (H : is_contr A) : A ≃ unit :=
+  equiv_of_is_contr _ _
 
   /- interaction with pathovers -/
   variable {A}
@@ -337,19 +339,21 @@ namespace is_trunc
             {a a₂ : A} (p : a = a₂)
             (c : C a) (c₂ : C a₂)
 
+  definition is_trunc_pathover [instance]
+    (n : ℕ₋₂) [H : is_trunc (n.+1) (C a)] : is_trunc n (c =[p] c₂) :=
+  is_trunc_equiv_closed_rev n !pathover_equiv_eq_tr _
+
   definition is_prop.elimo [H : is_prop (C a)] : c =[p] c₂ :=
   pathover_of_eq_tr !is_prop.elim
 
-  definition is_trunc_pathover [instance]
-    (n : ℕ₋₂) [H : is_trunc (n.+1) (C a)] : is_trunc n (c =[p] c₂) :=
-  is_trunc_equiv_closed_rev n !pathover_equiv_eq_tr
+  definition is_prop_elimo_self {A : Type} (B : A → Type) {a : A} (b : B a) {H : is_prop (B a)} :
+    @is_prop.elimo A B a a idp b b H = idpo :=
+  !is_prop.elim
 
   variables {p c c₂}
   theorem is_set.elimo (q q' : c =[p] c₂) [H : is_set (C a)] : q = q' :=
   !is_prop.elim
 
-  -- TODO: port "Truncated morphisms"
-
   /- truncated universe -/
 
 end is_trunc

hott/init/ua.hlean

@@ -71,7 +71,7 @@ namespace equiv
   rec_on_ua' f (λq, eq.rec_on q H)
 
   definition ua_refl (A : Type) : ua erfl = idpath A :=
-  eq_of_fn_eq_fn !eq_equiv_equiv (right_inv !eq_equiv_equiv erfl)
+  inj !eq_equiv_equiv (right_inv !eq_equiv_equiv erfl)
 
   definition ua_symm {A B : Type} (f : A ≃ B) : ua f⁻¹ᵉ = (ua f)⁻¹ :=
   begin

hott/prop_trunc.hlean

@@ -35,19 +35,21 @@ namespace is_trunc
       induction (P a b), apply idp},
   end
 
-  definition is_prop_is_trunc [instance] (n : trunc_index) :
+  definition is_prop_is_trunc (n : trunc_index) :
     Π (A : Type), is_prop (is_trunc n A) :=
   begin
     induction n,
     { intro A,
-      apply is_trunc_is_equiv_closed,
-      { apply equiv.to_is_equiv, apply is_contr.sigma_char},
+      apply is_trunc_equiv_closed _ !is_contr.sigma_char,
       apply is_prop.mk, intros,
       fapply sigma_eq, apply x.2,
       apply is_prop.elimo },
-    { intro A,
-      apply is_trunc_is_equiv_closed,
-      apply equiv.to_is_equiv,
-      apply is_trunc.pi_char},
+    { intro A, exact is_trunc_equiv_closed _ !is_trunc.pi_char _ },
   end
+
+  local attribute is_prop_is_trunc [instance]
+  definition is_trunc_succ_is_trunc [instance] (n m : ℕ₋₂) (A : Type) :
+    is_trunc (n.+1) (is_trunc m A) :=
+  is_trunc_succ_of_is_prop _ _ _
+
 end is_trunc

hott/types/W.hlean

@@ -124,8 +124,9 @@ namespace Wtype
   fapply is_trunc_equiv_closed,
   { apply equiv_path_W},
   { apply is_trunc_sigma,
-    intro p, cases p, esimp, apply is_trunc_equiv_closed_rev,
-      apply pathover_idp}
+    intro p, cases p,
+    apply is_trunc_equiv_closed_rev n !pathover_idp,
+    apply is_trunc_pi_eq, intro b, apply IH }
   end
 
 end Wtype

hott/types/eq.hlean

@@ -21,73 +21,74 @@ namespace eq
 
   /- some lemmas about whiskering or other higher paths -/
 
-  theorem whisker_left_con_right (p : a₁ = a₂) {q q' q'' : a₂ = a₃} (r : q = q') (s : q' = q'')
+  definition whisker_left_con_right (p : a₁ = a₂) {q q' q'' : a₂ = a₃} (r : q = q') (s : q' = q'')
     : whisker_left p (r ⬝ s) = whisker_left p r ⬝ whisker_left p s :=
   begin
     induction p, induction r, induction s, reflexivity
   end
 
-  theorem whisker_right_con_right (q : a₂ = a₃) (r : p = p') (s : p' = p'')
+  definition whisker_right_con_right (q : a₂ = a₃) (r : p = p') (s : p' = p'')
     : whisker_right q (r ⬝ s) = whisker_right q r ⬝ whisker_right q s :=
   begin
     induction q, induction r, induction s, reflexivity
   end
 
-  theorem whisker_left_con_left (p : a₁ = a₂) (p' : a₂ = a₃) {q q' : a₃ = a₄} (r : q = q')
+  definition whisker_left_con_left (p : a₁ = a₂) (p' : a₂ = a₃) {q q' : a₃ = a₄} (r : q = q')
     : whisker_left (p ⬝ p') r = !con.assoc ⬝ whisker_left p (whisker_left p' r) ⬝ !con.assoc' :=
   begin
     induction p', induction p, induction r, induction q, reflexivity
   end
 
-  theorem whisker_right_con_left {p p' : a₁ = a₂} (q : a₂ = a₃) (q' : a₃ = a₄) (r : p = p')
+  definition whisker_right_con_left {p p' : a₁ = a₂} (q : a₂ = a₃) (q' : a₃ = a₄) (r : p = p')
     : whisker_right (q ⬝ q') r = !con.assoc' ⬝ whisker_right q' (whisker_right q r) ⬝ !con.assoc :=
   begin
     induction q', induction q, induction r, induction p, reflexivity
   end
 
-  theorem whisker_left_inv_left (p : a₂ = a₁) {q q' : a₂ = a₃} (r : q = q')
+  definition whisker_left_inv_left (p : a₂ = a₁) {q q' : a₂ = a₃} (r : q = q')
     : !con_inv_cancel_left⁻¹ ⬝ whisker_left p (whisker_left p⁻¹ r) ⬝ !con_inv_cancel_left = r :=
   begin
     induction p, induction r, induction q, reflexivity
   end
 
-  theorem whisker_left_inv (p : a₁ = a₂) {q q' : a₂ = a₃} (r : q = q')
+  definition whisker_left_inv (p : a₁ = a₂) {q q' : a₂ = a₃} (r : q = q')
     : whisker_left p r⁻¹ = (whisker_left p r)⁻¹ :=
   by induction r; reflexivity
 
-  theorem whisker_right_inv {p p' : a₁ = a₂} (q : a₂ = a₃) (r : p = p')
+  definition whisker_right_inv {p p' : a₁ = a₂} (q : a₂ = a₃) (r : p = p')
     : whisker_right q r⁻¹ = (whisker_right q r)⁻¹ :=
   by induction r; reflexivity
 
-  theorem ap_eq_apd10 {B : A → Type} {f g : Πa, B a} (p : f = g) (a : A) :
+  definition ap_eq_apd10 [unfold 5] {B : A → Type} {f g : Πa, B a} (p : f = g) (a : A) :
     ap (λh, h a) p = apd10 p a :=
   by induction p; reflexivity
 
-  theorem inverse2_right_inv (r : p = p') : r ◾ inverse2 r ⬝ con.right_inv p' = con.right_inv p :=
+  definition inverse2_right_inv (r : p = p') : r ◾ inverse2 r ⬝ con.right_inv p' = con.right_inv p :=
   by induction r;induction p;reflexivity
 
-  theorem inverse2_left_inv (r : p = p') : inverse2 r ◾ r ⬝ con.left_inv p' = con.left_inv p :=
+  definition inverse2_left_inv (r : p = p') : inverse2 r ◾ r ⬝ con.left_inv p' = con.left_inv p :=
   by induction r;induction p;reflexivity
 
-  theorem ap_con_right_inv (f : A → B) (p : a₁ = a₂)
+  definition ap_con_right_inv (f : A → B) (p : a₁ = a₂)
     : ap_con f p p⁻¹ ⬝ whisker_left _ (ap_inv f p) ⬝ con.right_inv (ap f p)
       = ap (ap f) (con.right_inv p) :=
   by induction p;reflexivity
 
-  theorem ap_con_left_inv (f : A → B) (p : a₁ = a₂)
+  definition ap_con_left_inv (f : A → B) (p : a₁ = a₂)
     : ap_con f p⁻¹ p ⬝ whisker_right _ (ap_inv f p) ⬝ con.left_inv (ap f p)
       = ap (ap f) (con.left_inv p) :=
   by induction p;reflexivity
 
-  theorem idp_con_whisker_left {q q' : a₂ = a₃} (r : q = q') :
+  definition idp_con_whisker_left {q q' : a₂ = a₃} (r : q = q') :
   !idp_con⁻¹ ⬝ whisker_left idp r = r ⬝ !idp_con⁻¹ :=
   by induction r;induction q;reflexivity
 
-  theorem whisker_left_idp_con {q q' : a₂ = a₃} (r : q = q') :
+  -- this should maybe replace whisker_left_idp and whisker_left_idp_con
+  definition whisker_left_idp_con {q q' : a₂ = a₃} (r : q = q') :
   whisker_left idp r ⬝ !idp_con = !idp_con ⬝ r :=
   by induction r;induction q;reflexivity
 
-  theorem idp_con_idp {p : a = a} (q : p = idp) : idp_con p ⬝ q = ap (λp, idp ⬝ p) q :=
+  definition idp_con_idp {p : a = a} (q : p = idp) : idp_con p ⬝ q = ap (λp, idp ⬝ p) q :=
   by cases q;reflexivity
 
   definition ap_is_constant [unfold 8] {A B : Type} {f : A → B} {b : B} (p : Πx, f x = b)
@@ -105,13 +106,13 @@ namespace eq
     : (r₁ ◾ r₂)⁻¹ = r₁⁻¹ ◾ r₂⁻¹ :=
   by induction r₁;induction r₂;reflexivity
 
-  theorem eq_con_inv_of_con_eq_whisker_left {A : Type} {a a₂ a₃ : A}
+  definition eq_con_inv_of_con_eq_whisker_left {A : Type} {a a₂ a₃ : A}
     {p : a = a₂} {q q' : a₂ = a₃} {r : a = a₃} (s' : q = q') (s : p ⬝ q' = r) :
     eq_con_inv_of_con_eq (whisker_left p s' ⬝ s)
       = eq_con_inv_of_con_eq s ⬝ whisker_left r (inverse2 s')⁻¹ :=
   by induction s';induction q;induction s;reflexivity
 
-  theorem right_inv_eq_idp {A : Type} {a : A} {p : a = a} (r : p = idpath a) :
+  definition right_inv_eq_idp {A : Type} {a : A} {p : a = a} (r : p = idpath a) :
     con.right_inv p = r ◾ inverse2 r :=
   by cases r;reflexivity
 
@@ -126,19 +127,19 @@ namespace eq
 
   definition eq_transport_l (p : a₁ = a₂) (q : a₁ = a₃)
     : transport (λx, x = a₃) p q = p⁻¹ ⬝ q :=
-  by induction p; induction q; reflexivity
+  by induction p; exact !idp_con⁻¹
 
   definition eq_transport_r (p : a₂ = a₃) (q : a₁ = a₂)
     : transport (λx, a₁ = x) p q = q ⬝ p :=
-  by induction p; induction q; reflexivity
+  by induction p; reflexivity
 
   definition eq_transport_lr (p : a₁ = a₂) (q : a₁ = a₁)
     : transport (λx, x = x) p q = p⁻¹ ⬝ q ⬝ p :=
-  by induction p; rewrite [▸*,idp_con]
+  by induction p; exact !idp_con⁻¹
 
-  definition eq_transport_Fl (p : a₁ = a₂) (q : f a₁ = b)
+  definition eq_transport_Fl [unfold 7] (p : a₁ = a₂) (q : f a₁ = b)
     : transport (λx, f x = b) p q = (ap f p)⁻¹ ⬝ q :=
-  by induction p; induction q; reflexivity
+  by induction p; exact !idp_con⁻¹
 
   definition eq_transport_Fr (p : a₁ = a₂) (q : b = f a₁)
     : transport (λx, b = f x) p q = q ⬝ (ap f p) :=
@@ -146,27 +147,26 @@ namespace eq
 
   definition eq_transport_FlFr (p : a₁ = a₂) (q : f a₁ = g a₁)
     : transport (λx, f x = g x) p q = (ap f p)⁻¹ ⬝ q ⬝ (ap g p) :=
-  by induction p; rewrite [▸*,idp_con]
+  by induction p; exact !idp_con⁻¹
 
   definition eq_transport_FlFr_D {B : A → Type} {f g : Πa, B a}
     (p : a₁ = a₂) (q : f a₁ = g a₁)
       : transport (λx, f x = g x) p q = (apdt f p)⁻¹ ⬝ ap (transport B p) q ⬝ (apdt g p) :=
-  by induction p; rewrite [▸*,idp_con,ap_id]
+  by induction p; exact !ap_id⁻¹ ⬝ !idp_con⁻¹
 
   definition eq_transport_FFlr (p : a₁ = a₂) (q : h (f a₁) = a₁)
     : transport (λx, h (f x) = x) p q = (ap h (ap f p))⁻¹ ⬝ q ⬝ p :=
-  by induction p; rewrite [▸*,idp_con]
+  by induction p; exact !idp_con⁻¹
 
   definition eq_transport_lFFr (p : a₁ = a₂) (q : a₁ = h (f a₁))
     : transport (λx, x = h (f x)) p q = p⁻¹ ⬝ q ⬝ (ap h (ap f p)) :=
-  by induction p; rewrite [▸*,idp_con]
+  by induction p; exact !idp_con⁻¹
 
   /- Pathovers -/
 
   -- In the comment we give the fibration of the pathover
 
   -- we should probably try to do everything just with pathover_eq (defined in cubical.square),
-  -- the following definitions may be removed in future.
 
   definition eq_pathover_l (p : a₁ = a₂) (q : a₁ = a₃) : q =[p] p⁻¹ ⬝ q := /-(λx, x = a₃)-/
   by induction p; induction q; exact idpo
@@ -462,31 +462,36 @@ namespace eq
 
   section
     parameters {A : Type} (a₀ : A) (code : A → Type) (H : is_contr (Σa, code a))
-      (p : (center (Σa, code a)).1 = a₀)
-    include p
+      (c₀ : code a₀)
+    include H c₀
     protected definition encode {a : A} (q : a₀ = a) : code a :=
-    (p ⬝ q) ▸ (center (Σa, code a)).2
+    transport code q c₀
 
     protected definition decode' {a : A} (c : code a) : a₀ = a :=
-    (is_prop.elim ⟨a₀, encode idp⟩ ⟨a, c⟩)..1
+    have ⟨a₀, c₀⟩ = ⟨a, c⟩ :> Σa, code a, from !is_prop.elim,
+    this..1
 
     protected definition decode {a : A} (c : code a) : a₀ = a :=
-    (decode' (encode idp))⁻¹ ⬝ decode' c
+    (decode' c₀)⁻¹ ⬝ decode' c
 
+    open sigma.ops
     definition total_space_method (a : A) : (a₀ = a) ≃ code a :=
     begin
       fapply equiv.MK,
       { exact encode },
       { exact decode },
-      { intro c,
-        unfold [encode, decode, decode'],
-        induction p, esimp, rewrite [is_prop_elim_self,▸*,+idp_con],
-        apply tr_eq_of_pathover,
-        eapply @sigma.rec_on _ _ (λx, x.2 =[(is_prop.elim ⟨x.1, x.2⟩ ⟨a, c⟩)..1] c)
-          (center (sigma code)),
-        intro a c, apply eq_pr2},
+      { intro c, unfold [encode, decode, decode'],
+        rewrite [is_prop_elim_self, ▸*, idp_con],
+        apply tr_eq_of_pathover, apply eq_pr2 },
       { intro q, induction q, esimp, apply con.left_inv, },
     end
+
+  end
+
+  definition total_space_method2_refl {A : Type} (a₀ : A) (code : A → Type) (H : is_contr (Σa, code a))
+    (c₀ : code a₀) : total_space_method a₀ code H c₀ a₀ idp = c₀ :=
+  begin
+    reflexivity
   end
 
   definition encode_decode_method {A : Type} (a₀ a : A) (code : A → Type) (c₀ : code a₀)
@@ -499,7 +504,7 @@ namespace eq
       { intro p, fapply sigma_eq,
           apply decode, exact p.2,
         apply encode_decode}},
-    { reflexivity}
+    { exact c₀ }
   end
 
 end eq

hott/types/equiv.hlean

@@ -15,19 +15,6 @@ namespace is_equiv
   variables {A B : Type} (f : A → B) [H : is_equiv f]
   include H
   /- is_equiv f is a mere proposition -/
-  definition is_contr_fiber_of_is_equiv [instance] (b : B) : is_contr (fiber f b) :=
-  is_contr.mk
-    (fiber.mk (f⁻¹ b) (right_inv f b))
-    (λz, fiber.rec_on z (λa p,
-      fiber_eq ((ap f⁻¹ p)⁻¹ ⬝ left_inv f a) (calc
-        right_inv f b = (ap (f ∘ f⁻¹) p)⁻¹ ⬝ ((ap (f ∘ f⁻¹) p) ⬝ right_inv f b)
-                                                           : by rewrite inv_con_cancel_left
-      ... = (ap (f ∘ f⁻¹) p)⁻¹ ⬝ (right_inv f (f a) ⬝ p)   : by rewrite ap_con_eq_con
-      ... = (ap (f ∘ f⁻¹) p)⁻¹ ⬝ (ap f (left_inv f a) ⬝ p) : by rewrite [adj f]
-      ... = (ap (f ∘ f⁻¹) p)⁻¹ ⬝ ap f (left_inv f a) ⬝ p   : by rewrite con.assoc
-      ... = (ap f (ap f⁻¹ p))⁻¹ ⬝ ap f (left_inv f a) ⬝ p  : by rewrite ap_compose
-      ... = ap f (ap f⁻¹ p)⁻¹ ⬝ ap f (left_inv f a) ⬝ p    : by rewrite ap_inv
-      ... = ap f ((ap f⁻¹ p)⁻¹ ⬝ left_inv f a) ⬝ p         : by rewrite ap_con)))
 
   definition is_contr_right_inverse : is_contr (Σ(g : B → A), f ∘ g ~ id) :=
   begin
@@ -42,11 +29,11 @@ namespace is_equiv
   definition is_contr_right_coherence (u : Σ(g : B → A), f ∘ g ~ id)
     : is_contr (Σ(η : u.1 ∘ f ~ id), Π(a : A), u.2 (f a) = ap f (η a)) :=
   begin
-    fapply is_trunc_equiv_closed,
-      {apply equiv.symm, apply sigma_pi_equiv_pi_sigma},
-    fapply is_trunc_equiv_closed,
+    apply is_contr_equiv_closed_rev !sigma_pi_equiv_pi_sigma,
+    apply is_contr_equiv_closed,
     { apply pi_equiv_pi_right, intro a,
       apply (fiber_eq_equiv (fiber.mk (u.1 (f a)) (u.2 (f a))) (fiber.mk a idp)) },
+    exact _
   end
 
   omit H
@@ -77,7 +64,7 @@ namespace is_equiv
 
   theorem is_prop_is_equiv [instance] : is_prop (is_equiv f) :=
   is_prop_of_imp_is_contr
-    (λ(H : is_equiv f), is_trunc_equiv_closed -2 (equiv.symm !is_equiv.sigma_char'))
+    (λ(H : is_equiv f), is_contr_equiv_closed (equiv.symm !is_equiv.sigma_char') _)
 
   definition inv_eq_inv {A B : Type} {f f' : A → B} {Hf : is_equiv f} {Hf' : is_equiv f'}
     (p : f = f') : f⁻¹ = f'⁻¹ :=
@@ -98,7 +85,7 @@ namespace is_equiv
   @is_equiv_of_is_contr_fun _ _ f (λb, @is_contr_fiber_of_is_equiv _ _ _ (H b) _)
 
   definition is_equiv_equiv_is_contr_fun : is_equiv f ≃ is_contr_fun f :=
-  equiv_of_is_prop _ (λH, !is_equiv_of_is_contr_fun)
+  equiv_of_is_prop _ (λH, !is_equiv_of_is_contr_fun) _ _
 
   theorem inv_commute'_fn {A : Type} {B C : A → Type} (f : Π{a}, B a → C a) [H : Πa, is_equiv (@f a)]
     {g : A → A} (h : Π{a}, B a → B (g a)) (h' : Π{a}, C a → C (g a))
@@ -106,7 +93,7 @@ namespace is_equiv
     inv_commute' @f @h @h' p (f b)
       = (ap f⁻¹ (p b))⁻¹ ⬝ left_inv f (h b) ⬝ (ap h (left_inv f b))⁻¹ :=
   begin
-    rewrite [↑[inv_commute',eq_of_fn_eq_fn'],+ap_con,-adj_inv f,+con.assoc,inv_con_cancel_left,
+    rewrite [↑[inv_commute',inj'],+ap_con,-adj_inv f,+con.assoc,inv_con_cancel_left,
        adj f,+ap_inv,-+ap_compose,
        eq_bot_of_square (natural_square_tr (λb, (left_inv f (h b))⁻¹ ⬝ ap f⁻¹ (p b)) (left_inv f b))⁻¹ʰ,
        con_inv,inv_inv,+con.assoc],
@@ -209,7 +196,7 @@ namespace is_equiv
   begin
     intro a,
     apply is_equiv_of_is_contr_fun, intro q,
-    apply @is_contr_equiv_closed _ _ (fiber_total_equiv f q)
+    exact is_contr_equiv_closed (fiber_total_equiv f q) _
   end
 
 end is_equiv
@@ -228,6 +215,14 @@ namespace equiv
   definition equiv_eq {f f' : A ≃ B} (p : to_fun f ~ to_fun f') : f = f' :=
   by apply equiv_eq'; apply eq_of_homotopy p
 
+  definition ap_equiv_eq {X Y : Type} {e e' : X ≃ Y} (p : e ~ e') (x : X) :
+    ap (λ(e : X ≃ Y), e x) (equiv_eq p) = p x :=
+  begin
+    cases e with e He, cases e' with e' He', esimp at *, esimp [equiv_eq],
+    refine homotopy.rec_on' p _, intro q, induction q, esimp [equiv_eq', equiv_mk_eq],
+    assert H : He = He', apply is_prop.elim, induction H, rewrite [is_prop_elimo_self]
+  end
+
   definition trans_symm (f : A ≃ B) (g : B ≃ C) : (f ⬝e g)⁻¹ᵉ = g⁻¹ᵉ ⬝e f⁻¹ᵉ :> (C ≃ A) :=
   equiv_eq' idp
 
@@ -246,8 +241,8 @@ namespace equiv
 
   definition equiv_eq_char (f f' : A ≃ B) : (f = f') ≃ (to_fun f = to_fun f') :=
   calc
-    (f = f') ≃ (to_fun !equiv.sigma_char f = to_fun !equiv.sigma_char f')
-                : eq_equiv_fn_eq (to_fun !equiv.sigma_char)
+    (f = f') ≃ (!equiv.sigma_char f = !equiv.sigma_char f')
+                : eq_equiv_fn_eq !equiv.sigma_char
          ... ≃ ((to_fun !equiv.sigma_char f).1 = (to_fun !equiv.sigma_char f').1 ) : equiv_subtype
          ... ≃ (to_fun f = to_fun f') : equiv.rfl
 
@@ -264,41 +259,59 @@ namespace equiv
 
   definition equiv_pathover {A : Type} {a a' : A} (p : a = a')
     {B : A → Type} {C : A → Type} (f : B a ≃ C a) (g : B a' ≃ C a')
-    (r : Π(b : B a) (b' : B a') (q : b =[p] b'), f b =[p] g b') : f =[p] g :=
+    (r : to_fun f =[p] to_fun g) : f =[p] g :=
   begin
     fapply pathover_of_fn_pathover_fn,
     { intro a, apply equiv.sigma_char },
-    { fapply sigma_pathover,
-        esimp, apply arrow_pathover, exact r,
-        apply is_prop.elimo}
+    { apply sigma_pathover _ _ _ r, apply is_prop.elimo }
+  end
+
+  definition equiv_pathover2 {A : Type} {a a' : A} (p : a = a')
+    {B : A → Type} {C : A → Type} (f : B a ≃ C a) (g : B a' ≃ C a')
+    (r : Π(b : B a) (b' : B a') (q : b =[p] b'), f b =[p] g b') : f =[p] g :=
+  begin
+    apply equiv_pathover, apply arrow_pathover, exact r
+  end
+
+  definition equiv_pathover_inv {A : Type} {a a' : A} (p : a = a')
+    {B : A → Type} {C : A → Type} (f : B a ≃ C a) (g : B a' ≃ C a')
+    (r : to_inv f =[p] to_inv g) : f =[p] g :=
+  begin
+    /- this proof is a bit weird, but it works -/
+    apply equiv_pathover,
+    change f⁻¹ᶠ⁻¹ᶠ =[p] g⁻¹ᶠ⁻¹ᶠ,
+    apply apo (λ(a: A) (h : C a ≃ B a), h⁻¹ᶠ),
+    apply equiv_pathover,
+    exact r
   end
 
   definition is_contr_equiv (A B : Type) [HA : is_contr A] [HB : is_contr B] : is_contr (A ≃ B) :=
   begin
-    apply @is_contr_of_inhabited_prop, apply is_prop.mk,
+    refine is_contr_of_inhabited_prop _ _,
+    { exact equiv_of_is_contr_of_is_contr _ _ },
+    { apply is_prop.mk,
       intro x y, cases x with fx Hx, cases y with fy Hy, generalize Hy,
-    apply (eq_of_homotopy (λ a, !eq_of_is_contr)) ▸ (λ Hy, !is_prop.elim ▸ rfl),
-    apply equiv_of_is_contr_of_is_contr
+      apply (eq_of_homotopy (λ a, !eq_of_is_contr)) ▸ (λ Hy, !is_prop.elim ▸ rfl) }
   end
 
   definition is_trunc_succ_equiv (n : trunc_index) (A B : Type)
   [HA : is_trunc n.+1 A] [HB : is_trunc n.+1 B] : is_trunc n.+1 (A ≃ B) :=
   @is_trunc_equiv_closed _ _ n.+1 (equiv.symm !equiv.sigma_char)
-  (@is_trunc_sigma _ _ _ _ (λ f, !is_trunc_succ_of_is_prop))
+  (@is_trunc_sigma _ _ _ _ (λ f, is_trunc_succ_of_is_prop _ _ _))
 
   definition is_trunc_equiv (n : trunc_index) (A B : Type)
   [HA : is_trunc n A] [HB : is_trunc n B] : is_trunc n (A ≃ B) :=
   by cases n; apply !is_contr_equiv; apply !is_trunc_succ_equiv
 
-  definition eq_of_fn_eq_fn'_idp {A B : Type} (f : A → B) [is_equiv f] (x : A)
-    : eq_of_fn_eq_fn' f (idpath (f x)) = idpath x :=
+  definition inj'_idp {A B : Type} (f : A → B) [is_equiv f] (x : A)
+    : inj' f (idpath (f x)) = idpath x :=
   !con.left_inv
 
-  definition eq_of_fn_eq_fn'_con {A B : Type} (f : A → B) [is_equiv f] {x y z : A}
+  definition inj'_con {A B : Type} (f : A → B) [is_equiv f] {x y z : A}
     (p : f x = f y) (q : f y = f z)
-    : eq_of_fn_eq_fn' f (p ⬝ q) = eq_of_fn_eq_fn' f p ⬝ eq_of_fn_eq_fn' f q :=
+    : inj' f (p ⬝ q) = inj' f p ⬝ inj' f q :=
   begin
-    unfold eq_of_fn_eq_fn',
+    unfold inj',
     refine _ ⬝ !con.assoc, apply whisker_right,
     refine _ ⬝ !con.assoc⁻¹ ⬝ !con.assoc⁻¹, apply whisker_left,
     refine !ap_con ⬝ _, apply whisker_left,
@@ -306,13 +319,3 @@ namespace equiv
   end
 
 end equiv
-
-namespace pointed
-  open equiv is_equiv
-  definition pequiv_eq {A B : Type*} {p q : A ≃* B} (H : p = q :> (A →* B)) : p = q :=
-  begin
-    cases p with f Hf, cases q with g Hg, esimp at *,
-    exact apd011 pequiv_of_pmap H !is_prop.elimo
-  end
-
-end pointed

hott/types/fiber.hlean

@@ -8,30 +8,32 @@ Theorems about fibers
 -/
 
 import .sigma .eq .pi cubical.squareover .pointed .eq
-open equiv sigma sigma.ops eq pi pointed
+open equiv sigma sigma.ops eq pi pointed is_equiv is_trunc function unit
 
 structure fiber {A B : Type} (f : A → B) (b : B) :=
   (point : A)
   (point_eq : f point = b)
 
-namespace fiber
 variables {A B : Type} {f : A → B} {b : B}
 
+namespace fiber
+
   protected definition sigma_char [constructor]
     (f : A → B) (b : B) : fiber f b ≃ (Σ(a : A), f a = b) :=
   begin
   fapply equiv.MK,
     {intro x, exact ⟨point x, point_eq x⟩},
     {intro x, exact (fiber.mk x.1 x.2)},
-    {intro x, exact abstract begin cases x, apply idp end end},
-    {intro x, exact abstract begin cases x, apply idp end end},
+    {intro x, cases x, apply idp },
+    {intro x, cases x, apply idp },
   end
 
-  definition fiber_eq_equiv [constructor] (x y : fiber f b)
+  /- equality type of a fiber -/
+  definition fiber_eq_equiv' [constructor] (x y : fiber f b)
     : (x = y) ≃ (Σ(p : point x = point y), point_eq x = ap f p ⬝ point_eq y) :=
   begin
     apply equiv.trans,
-      apply eq_equiv_fn_eq_of_equiv, apply fiber.sigma_char,
+      apply eq_equiv_fn_eq, apply fiber.sigma_char,
     apply equiv.trans,
       apply sigma_eq_equiv,
     apply sigma_equiv_sigma_right,
@@ -41,7 +43,77 @@ namespace fiber
 
   definition fiber_eq {x y : fiber f b} (p : point x = point y)
     (q : point_eq x = ap f p ⬝ point_eq y) : x = y :=
-  to_inv !fiber_eq_equiv ⟨p, q⟩
+  to_inv !fiber_eq_equiv' ⟨p, q⟩
+
+  definition fiber_eq_equiv [constructor] (x y : fiber f b) :
+    (x = y) ≃ (Σ(p : point x = point y), point_eq x = ap f p ⬝ point_eq y) :=
+  @equiv_change_inv _ _ (fiber_eq_equiv' x y) (λpq, fiber_eq pq.1 pq.2)
+    begin intro pq, cases pq, reflexivity end
+
+  definition point_fiber_eq {x y : fiber f b}
+    (p : point x = point y) (q : point_eq x = ap f p ⬝ point_eq y) :
+    ap point (fiber_eq p q) = p :=
+  begin
+    induction x with a r, induction y with a' s, esimp at *, induction p,
+    induction q using eq.rec_symm, induction s, reflexivity
+  end
+
+  definition fiber_eq_equiv_fiber (x y : fiber f b) :
+    x = y ≃ fiber (ap1_gen f (point_eq x) (point_eq y)) (idpath b) :=
+  calc
+    x = y ≃ fiber.sigma_char f b x = fiber.sigma_char f b y :
+      eq_equiv_fn_eq (fiber.sigma_char f b) x y
+      ... ≃ Σ(p : point x = point y), point_eq x =[p] point_eq y : sigma_eq_equiv
+      ... ≃ Σ(p : point x = point y), (point_eq x)⁻¹ ⬝ ap f p ⬝ point_eq y = idp :
+      sigma_equiv_sigma_right (λp,
+      calc point_eq x =[p] point_eq y ≃ point_eq x = ap f p ⬝ point_eq y : eq_pathover_equiv_Fl
+           ... ≃ ap f p ⬝ point_eq y = point_eq x : eq_equiv_eq_symm
+           ... ≃ (point_eq x)⁻¹ ⬝ (ap f p ⬝ point_eq y) = idp : eq_equiv_inv_con_eq_idp
+           ... ≃ (point_eq x)⁻¹ ⬝ ap f p ⬝ point_eq y = idp : equiv_eq_closed_left _ !con.assoc⁻¹)
+      ... ≃ fiber (ap1_gen f (point_eq x) (point_eq y)) (idpath b) : fiber.sigma_char
+
+  definition point_fiber_eq_equiv_fiber {x y : fiber f b}
+    (p : x = y) : point (fiber_eq_equiv_fiber x y p) = ap1_gen point idp idp p :=
+  by induction p; reflexivity
+
+  definition fiber_eq_pr2 {x y : fiber f b}
+    (p : x = y) : point_eq x = ap f (ap point p) ⬝ point_eq y :=
+  begin induction p, exact !idp_con⁻¹ end
+
+  definition fiber_eq_eta {x y : fiber f b}
+    (p : x = y) : p = fiber_eq (ap point p) (fiber_eq_pr2 p) :=
+  begin induction p, induction x with a q, induction q, reflexivity end
+
+  definition fiber_eq_con {x y z : fiber f b}
+    (p1 : point x = point y) (p2 : point y = point z)
+    (q1 : point_eq x = ap f p1 ⬝ point_eq y) (q2 : point_eq y = ap f p2 ⬝ point_eq z) :
+    fiber_eq p1 q1 ⬝ fiber_eq p2 q2 =
+    fiber_eq (p1 ⬝ p2) (q1 ⬝ whisker_left (ap f p1) q2 ⬝ !con.assoc⁻¹ ⬝
+                         whisker_right (point_eq z) (ap_con f p1 p2)⁻¹) :=
+  begin
+    induction x with a₁ r₁, induction y with a₂ r₂, induction z with a₃ r₃, esimp at *,
+    induction q2 using eq.rec_symm, induction q1 using eq.rec_symm,
+    induction p2, induction p1, induction r₃, reflexivity
+  end
+
+  definition fiber_eq2_equiv {x y : fiber f b}
+    (p₁ p₂ : point x = point y) (q₁ : point_eq x = ap f p₁ ⬝ point_eq y)
+    (q₂ : point_eq x = ap f p₂ ⬝ point_eq y) : (fiber_eq p₁ q₁ = fiber_eq p₂ q₂) ≃
+    (Σ(r : p₁ = p₂), q₁ ⬝ whisker_right (point_eq y) (ap02 f r) = q₂) :=
+  begin
+    refine (eq_equiv_fn_eq (fiber_eq_equiv x y)⁻¹ᵉ _ _)⁻¹ᵉ ⬝e sigma_eq_equiv _ _ ⬝e _,
+    apply sigma_equiv_sigma_right, esimp, intro r,
+    refine !eq_pathover_equiv_square ⬝e _,
+    refine eq_hconcat_equiv !ap_constant ⬝e hconcat_eq_equiv (ap_compose (λx, x ⬝ _) _ _) ⬝e _,
+    refine !square_equiv_eq ⬝e _,
+    exact eq_equiv_eq_closed idp (idp_con q₂)
+  end
+
+  definition fiber_eq2 {x y : fiber f b}
+    {p₁ p₂ : point x = point y} {q₁ : point_eq x = ap f p₁ ⬝ point_eq y}
+    {q₂ : point_eq x = ap f p₂ ⬝ point_eq y} (r : p₁ = p₂)
+    (s : q₁ ⬝ whisker_right (point_eq y) (ap02 f r) = q₂) : (fiber_eq p₁ q₁ = fiber_eq p₂ q₂) :=
+  (fiber_eq2_equiv p₁ p₂ q₁ q₂)⁻¹ᵉ ⟨r, s⟩
 
   definition fiber_pathover {X : Type} {A B : X → Type} {x₁ x₂ : X} {p : x₁ = x₂}
     {f : Πx, A x → B x} {b : Πx, B x} {v₁ : fiber (f x₁) (b x₁)} {v₂ : fiber (f x₂) (b x₂)}
@@ -57,35 +129,63 @@ namespace fiber
       apply pathover_idp_of_eq, apply eq_of_vdeg_square, apply square_of_squareover_ids r}
   end
 
-  open is_trunc
+  definition is_trunc_fiber (n : ℕ₋₂) {A B : Type} (f : A → B) (b : B)
+    (HA : is_trunc n A) (HB : is_trunc (n.+1) B) : is_trunc n (fiber f b) :=
+  is_trunc_equiv_closed_rev n !fiber.sigma_char _
+
+  definition is_contr_fiber_id (A : Type) (a : A) : is_contr (fiber (@id A) a) :=
+  is_contr.mk (fiber.mk a idp)
+    begin intro x, induction x with a p, esimp at p, cases p, reflexivity end
+
+  /- the general functoriality between fibers -/
+  -- todo: transpose the hsquare in fiber_functor?
+  -- todo: show that the underlying map of fiber_equiv_of_square is fiber_functor
+  definition fiber_functor [constructor] {A A' B B' : Type} {f : A → B} {f' : A' → B'}
+    {b : B} {b' : B'} (g : A → A') (h : B → B') (H : hsquare g h f f') (p : h b = b')
+    (x : fiber f b) : fiber f' b' :=
+  fiber.mk (g (point x)) (H (point x) ⬝ ap h (point_eq x) ⬝ p)
+
+  /- equivalences between fibers -/
+
+  definition fiber_equiv_of_homotopy {A B : Type} {f g : A → B} (h : f ~ g) (b : B)
+    : fiber f b ≃ fiber g b :=
+  begin
+    refine (fiber.sigma_char f b ⬝e _ ⬝e (fiber.sigma_char g b)⁻¹ᵉ),
+    apply sigma_equiv_sigma_right, intros a,
+    apply equiv_eq_closed_left, apply h
+  end
+
+  definition fiber_equiv_basepoint [constructor] {A B : Type} (f : A → B) {b1 b2 : B} (p : b1 = b2)
+    : fiber f b1 ≃ fiber f b2 :=
+    calc fiber f b1 ≃ Σa, f a = b1 : fiber.sigma_char
+               ...  ≃ Σa, f a = b2 : sigma_equiv_sigma_right (λa, equiv_eq_closed_right (f a) p)
+               ...  ≃ fiber f b2   : fiber.sigma_char
+
+
   definition fiber_pr1 (B : A → Type) (a : A) : fiber (pr1 : (Σa, B a) → A) a ≃ B a :=
   calc
     fiber pr1 a ≃ Σu, u.1 = a            : fiber.sigma_char
-            ... ≃ Σa' (b : B a'), a' = a : sigma_assoc_equiv
-            ... ≃ Σa' (p : a' = a), B a' : sigma_equiv_sigma_right (λa', !comm_equiv_nondep)
-            ... ≃ Σu, B u.1              : sigma_assoc_equiv
-            ... ≃ B a                    : !sigma_equiv_of_is_contr_left
+            ... ≃ Σu, B u.1              : sigma_assoc_comm_equiv
+            ... ≃ B a                    : sigma_equiv_of_is_contr_left _ _
 
   definition sigma_fiber_equiv (f : A → B) : (Σb, fiber f b) ≃ A :=
   calc
     (Σb, fiber f b) ≃ Σb a, f a = b : sigma_equiv_sigma_right (λb, !fiber.sigma_char)
                 ... ≃ Σa b, f a = b : sigma_comm_equiv
-                ... ≃ A             : sigma_equiv_of_is_contr_right
+                ... ≃ A             : sigma_equiv_of_is_contr_right _ _
 
-  definition is_pointed_fiber [instance] [constructor] (f : A → B) (a : A)
-    : pointed (fiber f (f a)) :=
-  pointed.mk (fiber.mk a idp)
-
-  definition pointed_fiber [constructor] (f : A → B) (a : A) : Type* :=
-  pointed.Mk (fiber.mk a (idpath (f a)))
-
-  definition is_trunc_fun [reducible] (n : ℕ₋₂) (f : A → B) :=
-  Π(b : B), is_trunc n (fiber f b)
-
-  definition is_contr_fun [reducible] (f : A → B) := is_trunc_fun -2 f
+  definition fiber_compose_equiv {A B C : Type} (g : B → C) (f : A → B) (c : C) :
+    fiber (g ∘ f) c ≃ Σ(x : fiber g c), fiber f (point x) :=
+  begin
+    fapply equiv.MK,
+    { intro x, exact ⟨fiber.mk (f (point x)) (point_eq x), fiber.mk (point x) idp⟩ },
+    { intro x, exact fiber.mk (point x.2) (ap g (point_eq x.2) ⬝ point_eq x.1) },
+    { intro x, induction x with x₁ x₂, induction x₁ with b p, induction x₂ with a q,
+      induction p, esimp at q, induction q, reflexivity },
+    { intro x, induction x with a p, induction p, reflexivity }
+  end
 
   -- pre and post composition with equivalences
-  open function
   variable (f)
   protected definition equiv_postcompose [constructor] {B' : Type} (g : B ≃ B') --[H : is_equiv g]
     (b : B) : fiber (g ∘ f) (g b) ≃ fiber f b :=
@@ -107,11 +207,24 @@ namespace fiber
                                                  end
                 ... ≃ fiber f b                : fiber.sigma_char
 
-end fiber
+  definition fiber_equiv_of_square {A B C D : Type} {b : B} {d : D} {f : A → B} {g : C → D}
+    (h : A ≃ C) (k : B ≃ D) (s : hsquare f g h k) (p : k b = d) : fiber f b ≃ fiber g d :=
+    calc fiber f b ≃ fiber (k ∘ f) (k b) : fiber.equiv_postcompose
+              ... ≃ fiber (k ∘ f) d : fiber_equiv_basepoint (k ∘ f) p
+              ... ≃ fiber (g ∘ h) d : fiber_equiv_of_homotopy s d
+              ... ≃ fiber g d : fiber.equiv_precompose
 
-open unit is_trunc pointed
+  definition fiber_equiv_of_triangle {A B C : Type} {b : B} {f : A → B} {g : C → B} (h : A ≃ C)
+    (s : f ~ g ∘ h) : fiber f b ≃ fiber g b :=
+  fiber_equiv_of_square h erfl s idp
 
-namespace fiber
+  definition is_contr_fiber_equiv [instance] (f : A ≃ B) (b : B) : is_contr (fiber f b) :=
+  is_contr_equiv_closed
+    (fiber_equiv_of_homotopy (to_left_inv f)⁻¹ʰᵗʸ _ ⬝e fiber.equiv_postcompose f f⁻¹ᵉ b)
+    !is_contr_fiber_id
+
+  definition is_contr_fiber_of_is_equiv [instance] [is_equiv f] (b : B) : is_contr (fiber f b) :=
+  is_contr_fiber_equiv (equiv.mk f _) b
 
   definition fiber_star_equiv [constructor] (A : Type) : fiber (λx : A, star) star ≃ A :=
   begin
@@ -130,94 +243,7 @@ namespace fiber
       ≃ Σz : unit, a₀ = a : fiber.sigma_char
   ... ≃ a₀ = a : sigma_unit_left
 
-  -- the pointed fiber of a pointed map, which is the fiber over the basepoint
-  open pointed
-  definition pfiber [constructor] {X Y : Type*} (f : X →* Y) : Type* :=
-  pointed.MK (fiber f pt) (fiber.mk pt !respect_pt)
-
-  definition ppoint [constructor] {X Y : Type*} (f : X →* Y) : pfiber f →* X :=
-  pmap.mk point idp
-
-  definition pfiber.sigma_char [constructor] {A B : Type*} (f : A →* B)
-    : pfiber f ≃* pointed.MK (Σa, f a = pt) ⟨pt, respect_pt f⟩ :=
-  pequiv_of_equiv (fiber.sigma_char f pt) idp
-
-  definition ppoint_sigma_char [constructor] {A B : Type*} (f : A →* B)
-    : ppoint f ~* pmap.mk pr1 idp ∘* pfiber.sigma_char f :=
-  !phomotopy.refl
-
-  definition pfiber_loop_space {A B : Type*} (f : A →* B) : pfiber (Ω→ f) ≃* Ω (pfiber f) :=
-    pequiv_of_equiv
-    (calc pfiber (Ω→ f) ≃ Σ(p : Point A = Point A), ap1 f p = rfl
-                          : (fiber.sigma_char (ap1 f) (Point (Ω B)))
-                    ... ≃ Σ(p : Point A = Point A), (respect_pt f) = ap f p ⬝ (respect_pt f)
-                          : (sigma_equiv_sigma_right (λp,
-                              calc (ap1 f p = rfl) ≃ !respect_pt⁻¹ ⬝ (ap f p ⬝ !respect_pt) = rfl
-                                                     : equiv_eq_closed_left _ (con.assoc _ _ _)
-                                               ... ≃ ap f p ⬝ (respect_pt f) = (respect_pt f)
-                                                     : eq_equiv_inv_con_eq_idp
-                                               ... ≃ (respect_pt f) = ap f p ⬝ (respect_pt f)
-                                                     : eq_equiv_eq_symm))
-                    ... ≃ fiber.mk (Point A) (respect_pt f) = fiber.mk pt (respect_pt f)
-                          : fiber_eq_equiv
-                    ... ≃ Ω (pfiber f)
-                          : erfl)
-    (begin cases f with f p, cases A with A a, cases B with B b, esimp at p, esimp at f,
-           induction p, reflexivity end)
-
-  definition pfiber_equiv_of_phomotopy {A B : Type*} {f g : A →* B} (h : f ~* g)
-    : pfiber f ≃* pfiber g :=
-  begin
-    fapply pequiv_of_equiv,
-    { refine (fiber.sigma_char f pt ⬝e _ ⬝e (fiber.sigma_char g pt)⁻¹ᵉ),
-      apply sigma_equiv_sigma_right, intros a,
-      apply equiv_eq_closed_left, apply (to_homotopy h) },
-    { refine (fiber_eq rfl _),
-      change (h pt)⁻¹ ⬝ respect_pt f = idp ⬝ respect_pt g,
-      rewrite idp_con, apply inv_con_eq_of_eq_con, symmetry, exact (to_homotopy_pt h) }
-  end
-
-  definition transport_fiber_equiv [constructor] {A B : Type} (f : A → B) {b1 b2 : B} (p : b1 = b2)
-    : fiber f b1 ≃ fiber f b2 :=
-    calc fiber f b1 ≃ Σa, f a = b1 : fiber.sigma_char
-               ...  ≃ Σa, f a = b2 : sigma_equiv_sigma_right (λa, equiv_eq_closed_right (f a) p)
-               ...  ≃ fiber f b2   : fiber.sigma_char
-
-  definition pequiv_postcompose {A B B' : Type*} (f : A →* B) (g : B ≃* B')
-    : pfiber (g ∘* f) ≃* pfiber f :=
-  begin
-    fapply pequiv_of_equiv, esimp,
-    refine transport_fiber_equiv (g ∘* f) (respect_pt g)⁻¹ ⬝e fiber.equiv_postcompose f g (Point B),
-    esimp, apply (ap (fiber.mk (Point A))), refine !con.assoc ⬝ _, apply inv_con_eq_of_eq_con,
-    rewrite [con.assoc, con.right_inv, con_idp, -ap_compose'], apply ap_con_eq_con
-  end
-
-  definition pequiv_precompose {A A' B : Type*} (f : A →* B) (g : A' ≃* A)
-    : pfiber (f ∘* g) ≃* pfiber f :=
-  begin
-    fapply pequiv_of_equiv, esimp,
-    refine fiber.equiv_precompose f g (Point B),
-    esimp, apply (eq_of_fn_eq_fn (fiber.sigma_char _ _)), fapply sigma_eq: esimp,
-    { apply respect_pt g },
-    { apply eq_pathover_Fl' }
-  end
-
-  definition pfiber_equiv_of_square {A B C D : Type*} {f : A →* B} {g : C →* D} (h : A ≃* C)
-    (k : B ≃* D) (s : k ∘* f ~* g ∘* h) : pfiber f ≃* pfiber g :=
-    calc pfiber f ≃* pfiber (k ∘* f) : pequiv_postcompose
-              ... ≃* pfiber (g ∘* h) : pfiber_equiv_of_phomotopy s
-              ... ≃* pfiber g : pequiv_precompose
-
-end fiber
-
-open function is_equiv
-
-namespace fiber
-  /- Theorem 4.7.6 -/
-  variables {A : Type} {P Q : A → Type}
-  variable (f : Πa, P a → Q a)
-
-  definition fiber_total_equiv [constructor] {a : A} (q : Q a)
+  definition fiber_total_equiv [constructor] {P Q : A → Type} (f : Πa, P a → Q a) {a : A} (q : Q a)
     : fiber (total f) ⟨a , q⟩ ≃ fiber (f a) q :=
   calc
     fiber (total f) ⟨a , q⟩
@@ -238,12 +264,8 @@ namespace fiber
               apply sigma_equiv_sigma_right, intro x,
               apply sigma_comm_equiv
             end
-      ... ≃ Σ(w : Σx, x = a), Σ(p : P w.1), f w.1 p =[w.2] q
-            : sigma_assoc_equiv
-      ... ≃ Σ(p : P (center (Σx, x=a)).1), f (center (Σx, x=a)).1 p =[(center (Σx, x=a)).2] q
-            : sigma_equiv_of_is_contr_left
       ... ≃ Σ(p : P a), f a p =[idpath a] q
-            : equiv_of_eq idp
+            : sigma_sigma_eq_left
       ... ≃ Σ(p : P a), f a p = q
             :
             begin
@@ -253,4 +275,216 @@ namespace fiber
       ... ≃ fiber (f a) q
             : fiber.sigma_char
 
+  definition fiber_equiv_of_is_contr [constructor] {A B : Type} (f : A → B) (b : B)
+    (H : is_contr B) : fiber f b ≃ A :=
+  !fiber.sigma_char ⬝e sigma_equiv_of_is_contr_right _ _
+
+  /- the pointed fiber of a pointed map, which is the fiber over the basepoint -/
+
+  definition pfiber [constructor] {X Y : Type*} (f : X →* Y) : Type* :=
+  pointed.MK (fiber f pt) (fiber.mk pt !respect_pt)
+
+  definition ppoint [constructor] {X Y : Type*} (f : X →* Y) : pfiber f →* X :=
+  pmap.mk point idp
+
+  definition pfiber.sigma_char [constructor] {A B : Type*} (f : A →* B)
+    : pfiber f ≃* pointed.MK (Σa, f a = pt) ⟨pt, respect_pt f⟩ :=
+  pequiv_of_equiv (fiber.sigma_char f pt) idp
+
+  definition ppoint_sigma_char [constructor] {A B : Type*} (f : A →* B)
+    : ppoint f ~* pmap.mk pr1 idp ∘* pfiber.sigma_char f :=
+  !phomotopy.refl
+
+  definition pfiber_pequiv_of_phomotopy {A B : Type*} {f g : A →* B} (h : f ~* g)
+    : pfiber f ≃* pfiber g :=
+  begin
+    fapply pequiv_of_equiv,
+    { exact fiber_equiv_of_homotopy h pt },
+    { refine (fiber_eq rfl _),
+      change (h pt)⁻¹ ⬝ respect_pt f = idp ⬝ respect_pt g,
+      rewrite idp_con, apply inv_con_eq_of_eq_con, symmetry, exact (to_homotopy_pt h) }
+  end
+
+  definition pequiv_postcompose {A B B' : Type*} (f : A →* B) (g : B ≃* B')
+    : pfiber (g ∘* f) ≃* pfiber f :=
+  begin
+    fapply pequiv_of_equiv, esimp,
+    refine fiber_equiv_basepoint (g ∘* f) (respect_pt g)⁻¹ ⬝e fiber.equiv_postcompose f g (Point B),
+    esimp, apply (ap (fiber.mk (Point A))), refine !con.assoc ⬝ _, apply inv_con_eq_of_eq_con,
+    rewrite [▸*, con.assoc, con.right_inv, con_idp, ap_compose'],
+    exact ap_con_eq_con (λ x, ap g⁻¹ᵉ* (ap g (pleft_inv' g x)⁻¹) ⬝ ap g⁻¹ᵉ* (pright_inv g (g x)) ⬝
+      pleft_inv' g x) (respect_pt f)
+  end
+
+  definition pequiv_precompose {A A' B : Type*} (f : A →* B) (g : A' ≃* A)
+    : pfiber (f ∘* g) ≃* pfiber f :=
+  begin
+    fapply pequiv_of_equiv, esimp,
+    refine fiber.equiv_precompose f g (Point B),
+    esimp, apply (inj (fiber.sigma_char _ _)), fapply sigma_eq: esimp,
+    { apply respect_pt g },
+    { apply eq_pathover_Fl' }
+  end
+
+  definition pfiber_pequiv_of_square {A B C D : Type*} {f : A →* B} {g : C →* D} (h : A ≃* C)
+    (k : B ≃* D) (s : k ∘* f ~* g ∘* h) : pfiber f ≃* pfiber g :=
+    calc pfiber f ≃* pfiber (k ∘* f) : pequiv_postcompose
+              ... ≃* pfiber (g ∘* h) : pfiber_pequiv_of_phomotopy s
+              ... ≃* pfiber g : pequiv_precompose
+
+  definition pcompose_ppoint {A B : Type*} (f : A →* B) : f ∘* ppoint f ~* pconst (pfiber f) B :=
+  begin
+    fapply phomotopy.mk,
+    { exact point_eq },
+    { exact !idp_con⁻¹ }
+  end
+
+  definition loop_pfiber [constructor] {A B : Type*} (f : A →* B) : Ω (pfiber f) ≃* pfiber (Ω→ f) :=
+  pequiv_of_equiv (fiber_eq_equiv_fiber pt pt)
+    begin
+      induction f with f f₀, induction B with B b₀, esimp at (f,f₀), induction f₀, reflexivity
+    end
+
+  definition pfiber_loop_space {A B : Type*} (f : A →* B) : pfiber (Ω→ f) ≃* Ω (pfiber f) :=
+  (loop_pfiber f)⁻¹ᵉ*
+
+  lemma ppoint_loop_pfiber {A B : Type*} (f : A →* B) :
+    ppoint (Ω→ f) ∘* loop_pfiber f ~* Ω→ (ppoint f) :=
+  phomotopy.mk (point_fiber_eq_equiv_fiber)
+    begin
+     induction f with f f₀, induction B with B b₀, esimp at (f,f₀), induction f₀, reflexivity
+    end
+
+  lemma ppoint_loop_pfiber_inv {A B : Type*} (f : A →* B) :
+    Ω→ (ppoint f) ∘* (loop_pfiber f)⁻¹ᵉ* ~* ppoint (Ω→ f) :=
+  (phomotopy_pinv_right_of_phomotopy (ppoint_loop_pfiber f))⁻¹*
+
+  lemma pfiber_pequiv_of_phomotopy_ppoint {A B : Type*} {f g : A →* B} (h : f ~* g)
+    : ppoint g ∘* pfiber_pequiv_of_phomotopy h ~* ppoint f :=
+  begin
+    induction f with f f₀, induction g with g g₀, induction h with h h₀, induction B with B b₀,
+    esimp at *, induction h₀, induction g₀,
+    fapply phomotopy.mk,
+    { reflexivity },
+    { symmetry, rexact point_fiber_eq (idpath pt)
+        (inv_con_eq_of_eq_con (idpath (h pt ⬝ (idp ⬝ point_eq (fiber.mk pt idp))))) }
+  end
+
+  lemma pequiv_postcompose_ppoint {A B B' : Type*} (f : A →* B) (g : B ≃* B')
+    : ppoint f ∘* fiber.pequiv_postcompose f g ~* ppoint (g ∘* f) :=
+  begin
+    induction f with f f₀, induction g with g hg g₀, induction B with B b₀,
+    induction B' with B' b₀', esimp at * ⊢, induction g₀, induction f₀,
+    fapply phomotopy.mk,
+    { reflexivity },
+    { symmetry,
+      refine !ap_compose⁻¹ ⬝ _, apply ap_constant }
+  end
+
+  lemma pequiv_precompose_ppoint {A A' B : Type*} (f : A →* B) (g : A' ≃* A)
+    : ppoint f ∘* fiber.pequiv_precompose f g ~* g ∘* ppoint (f ∘* g) :=
+  begin
+    induction f with f f₀, induction g with g h₁ h₂ p₁ p₂, induction B with B b₀,
+    induction g with g g₀, induction A with A a₀', esimp at *, induction g₀, induction f₀,
+    reflexivity
+  end
+
+  definition pfiber_pequiv_of_square_ppoint {A B C D : Type*} {f : A →* B} {g : C →* D}
+    (h : A ≃* C) (k : B ≃* D) (s : k ∘* f ~* g ∘* h)
+    : ppoint g ∘* pfiber_pequiv_of_square h k s ~* h ∘* ppoint f :=
+  begin
+    refine !passoc⁻¹* ⬝* _,
+    refine pwhisker_right _ !pequiv_precompose_ppoint ⬝* _,
+    refine !passoc ⬝* _,
+    apply pwhisker_left,
+    refine !passoc⁻¹* ⬝* _,
+    refine pwhisker_right _ !pfiber_pequiv_of_phomotopy_ppoint ⬝* _,
+    apply pinv_right_phomotopy_of_phomotopy,
+    refine !pequiv_postcompose_ppoint⁻¹*,
+  end
+
+  definition is_trunc_pfiber (n : ℕ₋₂) {A B : Type*} (f : A →* B)
+    (HA : is_trunc n A) (HB : is_trunc (n.+1) B) : is_trunc n (pfiber f) :=
+  is_trunc_fiber n f pt HA HB
+
+  definition pfiber_pequiv_of_is_contr [constructor] {A B : Type*} (f : A →* B) (H : is_contr B) :
+    pfiber f ≃* A :=
+  pequiv_of_equiv (fiber_equiv_of_is_contr f pt H) idp
+
+  definition pfiber_ppoint_equiv {A B : Type*} (f : A →* B) : pfiber (ppoint f) ≃ Ω B :=
+  calc
+    pfiber (ppoint f) ≃ Σ(x : pfiber f), ppoint f x = pt : fiber.sigma_char
+      ... ≃ Σ(x : Σa, f a = pt), x.1 = pt : by exact sigma_equiv_sigma !fiber.sigma_char (λa, erfl)
+      ... ≃ Σ(x : Σa, a = pt), f x.1 = pt : by exact !sigma_assoc_comm_equiv
+      ... ≃ f pt = pt : by exact sigma_equiv_of_is_contr_left _ _
+      ... ≃ Ω B : by exact !equiv_eq_closed_left !respect_pt
+
+  definition pfiber_ppoint_pequiv {A B : Type*} (f : A →* B) : pfiber (ppoint f) ≃* Ω B :=
+  pequiv_of_equiv (pfiber_ppoint_equiv f) !con.left_inv
+
+  definition pfiber_ppoint_equiv_eq {A B : Type*} {f : A →* B} {a : A} (p : f a = pt)
+    (q : ppoint f (fiber.mk a p) = pt) :
+    pfiber_ppoint_equiv f (fiber.mk (fiber.mk a p) q) = (respect_pt f)⁻¹ ⬝ ap f q⁻¹ ⬝ p :=
+  begin
+    refine _ ⬝ !con.assoc⁻¹,
+    apply whisker_left,
+    refine eq_transport_Fl _ _ ⬝ _,
+    apply whisker_right,
+    refine inverse2 !ap_inv ⬝ !inv_inv ⬝ _,
+    refine ap_compose f pr₁ _ ⬝ ap02 f !ap_pr1_center_eq_sigma_eq',
+  end
+
+  definition pfiber_ppoint_equiv_inv_eq {A B : Type*} (f : A →* B) (p : Ω B) :
+    (pfiber_ppoint_equiv f)⁻¹ᵉ p = fiber.mk (fiber.mk pt (respect_pt f ⬝ p)) idp :=
+  begin
+    apply inv_eq_of_eq,
+    refine _ ⬝ !pfiber_ppoint_equiv_eq⁻¹,
+    exact !inv_con_cancel_left⁻¹
+  end
+
+  definition loopn_pfiber [constructor] {A B : Type*} (n : ℕ) (f : A →* B) :
+    Ω[n] (pfiber f) ≃* pfiber (Ω→[n] f) :=
+  begin
+    induction n with n IH, reflexivity, exact loop_pequiv_loop IH ⬝e* loop_pfiber (Ω→[n] f),
+  end
+
+  definition is_contr_pfiber_pid (A : Type*) : is_contr (pfiber (pid A)) :=
+  by exact is_contr_fiber_id A pt
+
+  definition pfiber_functor [constructor] {A A' B B' : Type*} {f : A →* B} {f' : A' →* B'}
+    (g : A →* A') (h : B →* B') (H : psquare g h f f') : pfiber f →* pfiber f' :=
+  pmap.mk (fiber_functor g h H (respect_pt h))
+    begin
+      fapply fiber_eq,
+        exact respect_pt g,
+        exact !con.assoc ⬝ to_homotopy_pt H
+    end
+
+  definition ppoint_natural {A A' B B' : Type*} {f : A →* B} {f' : A' →* B'}
+    (g : A →* A') (h : B →* B') (H : psquare g h f f') :
+    psquare (ppoint f) (ppoint f') (pfiber_functor g h H) g :=
+  begin
+    fapply phomotopy.mk,
+    { intro x, reflexivity },
+    { refine !idp_con ⬝ _ ⬝ !idp_con⁻¹, esimp, apply point_fiber_eq }
+  end
+
+  /- A less commonly used pointed fiber with basepoint (f a) for some a in the domain of f -/
+  definition pointed_fiber [constructor] (f : A → B) (a : A) : Type* :=
+  pointed.Mk (fiber.mk a (idpath (f a)))
+
 end fiber
+open fiber
+
+/- A function is truncated if it has truncated fibers -/
+definition is_trunc_fun [reducible] (n : ℕ₋₂) (f : A → B) :=
+Π(b : B), is_trunc n (fiber f b)
+
+definition is_contr_fun [reducible] (f : A → B) := is_trunc_fun -2 f
+
+definition is_trunc_fun_id (k : ℕ₋₂) (A : Type) : is_trunc_fun k (@id A) :=
+λa, is_trunc_of_is_contr _ _ !is_contr_fiber_id
+
+definition is_trunc_fun_compose (k : ℕ₋₂) {A B C : Type} {g : B → C} {f : A → B}
+  (Hg : is_trunc_fun k g) (Hf : is_trunc_fun k f) : is_trunc_fun k (g ∘ f) :=
+λc, is_trunc_equiv_closed_rev k (fiber_compose_equiv g f c) _

hott/types/fin.hlean

@@ -30,8 +30,8 @@ end
 
 definition is_set_fin [instance] : is_set (fin n) :=
 begin
-  assert H : Πa, is_set (a < n), exact _, -- I don't know why this is necessary
-  apply is_trunc_equiv_closed_rev, apply fin.sigma_char,
+  assert H : Πa, is_set (a < n), exact _,
+  apply is_trunc_equiv_closed_rev 0 !fin.sigma_char _,
 end
 
 definition eq_of_veq : Π {i j : fin n}, (val i) = j → i = j :=
@@ -135,12 +135,11 @@ theorem val_lt : Π i : fin n, val i < n
 lemma max_lt (i j : fin n) : max i j < n :=
 max_lt (is_lt i) (is_lt j)
 
-definition lift [constructor] : fin n → Π m : nat, fin (n + m)
-| (mk v h) m := mk v (lt_add_of_lt_right h m)
+definition lift [constructor] (x : fin n) (m : ℕ) : fin (n + m) :=
+fin.mk x (lt_add_of_lt_right (is_lt x) m)
 
-definition lift_succ [constructor] (i : fin n) : fin (nat.succ n) :=
-have r : fin (n+1), from lift i 1,
-r
+definition lift_succ [constructor] ⦃n : ℕ⦄ (x : fin n) : fin (nat.succ n) :=
+fin.mk x (le.step (is_lt x))
 
 definition maxi [reducible] : fin (succ n) :=
 mk n !lt_succ_self
@@ -219,7 +218,7 @@ lemma lift_fun_eq {f : fin n → fin n} {i : fin n} :
   lift_fun f (lift_succ i) = lift_succ (f i) :=
 begin
   rewrite [lift_fun_of_ne_max lift_succ_ne_max], do 2 congruence,
-  apply eq_of_veq, esimp, rewrite -val_lift,
+  apply eq_of_veq, reflexivity
 end
 
 lemma lift_fun_of_inj {f : fin n → fin n} : is_embedding f → is_embedding (lift_fun f) :=
@@ -238,8 +237,8 @@ begin
       rewrite [lift_fun_of_ne_max Pinmax, lift_fun_of_ne_max Pjnmax],
         intro Peq, apply eq_of_veq,
         cases i with i ilt, cases j with j jlt, esimp at *,
-        fapply veq_of_eq, apply is_injective_of_is_embedding,
-        apply @is_injective_of_is_embedding _ _ lift_succ _ _ _ Peq,
+        fapply veq_of_eq, apply @is_injective_of_is_embedding _ _ f,
+        apply @is_injective_of_is_embedding _ _ (@lift_succ _) _ _ _ Peq,
 end
 
 lemma lift_fun_inj : is_embedding (@lift_fun n) :=
@@ -329,9 +328,9 @@ lemma val_succ : Π (i : fin n), val (succ i) = nat.succ (val i)
 
 lemma succ_max : fin.succ maxi = (@maxi (nat.succ n)) := rfl
 
-lemma lift_succ.comm : lift_succ ∘ (@succ n) = succ ∘ lift_succ :=
+lemma lift_succ.comm : @lift_succ _ ∘ (@succ n) = succ ∘ @lift_succ _ :=
 eq_of_homotopy take i,
-  eq_of_veq (begin rewrite [↑lift_succ, -val_lift, *val_succ, -val_lift] end)
+  eq_of_veq (begin rewrite [↑lift_succ, *val_succ] end)
 
 definition elim0 {C : fin 0 → Type} : Π i : fin 0, C i
 | (mk v h) := absurd h !not_lt_zero
@@ -388,9 +387,7 @@ begin
   { intro ilt', esimp[val_inj], apply concat,
     apply ap (λ x, eq.rec_on x _), esimp[eq_of_veq, rfl], reflexivity,
     have H : ilt = ilt', by apply is_prop.elim, cases H,
-    have H' : is_prop.elim (lt_add_of_lt_right ilt 1) (lt_add_of_lt_right ilt 1) = idp,
-      by apply is_prop.elim,
-    krewrite H' },
+    apply ap (λx, eq.rec_on x _), apply ap02, apply is_prop_elim_self },
   { intro a, exact absurd ilt a },
 end
 
@@ -522,7 +519,7 @@ begin
                    ... ≃ fin 0 : fin_zero_equiv_empty },
   { have H : (a + 1) * m = a * m + m, by rewrite [nat.right_distrib, one_mul],
     calc fin (a + 1) × fin m
-         ≃ (fin a + unit) × fin m : prod.prod_equiv_prod_right !fin_succ_equiv
+         ≃ (fin a + unit) × fin m : prod_equiv_prod_left !fin_succ_equiv
      ... ≃ (fin a × fin m) + (unit × fin m) : sum_prod_right_distrib
      ... ≃ (fin a × fin m) + (fin m × unit) : prod_comm_equiv
      ... ≃ fin (a * m) + (fin m × unit) : v_0
@@ -532,7 +529,7 @@ begin
 end
 
 definition fin_two_equiv_bool : fin 2 ≃ bool :=
-let H := equiv_unit_of_is_contr (fin 1) in
+let H := equiv_unit_of_is_contr (fin 1) _ in
 calc
   fin 2 ≃ fin (1 + 1)   : equiv.refl
    ...  ≃ fin 1 + fin 1 : fin_sum_equiv
@@ -540,7 +537,7 @@ calc
    ...  ≃ bool          : bool_equiv_unit_sum_unit
 
 definition fin_sum_unit_equiv (n : nat) : fin n + unit ≃ fin (nat.succ n) :=
-let H := equiv_unit_of_is_contr (fin 1) in
+let H := equiv_unit_of_is_contr (fin 1) _ in
 calc
   fin n + unit ≃ fin n + fin 1 : H
           ...  ≃ fin (nat.succ n)     : fin_sum_equiv
@@ -595,6 +592,15 @@ end
                (succ_lt_succ (lt_of_le_of_ne (le_of_lt_succ (is_lt x)) H))}
   end
 
+  definition cyclic_pred {n : ℕ} (x : fin n) : fin n :=
+  begin
+    cases n with n,
+    { exfalso, apply not_lt_zero _ (is_lt x)},
+    { cases x with m H, cases m with m,
+      { exact fin.mk n (self_lt_succ n) },
+      { exact fin.mk m (lt.trans (self_lt_succ m) H) }}
+  end
+
   /-
     We want to say that fin (succ n) always has a 0 and 1. However, we want a bit more, because
     sometimes we want a zero of (fin a) where a is either

hott/types/int/default.hlean

@@ -4,4 +4,4 @@ Released under Apache 2.0 license as described in the file LICENSE.
 Authors: Floris van Doorn
 -/
 
-import .basic .hott
+import .basic .hott .order

hott/types/int/hott.hlean

@@ -6,7 +6,7 @@ Author: Floris van Doorn
 Theorems about the integers specific to HoTT
 -/
 
-import .basic types.eq arity algebra.bundled
+import .order types.eq arity algebra.bundled
 open core eq is_equiv equiv algebra is_trunc
 open nat (hiding pred)
 
@@ -28,8 +28,17 @@ namespace int
   AddAbGroup.mk ℤ _
 
   notation `agℤ` := AbGroup_int
+
+  definition ring_int : Ring :=
+  Ring.mk ℤ _
+
+  notation `rℤ` := ring_int
+
   end
 
+  definition not_neg_succ_le_of_nat {n m : ℕ} : ¬m ≤ -[1+n] :=
+  by cases m: exact id
+
   definition is_equiv_succ [constructor] [instance] : is_equiv succ :=
   adjointify succ pred (λa, !add_sub_cancel) (λa, !sub_add_cancel)
   definition equiv_succ [constructor] : ℤ ≃ ℤ := equiv.mk succ _
@@ -38,11 +47,31 @@ namespace int
   adjointify neg neg (λx, !neg_neg) (λa, !neg_neg)
   definition equiv_neg [constructor] : ℤ ≃ ℤ := equiv.mk neg _
 
-  definition iterate {A : Type} (f : A ≃ A) (a : ℤ) : A ≃ A :=
+  definition iiterate {A : Type} (f : A ≃ A) (a : ℤ) : A ≃ A :=
   rec_nat_on a erfl
                (λb g, f ⬝e g)
                (λb g, g ⬝e f⁻¹ᵉ)
 
+  definition max0 : ℤ → ℕ
+  | (of_nat n) := n
+  | (-[1+ n])  := 0
+
+  lemma le_max0 : Π(n : ℤ), n ≤ of_nat (max0 n)
+  | (of_nat n) := proof le.refl n qed
+  | (-[1+ n])  := proof unit.star qed
+
+  lemma le_of_max0_le {n : ℤ} {m : ℕ} (h : max0 n ≤ m) : n ≤ of_nat m :=
+  le.trans (le_max0 n) (of_nat_le_of_nat_of_le h)
+
+  definition max0_monotone {n m : ℤ} (H : n ≤ m) : max0 n ≤ max0 m :=
+  begin
+    induction n with n n,
+    { induction m with m m,
+      { exact le_of_of_nat_le_of_nat H },
+      { exfalso, exact not_neg_succ_le_of_nat H }},
+    { apply zero_le }
+  end
+
   -- definition iterate_trans {A : Type} (f : A ≃ A) (a : ℤ)
   --   : iterate f a ⬝e f = iterate f (a + 1) :=
   -- sorry

hott/types/int/int.md

@@ -4,4 +4,5 @@ types.int
 The integers. Note: most of these files are ported from the standard library. If anything needs to be changed, it is probably a good idea to change it in the standard library and then port the file again (see also [script/port.pl](../../../script/port.pl)).
 
 * [basic](basic.hlean) : the integers, with basic operations
+* [order](order.hlean) : order on the integers
 * [hott](hott.hlean) : facts about the integers specific to the HoTT library

hott/types/int/order.hlean

@@ -0,0 +1,438 @@
+/-
+Copyright (c) 2014 Floris van Doorn. All rights reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+Authors: Floris van Doorn, Jeremy Avigad
+
+The order relation on the integers. We show that int is an instance of linear_comm_ordered_ring
+prod transfer the results.
+-/
+import .basic algebra.ordered_ring
+open nat decidable int unit algebra eq
+
+namespace int
+
+private definition nonneg (a : ℤ) : Type₀ := int.cases_on a (take n, unit) (take n, empty)
+protected definition le (a b : ℤ) : Type₀ := nonneg (b - a)
+
+definition int_has_le [instance] [priority int.prio]: has_le int :=
+has_le.mk int.le
+
+protected definition lt (a b : ℤ) : Type₀ := (a + 1) ≤ b
+
+definition int_has_lt [instance] [priority int.prio]: has_lt int :=
+has_lt.mk int.lt
+
+local attribute nonneg [reducible]
+private definition decidable_nonneg [instance] (a : ℤ) : decidable (nonneg a) := int.cases_on a _ _
+definition decidable_le [instance] (a b : ℤ) : decidable (a ≤ b) := decidable_nonneg _
+definition decidable_lt [instance] (a b : ℤ) : decidable (a < b) := decidable_nonneg _
+
+private theorem nonneg.elim {a : ℤ} : nonneg a → Σn : ℕ, a = n :=
+int.cases_on a (take n H, sigma.mk n rfl) (take n', empty.elim)
+
+private theorem nonneg_sum_nonneg_neg (a : ℤ) : nonneg a ⊎ nonneg (-a) :=
+int.cases_on a (take n, sum.inl star) (take n, sum.inr star)
+
+theorem le.intro {a b : ℤ} {n : ℕ} (H : a + n = b) : a ≤ b :=
+have n = b - a, from eq_add_neg_of_add_eq (begin rewrite [add.comm, H] end), -- !add.comm ▸ H),
+show nonneg (b - a), from this ▸ star
+
+theorem le.elim {a b : ℤ} (H : a ≤ b) : Σn : ℕ, a + n = b :=
+obtain (n : ℕ) (H1 : b - a = n), from nonneg.elim H,
+sigma.mk n (!add.comm ▸ iff.mpr !add_eq_iff_eq_add_neg (H1⁻¹))
+
+protected theorem le_total (a b : ℤ) : a ≤ b ⊎ b ≤ a :=
+sum.imp_right
+  (assume H : nonneg (-(b - a)),
+   have -(b - a) = a - b, from !neg_sub,
+   show nonneg (a - b), from this ▸ H)
+  (nonneg_sum_nonneg_neg (b - a))
+
+theorem of_nat_le_of_nat_of_le {m n : ℕ} (H : #nat m ≤ n) : of_nat m ≤ of_nat n :=
+obtain (k : ℕ) (Hk : m + k = n), from nat.le.elim H,
+le.intro (Hk ▸ (of_nat_add m k)⁻¹)
+
+theorem le_of_of_nat_le_of_nat {m n : ℕ} (H : of_nat m ≤ of_nat n) : (#nat m ≤ n) :=
+obtain (k : ℕ) (Hk : of_nat m + of_nat k = of_nat n), from le.elim H,
+have m + k = n, from of_nat.inj (of_nat_add m k ⬝ Hk),
+nat.le.intro this
+
+theorem of_nat_le_of_nat_iff (m n : ℕ) : of_nat m ≤ of_nat n ↔ m ≤ n :=
+iff.intro le_of_of_nat_le_of_nat of_nat_le_of_nat_of_le
+
+theorem lt_add_succ (a : ℤ) (n : ℕ) : a < a + succ n :=
+le.intro (show a + 1 + n = a + succ n, from
+  calc
+    a + 1 + n = a + (1 + n) : add.assoc
+      ... = a + (n + 1)     : by rewrite (int.add_comm 1 n)
+      ... = a + succ n      : rfl)
+
+theorem lt.intro {a b : ℤ} {n : ℕ} (H : a + succ n = b) : a < b :=
+H ▸ lt_add_succ a n
+
+theorem lt.elim {a b : ℤ} (H : a < b) : Σn : ℕ, a + succ n = b :=
+obtain (n : ℕ) (Hn : a + 1 + n = b), from le.elim H,
+have a + succ n = b, from
+  calc
+    a + succ n = a + 1 + n : by rewrite [add.assoc, int.add_comm 1 n]
+           ... = b         : Hn,
+sigma.mk n this
+
+theorem of_nat_lt_of_nat_iff (n m : ℕ) : of_nat n < of_nat m ↔ n < m :=
+calc
+  of_nat n < of_nat m ↔ of_nat n + 1 ≤ of_nat m : iff.refl
+    ... ↔ of_nat (nat.succ n) ≤ of_nat m        : of_nat_succ n ▸ !iff.refl
+    ... ↔ nat.succ n ≤ m                        : of_nat_le_of_nat_iff
+    ... ↔ n < m                                 : iff.symm (lt_iff_succ_le _ _)
+
+theorem lt_of_of_nat_lt_of_nat {m n : ℕ} (H : of_nat m < of_nat n) : #nat m < n :=
+iff.mp !of_nat_lt_of_nat_iff H
+
+theorem of_nat_lt_of_nat_of_lt {m n : ℕ} (H : #nat m < n) : of_nat m < of_nat n :=
+iff.mpr !of_nat_lt_of_nat_iff H
+
+/- show that the integers form an ordered additive group -/
+
+protected theorem le_refl (a : ℤ) : a ≤ a :=
+le.intro (add_zero a)
+
+protected theorem le_trans {a b c : ℤ} (H1 : a ≤ b) (H2 : b ≤ c) : a ≤ c :=
+obtain (n : ℕ) (Hn : a + n = b), from le.elim H1,
+obtain (m : ℕ) (Hm : b + m = c), from le.elim H2,
+have a + of_nat (n + m) = c, from
+  calc
+    a + of_nat (n + m) = a + (of_nat n + m) : {of_nat_add n m}
+      ... = a + n + m : (add.assoc a n m)⁻¹
+      ... = b + m : {Hn}
+      ... = c : Hm,
+le.intro this
+
+protected theorem le_antisymm : Π {a b : ℤ}, a ≤ b → b ≤ a → a = b :=
+take a b : ℤ, assume (H₁ : a ≤ b) (H₂ : b ≤ a),
+obtain (n : ℕ) (Hn : a + n = b), from le.elim H₁,
+obtain (m : ℕ) (Hm : b + m = a), from le.elim H₂,
+have a + of_nat (n + m) = a + 0, from
+  calc
+    a + of_nat (n + m) = a + (of_nat n + m) : by rewrite of_nat_add
+      ... = a + n + m                       : by rewrite add.assoc
+      ... = b + m                           : by rewrite Hn
+      ... = a                               : by rewrite Hm
+      ... = a + 0                           : by rewrite add_zero,
+have of_nat (n + m) = of_nat 0, from add.left_cancel this,
+have n + m = 0,                 from of_nat.inj this,
+have n = 0,                     from nat.eq_zero_of_add_eq_zero_right this,
+show a = b, from
+  calc
+    a = a + 0    : add_zero
+  ... = a + n    : by rewrite this
+  ... = b        : Hn
+
+protected theorem lt_irrefl (a : ℤ) : ¬ a < a :=
+(suppose a < a,
+  obtain (n : ℕ) (Hn : a + succ n = a), from lt.elim this,
+  have a + succ n = a + 0, from
+    Hn ⬝ !add_zero⁻¹,
+  !succ_ne_zero (of_nat.inj (add.left_cancel this)))
+
+protected theorem ne_of_lt {a b : ℤ} (H : a < b) : a ≠ b :=
+(suppose a = b, absurd (this ▸ H) (int.lt_irrefl b))
+
+theorem le_of_lt {a b : ℤ} (H : a < b) : a ≤ b :=
+obtain (n : ℕ) (Hn : a + succ n = b), from lt.elim H,
+le.intro Hn
+
+protected theorem lt_iff_le_prod_ne (a b : ℤ) : a < b ↔ (a ≤ b × a ≠ b) :=
+iff.intro
+  (assume H, pair (le_of_lt H) (int.ne_of_lt H))
+  (assume H,
+    have a ≤ b, from prod.pr1 H,
+    have a ≠ b, from prod.pr2 H,
+    obtain (n : ℕ) (Hn : a + n = b), from le.elim `a ≤ b`,
+    have n ≠ 0, from (assume H' : n = 0, `a ≠ b` (!add_zero ▸ H' ▸ Hn)),
+    obtain (k : ℕ) (Hk : n = nat.succ k), from nat.exists_eq_succ_of_ne_zero this,
+    lt.intro (Hk ▸ Hn))
+
+protected theorem le_iff_lt_sum_eq (a b : ℤ) : a ≤ b ↔ (a < b ⊎ a = b) :=
+iff.intro
+  (assume H,
+    by_cases
+      (suppose a = b, sum.inr this)
+      (suppose a ≠ b,
+        obtain (n : ℕ) (Hn : a + n = b), from le.elim H,
+        have n ≠ 0, from (assume H' : n = 0, `a ≠ b` (!add_zero ▸ H' ▸ Hn)),
+        obtain (k : ℕ) (Hk : n = nat.succ k), from nat.exists_eq_succ_of_ne_zero this,
+        sum.inl (lt.intro (Hk ▸ Hn))))
+  (assume H,
+    sum.elim H
+      (assume H1, le_of_lt H1)
+      (assume H1, H1 ▸ !int.le_refl))
+
+theorem lt_succ (a : ℤ) : a < a + 1 :=
+int.le_refl (a + 1)
+
+protected theorem add_le_add_left {a b : ℤ} (H : a ≤ b) (c : ℤ) : c + a ≤ c + b :=
+obtain (n : ℕ) (Hn : a + n = b), from le.elim H,
+have H2 : c + a + n = c + b, from
+  calc
+    c + a + n = c + (a + n) : add.assoc c a n
+      ... = c + b : {Hn},
+le.intro H2
+
+protected theorem add_lt_add_left {a b : ℤ} (H : a < b) (c : ℤ) : c + a < c + b :=
+let H' := le_of_lt H in
+(iff.mpr (int.lt_iff_le_prod_ne _ _)) (pair (int.add_le_add_left H' _)
+                                  (take Heq, let Heq' := add_left_cancel Heq in
+                                   !int.lt_irrefl (Heq' ▸ H)))
+
+protected theorem mul_nonneg {a b : ℤ} (Ha : 0 ≤ a) (Hb : 0 ≤ b) : 0 ≤ a * b :=
+obtain (n : ℕ) (Hn : 0 + n = a), from le.elim Ha,
+obtain (m : ℕ) (Hm : 0 + m = b), from le.elim Hb,
+le.intro
+  (inverse
+    (calc
+      a * b = (0 + n) * b : by rewrite Hn
+        ... = n * b       : by rewrite zero_add
+        ... = n * (0 + m) : by rewrite Hm
+        ... = n * m       : by rewrite zero_add
+        ... = 0 + n * m   : by rewrite zero_add))
+
+protected theorem mul_pos {a b : ℤ} (Ha : 0 < a) (Hb : 0 < b) : 0 < a * b :=
+obtain (n : ℕ) (Hn : 0 + nat.succ n = a), from lt.elim Ha,
+obtain (m : ℕ) (Hm : 0 + nat.succ m = b), from lt.elim Hb,
+lt.intro
+  (inverse
+    (calc
+      a * b = (0 + nat.succ n) * b                     : by rewrite Hn
+        ... = nat.succ n * b                           : by rewrite zero_add
+        ... = nat.succ n * (0 + nat.succ m)            : by rewrite Hm
+        ... = nat.succ n * nat.succ m                  : by rewrite zero_add
+        ... = of_nat (nat.succ n * nat.succ m)         : by rewrite of_nat_mul
+        ... = of_nat (nat.succ n * m + nat.succ n)     : by rewrite nat.mul_succ
+        ... = of_nat (nat.succ (nat.succ n * m + n))   : by rewrite nat.add_succ
+        ... = 0 + nat.succ (nat.succ n * m + n)        : by rewrite zero_add))
+
+protected theorem zero_lt_one : (0 : ℤ) < 1 := star
+
+protected theorem not_le_of_gt {a b : ℤ} (H : a < b) : ¬ b ≤ a :=
+  assume Hba,
+  let Heq := int.le_antisymm (le_of_lt H) Hba in
+  !int.lt_irrefl (Heq ▸ H)
+
+protected theorem lt_of_lt_of_le {a b c : ℤ} (Hab : a < b) (Hbc : b ≤ c) : a < c :=
+  let Hab' := le_of_lt Hab in
+  let Hac := int.le_trans Hab' Hbc in
+  (iff.mpr !int.lt_iff_le_prod_ne) (pair Hac
+    (assume Heq, int.not_le_of_gt (Heq ▸ Hab) Hbc))
+
+protected theorem lt_of_le_of_lt  {a b c : ℤ} (Hab : a ≤ b) (Hbc : b < c) : a < c :=
+  let Hbc' := le_of_lt Hbc in
+  let Hac := int.le_trans Hab Hbc' in
+  (iff.mpr !int.lt_iff_le_prod_ne) (pair Hac
+    (assume Heq, int.not_le_of_gt (Heq⁻¹ ▸ Hbc) Hab))
+
+protected definition linear_ordered_comm_ring [trans_instance] :
+    linear_ordered_comm_ring int :=
+⦃linear_ordered_comm_ring, int.integral_domain,
+  le               := int.le,
+  le_refl          := int.le_refl,
+  le_trans         := @int.le_trans,
+  le_antisymm      := @int.le_antisymm,
+  lt               := int.lt,
+  le_of_lt         := @int.le_of_lt,
+  lt_irrefl        := int.lt_irrefl,
+  lt_of_lt_of_le   := @int.lt_of_lt_of_le,
+  lt_of_le_of_lt   := @int.lt_of_le_of_lt,
+  add_le_add_left  := @int.add_le_add_left,
+  mul_nonneg       := @int.mul_nonneg,
+  mul_pos          := @int.mul_pos,
+  le_iff_lt_sum_eq  := int.le_iff_lt_sum_eq,
+  le_total         := int.le_total,
+  zero_ne_one      := int.zero_ne_one,
+  zero_lt_one      := int.zero_lt_one,
+  add_lt_add_left  := @int.add_lt_add_left⦄
+
+protected definition decidable_linear_ordered_comm_ring [instance] :
+    decidable_linear_ordered_comm_ring int :=
+⦃decidable_linear_ordered_comm_ring,
+ int.linear_ordered_comm_ring,
+ decidable_lt := decidable_lt⦄
+
+/- more facts specific to int -/
+
+theorem of_nat_nonneg (n : ℕ) : 0 ≤ of_nat n := star
+
+theorem of_nat_pos {n : ℕ} (Hpos : #nat n > 0) : of_nat n > 0 :=
+of_nat_lt_of_nat_of_lt Hpos
+
+theorem of_nat_succ_pos (n : nat) : of_nat (nat.succ n) > 0 :=
+of_nat_pos !nat.succ_pos
+
+theorem exists_eq_of_nat {a : ℤ} (H : 0 ≤ a) : Σn : ℕ, a = of_nat n :=
+obtain (n : ℕ) (H1 : 0 + of_nat n = a), from le.elim H,
+sigma.mk n (!zero_add ▸ (H1⁻¹))
+
+theorem exists_eq_neg_of_nat {a : ℤ} (H : a ≤ 0) : Σn : ℕ, a = -(of_nat n) :=
+have -a ≥ 0, from iff.mpr !neg_nonneg_iff_nonpos H,
+obtain (n : ℕ) (Hn : -a = of_nat n), from exists_eq_of_nat this,
+sigma.mk n (eq_neg_of_eq_neg (Hn⁻¹))
+
+theorem of_nat_nat_abs_of_nonneg {a : ℤ} (H : a ≥ 0) : of_nat (nat_abs a) = a :=
+obtain (n : ℕ) (Hn : a = of_nat n), from exists_eq_of_nat H,
+Hn⁻¹ ▸ ap of_nat (nat_abs_of_nat n)
+
+theorem of_nat_nat_abs_of_nonpos {a : ℤ} (H : a ≤ 0) : of_nat (nat_abs a) = -a :=
+have -a ≥ 0, from iff.mpr !neg_nonneg_iff_nonpos H,
+calc
+  of_nat (nat_abs a) = of_nat (nat_abs (-a)) : nat_abs_neg
+                 ... = -a                    : of_nat_nat_abs_of_nonneg this
+
+theorem of_nat_nat_abs (b : ℤ) : nat_abs b = abs b :=
+sum.elim (le.total 0 b)
+  (assume H : b ≥ 0, of_nat_nat_abs_of_nonneg H ⬝ (abs_of_nonneg H)⁻¹)
+  (assume H : b ≤ 0, of_nat_nat_abs_of_nonpos H ⬝ (abs_of_nonpos H)⁻¹)
+
+theorem nat_abs_abs (a : ℤ) : nat_abs (abs a) = nat_abs a :=
+abs.by_cases rfl !nat_abs_neg
+
+theorem lt_of_add_one_le {a b : ℤ} (H : a + 1 ≤ b) : a < b :=
+obtain (n : nat) (H1 : a + 1 + n = b), from le.elim H,
+have a + succ n = b, by rewrite [-H1, add.assoc, add.comm 1],
+lt.intro this
+
+theorem add_one_le_of_lt {a b : ℤ} (H : a < b) : a + 1 ≤ b :=
+obtain (n : nat) (H1 : a + succ n = b), from lt.elim H,
+have a + 1 + n = b, by rewrite [-H1, add.assoc, add.comm 1],
+le.intro this
+
+theorem lt_add_one_of_le {a b : ℤ} (H : a ≤ b) : a < b + 1 :=
+lt_add_of_le_of_pos H star
+
+theorem le_of_lt_add_one {a b : ℤ} (H : a < b + 1) : a ≤ b :=
+have H1 : a + 1 ≤ b + 1, from add_one_le_of_lt H,
+le_of_add_le_add_right H1
+
+theorem sub_one_le_of_lt {a b : ℤ} (H : a ≤ b) : a - 1 < b :=
+lt_of_add_one_le (begin rewrite sub_add_cancel, exact H end)
+
+theorem lt_of_sub_one_le {a b : ℤ} (H : a - 1 < b) : a ≤ b :=
+!sub_add_cancel ▸ add_one_le_of_lt H
+
+theorem le_sub_one_of_lt {a b : ℤ} (H : a < b) : a ≤ b - 1 :=
+le_of_lt_add_one begin rewrite sub_add_cancel, exact H end
+
+theorem lt_of_le_sub_one {a b : ℤ} (H : a ≤ b - 1) : a < b :=
+!sub_add_cancel ▸ (lt_add_one_of_le H)
+
+theorem sign_of_succ (n : nat) : sign (nat.succ n) = 1 :=
+sign_of_pos (of_nat_pos !nat.succ_pos)
+
+theorem exists_eq_neg_succ_of_nat {a : ℤ} : a < 0 → Σm : ℕ, a = -[1+m] :=
+int.cases_on a
+  (take (m : nat) H, absurd (of_nat_nonneg m : 0 ≤ m) (not_le_of_gt H))
+  (take (m : nat) H, sigma.mk m rfl)
+
+theorem eq_one_of_mul_eq_one_right {a b : ℤ} (H : a ≥ 0) (H' : a * b = 1) : a = 1 :=
+have a * b > 0, by rewrite H'; apply star,
+have b > 0, from pos_of_mul_pos_left this H,
+have a > 0, from pos_of_mul_pos_right `a * b > 0` (le_of_lt `b > 0`),
+sum.elim (le_sum_gt a 1)
+  (suppose a ≤ 1,
+    show a = 1, from le.antisymm this (add_one_le_of_lt `a > 0`))
+  (suppose a > 1,
+    have a * b ≥ 2 * 1,
+      from mul_le_mul (add_one_le_of_lt `a > 1`) (add_one_le_of_lt `b > 0`) star H,
+    have empty, by rewrite [H' at this]; exact this,
+    empty.elim this)
+
+theorem eq_one_of_mul_eq_one_left {a b : ℤ} (H : b ≥ 0) (H' : a * b = 1) : b = 1 :=
+eq_one_of_mul_eq_one_right H (!mul.comm ▸ H')
+
+theorem eq_one_of_mul_eq_self_left {a b : ℤ} (Hpos : a ≠ 0) (H : b * a = a) : b = 1 :=
+eq_of_mul_eq_mul_right Hpos (H ⬝ (one_mul a)⁻¹)
+
+theorem eq_one_of_mul_eq_self_right {a b : ℤ} (Hpos : b ≠ 0) (H : b * a = b) : a = 1 :=
+eq_one_of_mul_eq_self_left Hpos (!mul.comm ▸ H)
+
+theorem eq_one_of_dvd_one {a : ℤ} (H : a ≥ 0) (H' : a ∣ 1) : a = 1 :=
+dvd.elim H'
+  (take b,
+    suppose 1 = a * b,
+    eq_one_of_mul_eq_one_right H this⁻¹)
+
+theorem exists_least_of_bdd {P : ℤ → Type} [HP : decidable_pred P]
+    (Hbdd : Σ b : ℤ, Π z : ℤ, z ≤ b → ¬ P z)
+        (Hinh : Σ z : ℤ, P z) : Σ lb : ℤ, P lb × (Π z : ℤ, z < lb → ¬ P z) :=
+  begin
+    cases Hbdd with [b, Hb],
+    cases Hinh with [elt, Helt],
+    existsi b + of_nat (least (λ n, P (b + of_nat n)) (nat.succ (nat_abs (elt - b)))),
+    have Heltb : elt > b, begin
+      apply lt_of_not_ge,
+      intro Hge,
+      apply (Hb _ Hge) Helt
+    end,
+    have H' : P (b + of_nat (nat_abs (elt - b))), begin
+      rewrite [of_nat_nat_abs_of_nonneg (int.le_of_lt (iff.mpr !sub_pos_iff_lt Heltb)),
+              add.comm, sub_add_cancel],
+      apply Helt
+    end,
+    apply pair,
+    apply least_of_lt _ !lt_succ_self H',
+    intros z Hz,
+    cases em (z ≤ b) with [Hzb, Hzb],
+    apply Hb _ Hzb,
+    let Hzb' := lt_of_not_ge Hzb,
+    let Hpos := iff.mpr !sub_pos_iff_lt Hzb',
+    have Hzbk : z = b + of_nat (nat_abs (z - b)),
+      by rewrite [of_nat_nat_abs_of_nonneg (int.le_of_lt Hpos), int.add_comm, sub_add_cancel],
+    have Hk : nat_abs (z - b) < least (λ n, P (b + of_nat n)) (nat.succ (nat_abs (elt - b))), begin
+     note Hz' := iff.mp !lt_add_iff_sub_lt_left Hz,
+     rewrite [-of_nat_nat_abs_of_nonneg (int.le_of_lt Hpos) at Hz'],
+     apply lt_of_of_nat_lt_of_nat Hz'
+    end,
+    let Hk' := not_le_of_gt Hk,
+    rewrite Hzbk,
+    apply λ p, mt (ge_least_of_lt _ p) Hk',
+    apply nat.lt_trans Hk,
+    apply least_lt _ !lt_succ_self H'
+  end
+
+theorem exists_greatest_of_bdd {P : ℤ → Type} [HP : decidable_pred P]
+    (Hbdd : Σ b : ℤ, Π z : ℤ, z ≥ b → ¬ P z)
+        (Hinh : Σ z : ℤ, P z) : Σ ub : ℤ, P ub × (Π z : ℤ, z > ub → ¬ P z) :=
+  begin
+    cases Hbdd with [b, Hb],
+    cases Hinh with [elt, Helt],
+    existsi b - of_nat (least (λ n, P (b - of_nat n)) (nat.succ (nat_abs (b - elt)))),
+    have Heltb : elt < b, begin
+      apply lt_of_not_ge,
+      intro Hge,
+      apply (Hb _ Hge) Helt
+    end,
+    have H' : P (b - of_nat (nat_abs (b - elt))), begin
+      rewrite [of_nat_nat_abs_of_nonneg (int.le_of_lt (iff.mpr !sub_pos_iff_lt Heltb)),
+              sub_sub_self],
+      apply Helt
+    end,
+    apply pair,
+    apply least_of_lt _ !lt_succ_self H',
+    intros z Hz,
+    cases em (z ≥ b) with [Hzb, Hzb],
+    apply Hb _ Hzb,
+    let Hzb' := lt_of_not_ge Hzb,
+    let Hpos := iff.mpr !sub_pos_iff_lt Hzb',
+    have Hzbk : z = b - of_nat (nat_abs (b - z)),
+      by rewrite [of_nat_nat_abs_of_nonneg (int.le_of_lt Hpos), sub_sub_self],
+    have Hk : nat_abs (b - z) < least (λ n, P (b - of_nat n)) (nat.succ (nat_abs (b - elt))), begin
+      note Hz' := iff.mp !lt_add_iff_sub_lt_left (iff.mpr !lt_add_iff_sub_lt_right Hz),
+      rewrite [-of_nat_nat_abs_of_nonneg (int.le_of_lt Hpos) at Hz'],
+      apply lt_of_of_nat_lt_of_nat Hz'
+    end,
+    let Hk' := not_le_of_gt Hk,
+    rewrite Hzbk,
+    apply λ p, mt (ge_least_of_lt _ p) Hk',
+    apply nat.lt_trans Hk,
+    apply least_lt _ !lt_succ_self H'
+  end
+
+end int

hott/types/lift.hlean

@@ -129,23 +129,34 @@ namespace lift
 
   definition is_embedding_lift [instance] : is_embedding lift :=
   begin
-    intro A A', fapply is_equiv.homotopy_closed,
-      exact to_inv !lift_eq_lift_equiv,
-      exact _,
+    intro A A', refine is_equiv_of_equiv_of_homotopy !lift_eq_lift_equiv⁻¹ᵉ _,
     { intro p, induction p,
       esimp [lift_eq_lift_equiv,equiv.trans,equiv.symm,eq_equiv_equiv],
       rewrite [equiv_of_eq_refl, lift_equiv_lift_refl],
       apply ua_refl}
   end
 
+  definition fiber_lift_functor {A B : Type} (f : A → B) (b : B) :
+    fiber (lift_functor f) (up b) ≃ fiber f b :=
+  begin
+    fapply equiv.MK: intro v; cases v with a p,
+    { cases a with a, exact fiber.mk a (inj' up p) },
+    { exact fiber.mk (up a) (ap up p) },
+    { apply ap (fiber.mk a), apply inj'_ap },
+    { cases a with a, esimp, apply ap (fiber.mk (up a)), apply ap_inj' }
+  end
+
+  definition lift_functor2 {A B C : Type} (f : A → B → C) (x : lift A) (y : lift B) : lift C :=
+  up (f (down x) (down y))
+
+  -- is_trunc_lift is defined in init.trunc
+
   definition plift [constructor] (A : pType.{u}) : pType.{max u v} :=
   pointed.MK (lift A) (up pt)
 
   definition plift_functor [constructor] {A B : Type*} (f : A →* B) : plift A →* plift B :=
   pmap.mk (lift_functor f) (ap up (respect_pt f))
 
-  -- is_trunc_lift is defined in init.trunc
-
   definition pup [constructor] {A : Type*} : A →* plift A :=
   pmap.mk up idp
 
@@ -164,15 +175,8 @@ namespace lift
   definition pequiv_plift [constructor] (A : Type*) : A ≃* plift A :=
   pequiv_of_equiv (equiv_lift A) idp
 
-  definition fiber_lift_functor {A B : Type} (f : A → B) (b : B) :
-    fiber (lift_functor f) (up b) ≃ fiber f b :=
-  begin
-    fapply equiv.MK: intro v; cases v with a p,
-    { cases a with a, exact fiber.mk a (eq_of_fn_eq_fn' up p) },
-    { exact fiber.mk (up a) (ap up p) },
-    { apply ap (fiber.mk a), apply eq_of_fn_eq_fn'_ap },
-    { cases a with a, esimp, apply ap (fiber.mk (up a)), apply ap_eq_of_fn_eq_fn' }
-  end
-
+  definition is_trunc_plift [instance] [priority 1450] (A : Type*) (n : ℕ₋₂)
+    [H : is_trunc n A] : is_trunc n (plift A) :=
+  is_trunc_lift A n
 
 end lift

hott/types/list.hlean

@@ -10,7 +10,7 @@ Some lemmas are commented out, their proofs need to be repaired when needed
 
 import .pointed .nat .pi
 
-open eq lift nat is_trunc pi pointed sum function prod option sigma algebra
+open eq lift nat is_trunc pi pointed sum function prod option sigma algebra prod.ops unit sigma.ops
 
 inductive list (T : Type) : Type :=
 | nil {} : list T
@@ -19,11 +19,12 @@ inductive list (T : Type) : Type :=
 definition pointed_list [instance] (A : Type) : pointed (list A) :=
 pointed.mk list.nil
 
+universe variable u
+
 namespace list
 notation h :: t  := cons h t
 notation `[` l:(foldr `, ` (h t, cons h t) nil `]`) := l
 
-universe variable u
 variable {T : Type.{u}}
 
 lemma cons_ne_nil (a : T) (l : list T) : a::l ≠ [] :=
@@ -744,7 +745,7 @@ attribute list.has_decidable_eq [instance]
 
 namespace list
 
-variables {A B C : Type}
+variables {A B C X : Type}
 /- map -/
 definition map (f : A → B) : list A → list B
 | []       := []
@@ -924,4 +925,94 @@ theorem foldr_append (f : A → B → B) : Π (b : B) (l₁ l₂ : list A), fold
 | b []      l₂ := rfl
 | b (a::l₁) l₂ := by rewrite [append_cons, *foldr_cons, foldr_append]
 
+definition foldl_homotopy {f g : A → B → A} (h : f ~2 g) (a : A) : foldl f a ~ foldl g a :=
+begin
+  intro bs, revert a, induction bs with b bs p: intro a, reflexivity, esimp [foldl],
+  exact p (f a b) ⬝ ap010 (foldl g) (h a b) bs
+end
+
+definition cons_eq_cons {x x' : X} {l l' : list X} (p : x::l = x'::l') : x = x' × l = l' :=
+begin
+  refine lift.down (list.no_confusion p _), intro q r, split, exact q, exact r
+end
+
+definition concat_neq_nil (x : X) (l : list X) : concat x l ≠ nil :=
+begin
+  intro p, cases l: cases p,
+end
+
+definition concat_eq_singleton {x x' : X} {l : list X} (p : concat x l = [x']) :
+  x = x' × l = [] :=
+begin
+  cases l with x₂ l,
+  { cases cons_eq_cons p with q r, subst q, split: reflexivity },
+  { exfalso, esimp [concat] at p, apply concat_neq_nil x l, revert p, generalize (concat x l),
+    intro l' p, cases cons_eq_cons p with q r, exact r }
+end
+
+definition foldr_concat (f : A → B → B) (b : B) (a : A) (l : list A) :
+  foldr f b (concat a l) = foldr f (f a b) l :=
+begin
+  induction l with a' l p, reflexivity, rewrite [concat_cons, foldr_cons, p]
+end
+
+definition iterated_prod (X : Type.{u}) (n : ℕ) : Type.{u} :=
+iterate (prod X) n (lift unit)
+
+definition is_trunc_iterated_prod {k : ℕ₋₂} {X : Type} {n : ℕ} (H : is_trunc k X) :
+  is_trunc k (iterated_prod X n) :=
+begin
+  induction n with n IH,
+  { apply is_trunc_of_is_contr, apply is_trunc_lift },
+  { exact @is_trunc_prod _ _ _ H IH }
+end
+
+definition list_of_iterated_prod {n : ℕ} (x : iterated_prod X n) : list X :=
+begin
+  induction n with n IH,
+  { exact [] },
+  { exact x.1::IH x.2 }
+end
+
+definition list_of_iterated_prod_succ {n : ℕ} (x : X) (xs : iterated_prod X n) :
+  @list_of_iterated_prod X (succ n) (x, xs) = x::list_of_iterated_prod xs :=
+by reflexivity
+
+definition iterated_prod_of_list (l : list X) : Σn, iterated_prod X n :=
+begin
+  induction l with x l IH,
+  { exact ⟨0, up ⋆⟩ },
+  { exact ⟨succ IH.1, (x, IH.2)⟩ }
+end
+
+definition iterated_prod_of_list_cons (x : X) (l : list X) :
+  iterated_prod_of_list (x::l) =
+  ⟨succ (iterated_prod_of_list l).1, (x, (iterated_prod_of_list l).2)⟩ :=
+by reflexivity
+
+protected definition sigma_char [constructor] (X : Type) : list X ≃ Σ(n : ℕ), iterated_prod X n :=
+begin
+  apply equiv.MK iterated_prod_of_list (λv, list_of_iterated_prod v.2),
+  { intro x, induction x with n x, esimp, induction n with n IH,
+    { induction x with x, induction x, reflexivity },
+    { revert x, change Π(x : X × iterated_prod X n), _, intro xs, cases xs with x xs,
+      rewrite [list_of_iterated_prod_succ, iterated_prod_of_list_cons],
+      apply sigma_eq (ap succ (IH xs)..1),
+      apply pathover_ap, refine prod_pathover _ _ _ _ (IH xs)..2,
+      apply pathover_of_eq, reflexivity }},
+  { intro l, induction l with x l IH,
+    { reflexivity },
+    { exact ap011 cons idp IH }}
+end
+
+local attribute [instance] is_trunc_iterated_prod
+definition is_trunc_list [instance] {n : ℕ₋₂} {X : Type} (H : is_trunc (n.+2) X) :
+  is_trunc (n.+2) (list X) :=
+begin
+  assert H : is_trunc (n.+2) (Σ(k : ℕ), iterated_prod X k),
+  { apply is_trunc_sigma, refine is_trunc_succ_succ_of_is_set _ _ _,
+    intro, exact is_trunc_iterated_prod H },
+  apply is_trunc_equiv_closed_rev _ (list.sigma_char X) _,
+end
+
 end list