start on torus = S^1 x S^1

homotopy/torus.hlean

@@ -0,0 +1,80 @@
+import homotopy.torus
+
+open eq circle prod prod.ops function
+
+namespace torus
+
+  definition S1xS1_of_torus [unfold 1] (x : T²) : S¹ × S¹ :=
+  begin
+    induction x,
+    { exact (circle.base, circle.base) },
+    { exact prod_eq loop idp },
+    { exact prod_eq idp loop },
+    { apply square_of_eq,
+      exact !prod_eq_concat ⬝ ap011 prod_eq !idp_con⁻¹ !idp_con ⬝ !prod_eq_concat⁻¹ }
+  end
+
+  definition torus_of_S1xS1 [unfold 1] (x : S¹ × S¹) : T² :=
+  begin
+    induction x with x y, induction x,
+    { induction y,
+      { exact base },
+      { exact loop2 }},
+    { induction y,
+      { exact loop1 },
+      { apply eq_pathover, refine !elim_loop ⬝ph surf ⬝hp !elim_loop⁻¹ }}
+  end
+
+  definition to_from_base_left [unfold 1] (y : S¹) :
+    S1xS1_of_torus (torus_of_S1xS1 (circle.base, y)) = (circle.base, y) :=
+  begin
+    induction y,
+    { reflexivity },
+    { apply eq_pathover, apply hdeg_square,
+      refine ap_compose S1xS1_of_torus _ _ ⬝ ap02 _ !elim_loop ⬝ _ ⬝ !ap_prod_mk_right⁻¹,
+      apply elim_loop2 }
+  end
+
+  definition from_to_loop1
+    : pathover (λa, torus_of_S1xS1 (S1xS1_of_torus a) = a) proof idp qed loop1 proof idp qed :=
+  begin
+    apply eq_pathover, apply hdeg_square,
+    refine ap_compose torus_of_S1xS1 _ _ ⬝ ap02 _ !elim_loop1 ⬝ _ ⬝ !ap_id⁻¹,
+    refine !ap_prod_elim ⬝ !idp_con ⬝ !elim_loop
+  end
+
+  definition from_to_loop2
+    : pathover (λa, torus_of_S1xS1 (S1xS1_of_torus a) = a) proof idp qed loop2 proof idp qed :=
+  begin
+    apply eq_pathover, apply hdeg_square,
+    refine ap_compose torus_of_S1xS1 _ _ ⬝ ap02 _ !elim_loop2 ⬝ _ ⬝ !ap_id⁻¹,
+    refine !ap_prod_elim ⬝ !elim_loop
+  end
+
+  definition torus_equiv_S1xS1 : T² ≃ S¹ × S¹ :=
+  begin
+    fapply equiv.MK,
+    { exact S1xS1_of_torus },
+    { exact torus_of_S1xS1 },
+    { intro x, induction x with x y, induction x,
+      { exact to_from_base_left y },
+      { apply eq_pathover,
+        refine ap_compose (S1xS1_of_torus ∘ torus_of_S1xS1) _ _ ⬝ph _,
+        refine ap02 _ !ap_prod_mk_left ⬝ph _ ⬝hp !ap_prod_mk_left⁻¹,
+        refine !ap_compose ⬝ ap02 _ (!ap_prod_elim ⬝ !idp_con) ⬝ph _,
+        refine ap02 _ !elim_loop ⬝ph _,
+        induction y,
+        { apply hdeg_square, apply elim_loop1 },
+        { apply square_pathover, exact sorry }
+        -- apply square_of_eq, induction y,
+        -- { refine !idp_con ⬝ !elim_loop1⁻¹ },
+        -- { apply eq_pathover_dep, }
+        }},
+    { intro x, induction x,
+      { reflexivity },
+      { exact from_to_loop1 },
+      { exact from_to_loop2 },
+      { exact sorry }}
+  end
+
+end torus

move_to_lib.hlean

@@ -192,11 +192,6 @@ end is_equiv
 
 namespace prod
 
-  definition ap_prod_elim {A B C : Type} {a a' : A} {b b' : B} (m : A → B → C)
-    (p : a = a') (q : b = b') : ap (prod.rec m) (prod_eq p q)
-    = (ap (m a) q) ⬝ (ap (λx : A, m x b') p) :=
-  by cases p; cases q; constructor
-
   open prod.ops
   definition prod_pathover_equiv {A : Type} {B C : A → Type} {a a' : A} (p : a = a')
     (x : B a × C a) (x' : B a' × C a') : x =[p] x' ≃ x.1 =[p] x'.1 × x.2 =[p] x'.2 :=