From 183ca62cc1b044af8c69e89f924112ae8b061882 Mon Sep 17 00:00:00 2001
From: Floris van Doorn <fpv@andrew.cmu.edu>
Date: Fri, 14 Sep 2018 19:32:02 +0200
Subject: [PATCH] reverse sigma_assoc_equiv, and add variant

---
 hott/types/sigma.hlean | 38 ++++++++++++++++++++++++++++++--------
 1 file changed, 30 insertions(+), 8 deletions(-)

diff --git a/hott/types/sigma.hlean b/hott/types/sigma.hlean
index 4b827af04..73d8e82f5 100644
--- a/hott/types/sigma.hlean
+++ b/hott/types/sigma.hlean
@@ -415,12 +415,16 @@ namespace sigma
 
   --this proof is harder than in Coq because we don't have eta definitionally for sigma
   definition sigma_assoc_equiv [constructor] (C : (Σa, B a) → Type)
-    : (Σa b, C ⟨a, b⟩) ≃ (Σu, C u) :=
+    : (Σu, C u) ≃ (Σa b, C ⟨a, b⟩) :=
   equiv.mk _ (adjointify
+    (λuc, ⟨uc.1.1, uc.1.2, transport C (sigma.eta uc.1)⁻¹ uc.2⟩)
     (λav, ⟨⟨av.1, av.2.1⟩, av.2.2⟩)
-    (λuc, ⟨uc.1.1, uc.1.2, !sigma.eta⁻¹ ▸ uc.2⟩)
-    abstract begin intro uc, induction uc with u c, induction u, reflexivity end end
-    abstract begin intro av, induction av with a v, induction v, reflexivity end end)
+    abstract begin intro av, induction av with a v, induction v, reflexivity end end
+    abstract begin intro uc, induction uc with u c, induction u, reflexivity end end)
+
+  definition sigma_assoc_equiv' [constructor] (C : Πa, B a → Type)
+    : (Σa b, C a b) ≃ (Σu, C u.1 u.2) :=
+  !sigma_assoc_equiv⁻¹ᵉ
 
   open prod prod.ops
   definition assoc_equiv_prod [constructor] (C : (A × A') → Type) : (Σa a', C (a,a')) ≃ (Σu, C u) :=
@@ -430,6 +434,14 @@ namespace sigma
     abstract proof (λuc, destruct uc (λu, prod.destruct u (λa b c, idp))) qed end
     abstract proof (λav, destruct av (λa v, destruct v (λb c, idp))) qed end)
 
+  definition sigma_assoc_equiv_left {A D : Type} {B : A → Type} {E : D → Type} (C : Πa, B a → Type)
+    (f : (Σd, E d) ≃ Σa, B a) : (Σa b, C a b) ≃ Σd e, C (f ⟨d, e⟩).1 (f ⟨d, e⟩).2 :=
+  begin
+    refine !sigma_assoc_equiv' ⬝e _,
+    refine sigma_equiv_sigma_left f⁻¹ᵉ ⬝e _,
+    exact !sigma_assoc_equiv,
+  end
+
   /- Symmetry -/
 
   definition comm_equiv_unc (C : A × A' → Type) : (Σa a', C (a, a')) ≃ (Σa' a, C (a, a')) :=
@@ -520,21 +532,31 @@ namespace sigma
     { intro v, induction v with a p, induction p: reflexivity},
   end
 
-  definition sigma_sigma_eq_right {A : Type} (a : A) (P : Π(b : A), a = b → Type)
+  definition sigma_sigma_eq_right (a : A) (P : Π(b : A), a = b → Type)
     : (Σ(b : A) (p : a = b), P b p) ≃ P a idp :=
   calc
     (Σ(b : A) (p : a = b), P b p) ≃ (Σ(v : Σ(b : A), a = b), P v.1 v.2) : sigma_assoc_equiv
       ... ≃ P a idp : sigma_equiv_of_is_contr_left _ _
 
-  definition sigma_sigma_eq_left {A : Type} (a : A) (P : Π(b : A), b = a → Type)
+  definition sigma_sigma_eq_left (a : A) (P : Π(b : A), b = a → Type)
     : (Σ(b : A) (p : b = a), P b p) ≃ P a idp :=
   calc
     (Σ(b : A) (p : b = a), P b p) ≃ (Σ(v : Σ(b : A), b = a), P v.1 v.2) : sigma_assoc_equiv
       ... ≃ P a idp : sigma_equiv_of_is_contr_left _ _
 
-  definition sigma_assoc_equiv_of_is_contr_left [constructor] (C : (Σa, B a) → Type)
+  definition sigma_assoc_equiv_of_is_contr_left (C : (Σa, B a) → Type)
     (H : is_contr (Σa, B a)) : (Σa b, C ⟨a, b⟩) ≃ C (@center _ H) :=
-  sigma_assoc_equiv C ⬝e !sigma_equiv_of_is_contr_left
+  (sigma_assoc_equiv C)⁻¹ᵉ ⬝e !sigma_equiv_of_is_contr_left
+
+  definition sigma_homotopy_constant_equiv {A B : Type} (a₀ : A) (f : A → B) :
+    (Σ(b : B), Πa, f a = b) ≃ Σ(h : Πa, f a = f a₀), h a₀ = idp :=
+  begin
+    transitivity Σ(b : B) (h : Πa, f a = b) (p : f a₀ = b), h a₀ = p,
+    { symmetry, apply sigma_equiv_sigma_right, intro b, apply sigma_equiv_of_is_contr_right,
+      intro h, apply is_trunc.is_contr_sigma_eq },
+    { refine sigma_equiv_sigma_right (λb, !sigma_comm_equiv) ⬝e _,
+      exact sigma_sigma_eq_right _ (λb p, Σ(h : Πa, f a = b), h a₀ = p) }
+  end
 
   /- ** Universal mapping properties -/
   /- *** The positive universal property. -/