diff --git a/homotopy/torus.hlean b/homotopy/torus.hlean new file mode 100644 index 0000000..f7314f1 --- /dev/null +++ b/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 diff --git a/move_to_lib.hlean b/move_to_lib.hlean index bf050ad..08b4665 100644 --- a/move_to_lib.hlean +++ b/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 :=