feat(functor.adjoint): give another way to construct an adjunction

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₂
+  universe variables u v
-  parameters {C : Precategory.{u₁ v₁}} {D : Precategory.{u₂ v₂}} {F : C ⇒ D} {G : D ⇒ C}
+  parameters {C D : Precategory.{u v}} (F : C ⇒ D) (U : D → C)
-          (θ : functor_lift.{v₂ v₁} ∘f hom_functor D ∘f prod_functor_prod Fᵒᵖᶠ 1 ≅
+  (ε : Πd, F (U d) ⟶ d) (θ : Π{c : C} {d : D} (g : F c ⟶ d), c ⟶ U d)
-               functor_lift.{v₁ v₂} ∘f hom_functor C ∘f prod_functor_prod 1 G)
+  (θ_coh : Π{c : C} {d : D} (g : F c ⟶ d), ε d ∘ F (θ g) = g)
-  include θ
+  (θ_unique : Π{c : C} {d : D} {g : F c ⟶ d} {f : c ⟶ U d}, ε d ∘ F f = g → θ g = f)
-  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
 
-  definition adj_counit [constructor] : F ∘f G ⟹ 1 :=
+  include θ_coh θ_unique
-  begin
+  definition right_adjoint_simple [constructor] : D ⇒ C :=
-    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ᵒᵖᶠ :=
   begin
     fconstructor,
-    { rexact opposite_nat_trans (to_counit H)},
+    { exact U },
-    { rexact opposite_nat_trans (to_unit H)},
+    { intro d d' g, exact θ (g ∘ ε d) },
-    { rexact to_unit_counit_eq H},
+    { intro d, apply θ_unique, refine idp ∘2 !respect_id ⬝ !id_right ⬝ !id_left⁻¹ },
-    { rexact to_counit_unit_eq H}
+    { 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,
+    fapply natural_iso.MK,
-    { rexact opposite_rev_nat_trans (to_counit H)},
+    { intro x f, exact θ f },
-    { rexact opposite_rev_nat_trans (to_unit H)},
+    { esimp, intro x x' f, apply eq_of_homotopy, intro g, symmetry, apply θ_unique,
-    { rexact to_unit_counit_eq H},
+      refine idp ∘2 !respect_comp ⬝ !assoc ⬝ _, refine !θ_coh ∘2 idp ⬝ !assoc' ⬝ idp ∘2 _,
-    { rexact to_counit_unit_eq H}
+      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/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