move files from Spectral

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

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/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/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/function.hlean

@@ -42,6 +42,9 @@ 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))
@@ -171,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',
@@ -359,6 +370,20 @@ namespace function
     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
@@ -383,6 +408,32 @@ namespace function
       !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/homotopy/LES_of_homotopy_groups.hlean

@@ -724,6 +724,24 @@ namespace chain_complex
     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
 
   /-

hott/homotopy/connectedness.hlean

@@ -27,6 +27,13 @@ namespace is_conn
     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 :=
   is_contr_equiv_closed (trunc_trunc_equiv_left _ H) _
 
@@ -256,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 :=
   _
@@ -267,6 +275,26 @@ namespace is_conn
   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) :=
   is_contr_equiv_closed !trunc_trunc_equiv_trunc_trunc _
@@ -283,8 +311,60 @@ 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 :=
   _
@@ -292,6 +372,10 @@ namespace is_conn
   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) :=
@@ -303,10 +387,14 @@ 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
@@ -362,57 +450,6 @@ namespace is_conn
     rewrite -of_nat_add_two, exact _
   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_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_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 _
-
-  lemma is_conn_pfiber {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_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
@@ -545,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,
+  intro X Y, fapply is_equiv_of_equiv_of_homotopy,
-    note q := pType_eq_elim (eq_of_pequiv p),
+  { exact eq_equiv_fn_eq (pconntype.sigma_char k) _ _ ⬝e subtype_eq_equiv _ _ },
-    cases q with r s, esimp at *, induction r,
+  intro p, induction p, reflexivity
-    exact ap0111 (ptruncconntype.mk X) !is_prop.elim (eq_of_pathover_idp s) !is_prop.elim
 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/freudenthal.hlean

@@ -215,6 +215,17 @@ end
   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_susp_stability_pequiv_of_is_conn_0 (A : Type*) {k n : ℕ} [is_conn 0 A]
@@ -272,4 +283,5 @@ namespace susp
                  ptrunc_pequiv_ptrunc _ (loopn_pequiv_loopn _ !iterate_susp_succ_in)}
 end
 
+
 end susp

hott/init/equiv.hlean

@@ -407,6 +407,23 @@ namespace equiv
         ... = 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}

hott/init/trunc.hlean

@@ -314,7 +314,7 @@ namespace is_trunc
     (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] (HA : is_prop A) (HB : is_prop B) (H : A ↔ B) :
+  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) _ _
 

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

hott/types/fiber.hlean

@@ -138,7 +138,8 @@ namespace fiber
     begin intro x, induction x with a p, esimp at p, cases p, reflexivity end
 
   /- the general functoriality between fibers -/
-  -- todo: show that this is an equivalence if g and h are, and use that for the special cases below
+  -- 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' :=
@@ -175,6 +176,17 @@ namespace fiber
                 ... ≃ Σa b, f a = b : sigma_comm_equiv
                 ... ≃ A             : sigma_equiv_of_is_contr_right
 
+  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
   variable (f)
   protected definition equiv_postcompose [constructor] {B' : Type} (g : B ≃ B') --[H : is_equiv g]
@@ -198,7 +210,7 @@ namespace fiber
                 ... ≃ fiber f b                : fiber.sigma_char
 
   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 : k ∘ f ~ g ∘ h) (p : k b = d) : fiber f b ≃ fiber g 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
@@ -208,6 +220,14 @@ namespace fiber
     (s : f ~ g ∘ h) : fiber f b ≃ fiber g b :=
   fiber_equiv_of_square h erfl s idp
 
+  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
     fapply equiv.MK,
@@ -435,7 +455,7 @@ namespace fiber
   end
 
   definition is_contr_pfiber_pid (A : Type*) : is_contr (pfiber (pid A)) :=
-  is_contr_fiber_id A pt
+  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' :=
@@ -470,3 +490,7 @@ 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

@@ -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)
+definition lift [constructor] (x : fin n) (m : ℕ) : fin (n + m) :=
-| (mk v h) m := mk v (lt_add_of_lt_right h m)
+fin.mk x (lt_add_of_lt_right (is_lt x) m)
 
-definition lift_succ [constructor] (i : fin n) : fin (nat.succ n) :=
+definition lift_succ [constructor] ⦃n : ℕ⦄ (x : fin n) : fin (nat.succ n) :=
-have r : fin (n+1), from lift i 1,
+fin.mk x (le.step (is_lt x))
-r
 
 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,
+        fapply veq_of_eq, apply @is_injective_of_is_embedding _ _ f,
-        apply @is_injective_of_is_embedding _ _ lift_succ _ _ _ Peq,
+        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,
+    apply ap (λx, eq.rec_on x _), apply ap02, apply is_prop_elim_self },
-      by apply is_prop.elim,
-    krewrite H' },
   { 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

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

hott/types/pi.hlean

@@ -263,6 +263,15 @@ namespace pi
     { intro f, apply eq_of_homotopy, intro b, induction b: reflexivity},
   end
 
+  definition pi_bool_left_natural {A B : bool → Type} (g : Πx, A x → B x) :
+    hsquare (pi_bool_left A) (pi_bool_left B) (pi_functor_right g) (prod_functor (g ff) (g tt)) :=
+  begin intro h, esimp end
+
+  definition pi_bool_left_inv_natural {A B : bool → Type} (g : Πx, A x → B x) :
+    hsquare (pi_bool_left A)⁻¹ᵉ (pi_bool_left B)⁻¹ᵉ
+            (prod_functor (g ff) (g tt)) (pi_functor_right g) :=
+  (pi_bool_left_natural g)⁻¹ʰᵗʸʰ
+
   /- Truncatedness: any dependent product of n-types is an n-type -/
 
   theorem is_trunc_pi (B : A → Type) (n : trunc_index)

hott/types/pointed.hlean

@@ -341,6 +341,10 @@ namespace pointed
 
   /- equalities and equivalences relating pointed homotopies -/
 
+  definition to_homotopy_pt_mk {A B : Type*} {f g : A →* B} (h : f ~ g)
+    (p : h pt ⬝ respect_pt g = respect_pt f) : to_homotopy_pt (phomotopy.mk h p) = p :=
+  to_right_inv !eq_con_inv_equiv_con_eq p
+
   definition phomotopy.rec' [recursor] (B : k ~* l → Type)
     (H : Π(h : k ~ l) (p : h pt ⬝ respect_pt l = respect_pt k), B (phomotopy.mk h p))
     (h : k ~* l) : B h :=
@@ -353,8 +357,8 @@ namespace pointed
   definition phomotopy.eta_expand [constructor] (p : k ~* l) : k ~* l :=
   phomotopy.mk p (to_homotopy_pt p)
 
-  definition is_trunc_ppi [instance] (n : ℕ₋₂) {A : Type*} (B : A → Type) (b₀ : B pt) [Πa, is_trunc n (B a)] :
+  definition is_trunc_ppi [instance] (n : ℕ₋₂) {A : Type*} (B : A → Type) (b₀ : B pt)
-    is_trunc n (ppi B b₀) :=
+    [Πa, is_trunc n (B a)] : is_trunc n (ppi B b₀) :=
   is_trunc_equiv_closed_rev _ !ppi.sigma_char _
 
   definition is_trunc_pmap [instance] (n : ℕ₋₂) (A B : Type*) [is_trunc n B] :
@@ -1108,6 +1112,9 @@ namespace pointed
   definition pointed_eta_pequiv [constructor] (A : Type*) : A ≃* pointed.MK A pt :=
   pequiv.mk id !is_equiv_id idp
 
+  definition pbool_pequiv_add_point_unit [constructor] : pbool ≃* unit₊ :=
+  pequiv_of_equiv (bool_equiv_option_unit) idp
+
   /- every pointed map is homotopic to one of the form `pmap_of_map _ _`, up to some
      pointed equivalences -/
   definition phomotopy_pmap_of_map {A B : Type*} (f : A →* B) :

hott/types/pointed2.hlean

@@ -1,7 +1,7 @@
 /-
 Copyright (c) 2017 Floris van Doorn. All rights reserved.
 Released under Apache 2.0 license as described in the file LICENSE.
-Authors: Floris van Doorn
+Authors: Floris van Doorn, Yuri Sulyma
 
 More results about pointed types.
 
@@ -15,7 +15,7 @@ Contains
 
 import eq2 .unit
 
-open pointed eq unit is_trunc trunc nat is_equiv equiv sigma function bool sigma.ops
+open pointed eq unit is_trunc trunc nat is_equiv equiv sigma function bool sigma.ops fiber
 
 namespace pointed
   variables {A B C : Type*} {P : A → Type} {p₀ : P pt} {k k' l m n : ppi P p₀}
@@ -758,6 +758,24 @@ namespace pointed
     ap1_gen_const (g b) p :=
   begin induction p, reflexivity end
 
+  definition ap1_phomotopy_symm {A B : Type*} {f g : A →* B} (p : f ~* g) : (Ω⇒ p)⁻¹* = Ω⇒ (p⁻¹*) :=
+  begin
+    induction p using phomotopy_rec_idp,
+    rewrite ap1_phomotopy_refl,
+    xrewrite [+refl_symm],
+    rewrite ap1_phomotopy_refl
+  end
+
+  definition ap1_phomotopy_trans {A B : Type*} {f g h : A →* B} (q : g ~* h) (p : f ~* g) :
+    Ω⇒ (p ⬝* q) = Ω⇒ p ⬝* Ω⇒ q :=
+  begin
+    induction p using phomotopy_rec_idp,
+    induction q using phomotopy_rec_idp,
+    rewrite trans_refl,
+    rewrite [+ap1_phomotopy_refl],
+    rewrite trans_refl
+  end
+
   definition ap1_pcompose_pconst_left {A B C : Type*} (f : A →* B) :
     phsquare (ap1_pcompose (pconst B C) f)
              (ap1_pconst A C)

hott/types/prod.hlean

@@ -173,6 +173,8 @@ namespace prod
   definition prod_functor [unfold 7] (u : A × B) : A' × B' :=
   (f u.1, g u.2)
 
+  infix ` ×→ `:63 := prod_functor
+
   definition ap_prod_functor (p : u.1 = v.1) (q : u.2 = v.2)
     : ap (prod_functor f g) (prod_eq p q) = prod_eq (ap f p) (ap g q) :=
   by induction u; induction v; esimp at *; induction p; induction q; reflexivity
@@ -213,12 +215,12 @@ namespace prod
   definition prod_equiv_prod [constructor] (f : A ≃ A') (g : B ≃ B') : A × B ≃ A' × B' :=
   equiv.mk (prod_functor f g) _
 
-  -- rename
+  infix ` ×≃ `:63 := prod_equiv_prod
-  definition prod_equiv_prod_left [constructor] (g : B ≃ B') : A × B ≃ A × B' :=
+
+  definition prod_equiv_prod_right [constructor] (g : B ≃ B') : A × B ≃ A × B' :=
   prod_equiv_prod equiv.rfl g
 
-  -- rename
+  definition prod_equiv_prod_left [constructor] (f : A ≃ A') : A × B ≃ A' × B :=
-  definition prod_equiv_prod_right [constructor] (f : A ≃ A') : A × B ≃ A' × B :=
   prod_equiv_prod f equiv.rfl
 
   /- Symmetry -/
@@ -340,5 +342,7 @@ namespace prod
   definition pprod_functor [constructor] {A B C D : Type*} (f : A →* C) (g : B →* D) : A ×* B →* C ×* D :=
   pmap.mk (prod_functor f g) (prod_eq (respect_pt f) (respect_pt g))
 
+  definition pprod_incl1 [constructor] (X Y : Type*) : X →* X ×* Y := pmap.mk (λx, (x, pt)) idp
+  definition pprod_incl2 [constructor] (X Y : Type*) : Y →* X ×* Y := pmap.mk (λy, (pt, y)) idp
 
 end prod

hott/types/sum.hlean

@@ -114,6 +114,8 @@ namespace sum
   | sum_functor (inl a) := inl (f a)
   | sum_functor (inr b) := inr (g b)
 
+  infix ` +→ `:62 := sum_functor
+
   /- Equivalences -/
 
   definition is_equiv_sum_functor [constructor] [instance] [Hf : is_equiv f] [Hg : is_equiv g]
@@ -136,6 +138,8 @@ namespace sum
   definition sum_equiv_sum [constructor] (f : A ≃ A') (g : B ≃ B') : A + B ≃ A' + B' :=
   equiv.mk _ (is_equiv_sum_functor f g)
 
+  infix ` +≃ `:62 := sum_equiv_sum
+
   definition sum_equiv_sum_left [constructor] (g : B ≃ B') : A + B ≃ A + B' :=
   sum_equiv_sum equiv.rfl g
 
@@ -146,13 +150,11 @@ namespace sum
   | flip (inl a) := inr a
   | flip (inr b) := inl b
 
+  definition flip_flip (x : A ⊎ B) : flip (flip x) = x :=
+  begin induction x: reflexivity end
+
   definition sum_comm_equiv [constructor] (A B : Type) : A + B ≃ B + A :=
-  begin
+  equiv.MK flip flip flip_flip flip_flip
-    fapply equiv.MK,
-      exact flip,
-      exact flip,
-      all_goals (intro z; induction z; all_goals reflexivity)
-  end
 
   definition sum_assoc_equiv [constructor] (A B C : Type) : A + (B + C) ≃ (A + B) + C :=
   begin
@@ -211,7 +213,7 @@ namespace sum
   variables (H : unit + A ≃ unit + B)
   include H
 
-  open unit decidable sigma.ops
+  open unit sigma.ops
 
   definition unit_sum_equiv_cancel_map : A → B :=
   begin
@@ -306,8 +308,7 @@ namespace sum
 
   /- truncatedness -/
 
-  variables (A B)
+  theorem is_trunc_sum (n : ℕ₋₂) (A B : Type) [HA : is_trunc (n.+2) A]  [HB : is_trunc (n.+2) B]
-  theorem is_trunc_sum (n : trunc_index) [HA : is_trunc (n.+2) A]  [HB : is_trunc (n.+2) B]
     : is_trunc (n.+2) (A + B) :=
   begin
     apply is_trunc_succ_intro, intro z z',
@@ -316,7 +317,7 @@ namespace sum
     all_goals exact _,
   end
 
-  theorem is_trunc_sum_excluded (n : trunc_index) [HA : is_trunc n A]  [HB : is_trunc n B]
+  theorem is_trunc_sum_excluded (n : ℕ₋₂) (A B : Type) [HA : is_trunc n A]  [HB : is_trunc n B]
     (H : A → B → empty) : is_trunc n (A + B) :=
   begin
     induction n with n IH,
@@ -328,8 +329,8 @@ namespace sum
       { apply is_trunc_sum}}
   end
 
-  variable {B}
+  definition is_contr_sum_left (A : Type) {B : Type} [HA : is_contr A] (H : ¬B) :
-  definition is_contr_sum_left [HA : is_contr A] (H : ¬B) : is_contr (A + B) :=
+    is_contr (A + B) :=
   is_contr.mk (inl !center)
               (λx, sum.rec_on x (λa, ap inl !center_eq) (λb, empty.elim (H b)))
 
@@ -353,6 +354,35 @@ namespace sum
            begin intro v, induction v with b x, induction b, all_goals reflexivity end
            begin intro z, induction z with a b, all_goals reflexivity end
 
+  variables {A₀₀ A₂₀ A₀₂ A₂₂ B₀₀ B₂₀ B₀₂ B₂₂ C C' : Type}
+    {f₁₀ : A₀₀ → A₂₀} {f₁₂ : A₀₂ → A₂₂} {f₀₁ : A₀₀ → A₀₂} {f₂₁ : A₂₀ → A₂₂}
+    {g₁₀ : B₀₀ → B₂₀} {g₁₂ : B₀₂ → B₂₂} {g₀₁ : B₀₀ → B₀₂} {g₂₁ : B₂₀ → B₂₂}
+    {h₀₁ : B₀₀ → A₀₂} {h₂₁ : B₂₀ → A₂₂}
+  open function
+
+  definition sum_rec_hsquare [unfold 16] (h : hsquare f₁₀ f₁₂ f₀₁ f₂₁)
+    (k : hsquare g₁₀ f₁₂ h₀₁ h₂₁) : hsquare (f₁₀ +→ g₁₀) f₁₂ (sum.rec f₀₁ h₀₁) (sum.rec f₂₁ h₂₁) :=
+  begin intro x, induction x with a b, exact h a, exact k b end
+
+  definition sum_functor_hsquare [unfold 19] (h : hsquare f₁₀ f₁₂ f₀₁ f₂₁)
+    (k : hsquare g₁₀ g₁₂ g₀₁ g₂₁) : hsquare (f₁₀ +→ g₁₀) (f₁₂ +→ g₁₂) (f₀₁ +→ g₀₁) (f₂₁ +→ g₂₁) :=
+  sum_rec_hsquare (λa, ap inl (h a)) (λb, ap inr (k b))
+
+  definition sum_functor_compose (g : B → C) (f : A → B) (g' : B' → C') (f' : A' → B') :
+    (g ∘ f) +→ (g' ∘ f') ~ g +→ g' ∘ f +→ f' :=
+  begin intro x, induction x with a a': reflexivity end
+
+  definition sum_rec_sum_functor (g : B → C) (g' : B' → C) (f : A → B) (f' : A' → B') :
+    sum.rec g g' ∘ sum_functor f f' ~ sum.rec (g ∘ f) (g' ∘ f') :=
+  begin intro x, induction x with a a': reflexivity end
+
+  definition sum_rec_same_compose (g : B → C) (f : A → B) :
+    sum.rec (g ∘ f) (g ∘ f) ~ g ∘ sum.rec f f :=
+  begin intro x, induction x with a a': reflexivity end
+
+  definition sum_rec_same (f : A → B) : sum.rec f f ~ f ∘ sum.rec id id :=
+  by exact sum_rec_same_compose f id
+
   /- pointed sums. We arbitrarily choose (inl pt) as basepoint for the sum -/
 
   open pointed
@@ -367,13 +397,15 @@ open sum pi
 
 namespace decidable
 
+  /- some properties about the inductive type `decidable`
+     decidable A is equivalent to A + ¬A -/
   definition decidable_equiv [constructor] (A : Type) : decidable A ≃ A + ¬A :=
   begin
     fapply equiv.MK:intro a;induction a:try (constructor;assumption;now),
     all_goals reflexivity
   end
 
-  definition is_trunc_decidable [constructor] (A : Type) (n : trunc_index) [H : is_trunc n A] :
+  definition is_trunc_decidable [constructor] (A : Type) (n : ℕ₋₂) [H : is_trunc n A] :
     is_trunc n (decidable A) :=
   begin
     apply is_trunc_equiv_closed_rev,
@@ -383,11 +415,60 @@ namespace decidable
     { apply is_trunc_sum_excluded, exact λa na, na a}
   end
 
+  definition double_neg_elim {A : Type} (H : decidable A) (p : ¬ ¬ A) : A :=
+  begin induction H, assumption, contradiction end
+
+  definition dite_true {C : Type} [H : decidable C] {A : Type}
+    {t : C → A} {e : ¬ C → A} (c : C) (H' : is_prop C) : dite C t e = t c :=
+  begin
+    induction H with H H,
+    exact ap t !is_prop.elim,
+    contradiction
+  end
+
+  definition dite_false {C : Type} [H : decidable C] {A : Type}
+    {t : C → A} {e : ¬ C → A} (c : ¬ C) : dite C t e = e c :=
+  begin
+    induction H with H H,
+    contradiction,
+    exact ap e !is_prop.elim,
+  end
+
+  definition decidable_eq_of_is_prop (A : Type) [is_prop A] : decidable_eq A :=
+  λa a', decidable.inl !is_prop.elim
+
+  definition decidable_eq_sigma [instance] {A : Type} (B : A → Type) [HA : decidable_eq A]
+    [HB : Πa, decidable_eq (B a)] : decidable_eq (Σa, B a) :=
+  begin
+    intro v v', induction v with a b, induction v' with a' b',
+    cases HA a a' with p np,
+    { induction p, cases HB a b b' with q nq,
+        induction q, exact decidable.inl idp,
+        apply decidable.inr, intro p, apply nq, apply @eq_of_pathover_idp A B,
+        exact change_path !is_prop.elim p..2 },
+    { apply decidable.inr, intro p, apply np, exact p..1 }
+  end
+
+  open sum
+  definition decidable_eq_sum [instance] (A B : Type) [HA : decidable_eq A] [HB : decidable_eq B] :
+    decidable_eq (A ⊎ B) :=
+  begin
+    intro v v', induction v with a b: induction v' with a' b',
+    { cases HA a a' with p np,
+      { exact decidable.inl (ap sum.inl p) },
+      { apply decidable.inr, intro p,  apply np, exact down (sum.encode p) }},
+    { apply decidable.inr, intro p, cases p },
+    { apply decidable.inr, intro p, cases p },
+    { cases HB b b' with p np,
+      { exact decidable.inl (ap sum.inr p) },
+      { apply decidable.inr, intro p, apply np, exact down (sum.encode p) }},
+  end
+
 end decidable
 
 attribute sum.is_trunc_sum [instance] [priority 1480]
 
-definition tsum [constructor] {n : trunc_index} (A B : (n.+2)-Type) : (n.+2)-Type :=
+definition tsum [constructor] {n : ℕ₋₂} (A B : (n.+2)-Type) : (n.+2)-Type :=
 trunctype.mk (A + B) _
 
 infixr `+t`:25 := tsum

hott/types/trunc.hlean

@@ -1087,6 +1087,7 @@ end eq
 
 /- some consequences for properties about functions (surjectivity etc.) -/
 namespace function
+  open fiber
   variables {A B : Type}
   definition is_surjective_of_is_equiv [instance] (f : A → B) [H : is_equiv f] : is_surjective f :=
   λb, begin esimp, apply center, apply is_trunc_trunc_of_is_trunc end