/-
Copyright (c) 2022 Joël Riou. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Joël Riou
-/

import category_theory.idempotents.karoubi
import category_theory.additive.basic

/-!

# Biproducts in the idempotent completion of a preadditive category

In this file, we define an instance expressing that if `C` is an additive category,
then `karoubi C` is also an additive category.

We also obtain that for all `P : karoubi C` where `C` is a preadditive category `C`, there
is a canonical isomorphism `P ⊞ P.complement ≅ (to_karoubi C).obj P.X` in the category
`karoubi C` where `P.complement` is the formal direct factor of `P.X` corresponding to
the idempotent endomorphism `𝟙 P.X - P.p`.

-/

noncomputable theory

open category_theory.category
open category_theory.limits
open category_theory.preadditive

universes v

namespace category_theory

namespace idempotents

namespace karoubi

variables {C : Type*} [category.{v} C] [preadditive C]

namespace biproducts

/-- The `bicone` used in order to obtain the existence of
the biproduct of a functor `J ⥤ karoubi C` when the category `C` is additive. -/
@[simps]
def bicone [has_finite_biproducts C] {J : Type} [fintype J]
  (F : J → karoubi C) : bicone F :=
{ X :=
  { X := biproduct (λ j, (F j).X),
    p := biproduct.map (λ j, (F j).p),
    idem := begin
      ext j,
      simp only [biproduct.ι_map_assoc, biproduct.ι_map],
      slice_lhs 1 2 { rw (F j).idem, },
    end, },
  π := λ j,
    { f := biproduct.map (λ j, (F j).p) ≫ bicone.π _ j,
      comm := by simp only [assoc, biproduct.bicone_π, biproduct.map_π,
        biproduct.map_π_assoc, (F j).idem], },
  ι := λ j,
    { f := (by exact bicone.ι _ j) ≫ biproduct.map (λ j, (F j).p),
      comm := by rw [biproduct.ι_map, ← assoc, ← assoc, (F j).idem,
        assoc, biproduct.ι_map, ← assoc, (F j).idem], },
  ι_π := λ j j', begin
    split_ifs,
    { subst h,
      simp only [assoc, idem, biproduct.map_π, biproduct.map_π_assoc, eq_to_hom_refl,
        id_eq, hom_ext, comp_f, biproduct.ι_π_self_assoc], },
    { simp only [biproduct.ι_π_ne_assoc _ h, assoc, biproduct.map_π,
        biproduct.map_π_assoc, hom_ext, comp_f, zero_comp, quiver.hom.add_comm_group_zero_f], },
  end, }

end biproducts

lemma karoubi_has_finite_biproducts [has_finite_biproducts C] :
  has_finite_biproducts (karoubi C) :=
{ out := λ n,
  { has_biproduct := λ F, begin
      classical,
      apply has_biproduct_of_total (biproducts.bicone F),
      ext1, ext1,
      simp only [id_eq, comp_id, biproducts.bicone_X_p, biproduct.ι_map],
      rw [sum_hom, comp_sum, finset.sum_eq_single j], rotate,
      { intros j' h1 h2,
        simp only [biproduct.ι_map, biproducts.bicone_ι_f, biproducts.bicone_π_f,
          assoc, comp_f, biproduct.map_π],
        slice_lhs 1 2 { rw biproduct.ι_π, },
        split_ifs,
        { exfalso, exact h2 h.symm, },
        { simp only [zero_comp], } },
      { intro h,
        exfalso,
        simpa only [finset.mem_univ, not_true] using h, },
      { simp only [biproducts.bicone_π_f, comp_f,
          biproduct.ι_map, assoc, biproducts.bicone_ι_f, biproduct.map_π],
        slice_lhs 1 2 { rw biproduct.ι_π, },
        split_ifs, swap, { exfalso, exact h rfl, },
        simp only [eq_to_hom_refl, id_comp, (F j).idem], },
    end, } }

instance {D : Type*} [category D] [additive_category D] : additive_category (karoubi D) :=
{ to_preadditive := infer_instance,
  to_has_finite_biproducts := karoubi_has_finite_biproducts }

/-- `P.complement` is the formal direct factor of `P.X` given by the idempotent
endomorphism `𝟙 P.X - P.p` -/
@[simps]
def complement (P : karoubi C) : karoubi C :=
{ X := P.X,
  p := 𝟙 _ - P.p,
  idem := idem_of_id_sub_idem P.p P.idem, }

instance (P : karoubi C) : has_binary_biproduct P P.complement :=
has_binary_biproduct_of_total
{ X := P.X,
  fst := P.decomp_id_p,
  snd := P.complement.decomp_id_p,
  inl := P.decomp_id_i,
  inr := P.complement.decomp_id_i,
  inl_fst' := P.decomp_id.symm,
  inl_snd' := begin
    simp only [decomp_id_i_f, decomp_id_p_f, complement_p, comp_sub, comp_f,
      hom_ext, quiver.hom.add_comm_group_zero_f, P.idem],
    erw [comp_id, sub_self],
  end,
  inr_fst' := begin
    simp only [decomp_id_i_f, complement_p, decomp_id_p_f, sub_comp, comp_f,
      hom_ext, quiver.hom.add_comm_group_zero_f, P.idem],
    erw [id_comp, sub_self],
  end,
  inr_snd' := P.complement.decomp_id.symm, }
(by simp only [hom_ext, ← decomp_p, quiver.hom.add_comm_group_add_f,
  to_karoubi_map_f, id_eq, coe_p, complement_p, add_sub_cancel'_right])

/-- A formal direct factor `P : karoubi C` of an object `P.X : C` in a
preadditive category is actually a direct factor of the image `(to_karoubi C).obj P.X`
of `P.X` in the category `karoubi C` -/
def decomposition (P : karoubi C) : P ⊞ P.complement ≅ (to_karoubi _).obj P.X :=
{ hom := biprod.desc P.decomp_id_i P.complement.decomp_id_i,
  inv := biprod.lift P.decomp_id_p P.complement.decomp_id_p,
  hom_inv_id' := begin
    ext1,
    { simp only [← assoc, biprod.inl_desc, comp_id, biprod.lift_eq, comp_add,
        ← decomp_id, id_comp, add_right_eq_self],
      convert zero_comp,
      ext,
      simp only [decomp_id_i_f, decomp_id_p_f, complement_p, comp_sub, comp_f,
        quiver.hom.add_comm_group_zero_f, P.idem],
      erw [comp_id, sub_self], },
    { simp only [← assoc, biprod.inr_desc, biprod.lift_eq, comp_add,
        ← decomp_id, comp_id, id_comp, add_left_eq_self],
      convert zero_comp,
      ext,
      simp only [decomp_id_i_f, decomp_id_p_f, complement_p, sub_comp, comp_f,
        quiver.hom.add_comm_group_zero_f, P.idem],
      erw [id_comp, sub_self], }
  end,
  inv_hom_id' := begin
    rw biprod.lift_desc,
    simp only [← decomp_p],
    ext,
    dsimp only [complement, to_karoubi],
    simp only [quiver.hom.add_comm_group_add_f, add_sub_cancel'_right, id_eq],
  end, }

end karoubi

end idempotents

end category_theory


/- -----------------------------------------------------------------------
Exponential obejcts.
----------------------------------------------------------------------- -/

import ..c1_basic
import ..c2_limits

namespace qp

open stdaux

universe variables ℓobjx ℓhomx ℓobj ℓhom

/-! #brief An exponential object.
-/
class HasExp (C : Cat.{ℓobj ℓhom})
    (X Y : C^.obj)
:= (exp : C^.obj)
   (ev
     : ∀ [exp_Y_HasFinProduct : HasFinProduct C [exp, Y]]
       , C^.hom (finproduct C [exp, Y]) X)
   (univ
     : ∀ (Z : C^.obj) [Z_Y_HasFinProduct : HasFinProduct C [Z, Y]]
         (e : C^.hom (finproduct C [Z, Y]) X)
       , C^.hom Z exp)
   (factor
     : ∀ [exp_Y_HasFinProduct : HasFinProduct C [exp, Y]]
         (Z : C^.obj) [Z_Y_HasFinProduct : HasFinProduct C [Z, Y]]
         (e : C^.hom (finproduct C [Z, Y]) X)
       , e = ev ∘∘ finproduct.hom (univ Z e ↗ C^.id Y ↗↗))
   (uniq
     : ∀ [exp_Y_HasFinProduct : HasFinProduct C [exp, Y]]
         (Z : C^.obj) [Z_Y_HasFinProduct : HasFinProduct C [Z, Y]]
         (e : C^.hom (finproduct C [Z, Y]) X)
         (u : C^.hom Z exp)
         (ωu : e = ev ∘∘ finproduct.hom (u ↗ C^.id Y ↗↗))
       , u = univ Z e)

/-! #brief A category with all exponential obejcts.
-/
class HasAllExp (C : Cat.{ℓobj ℓhom})
:= (has_exp : ∀ (X Y : C^.obj), HasExp C X Y)

instance HasAllExp.HasExp {C : Cat.{ℓobj ℓhom}}
    [C_HasAllExp : HasAllExp C]
    (X Y : C^.obj)
    : HasExp C X Y
:= HasAllExp.has_exp X Y

/-! #brief A category which locally has all exponential obejcts.
-/
class HasAllLocalExp (C : Cat.{ℓobj ℓhom})
:= (has_exp : ∀ (A : C^.obj) (X Y : (OverCat C A)^.obj)
              , HasExp (OverCat C A) X Y)

instance HasAllLocalExp.HasAllExp (C : Cat.{ℓobj ℓhom})
    [C_HasAllLocalExp : HasAllLocalExp C]
    (A : C^.obj)
    : HasAllExp (OverCat C A)
:= { has_exp := HasAllLocalExp.has_exp A
   }

/-! #brief An exponential object.
-/
definition expon (C : Cat.{ℓobj ℓhom})
    (X Y : C^.obj)
    [X_Y_HasExp : HasExp C X Y]
    : C^.obj
:= HasExp.exp X Y

/-! #brief An evaluation map.
-/
definition expon.eval (C : Cat.{ℓobj ℓhom})
    (X Y : C^.obj)
    [X_Y_HasExp : HasExp C X Y]
    [exp_Y_HasFinProduct : HasFinProduct C [expon C X Y, Y]]
    : C^.hom (finproduct C [expon C X Y, Y]) X
:= HasExp.ev X Y

/-! #brief A universal map.
-/
definition expon.univ (C : Cat.{ℓobj ℓhom})
    {X Y : C^.obj}
    [X_Y_HasExp : HasExp C X Y]
    {Z : C^.obj}
    [Z_Y_HasFinProduct : HasFinProduct C [Z, Y]]
    (e : C^.hom (finproduct C [Z, Y]) X)
    : C^.hom Z (expon C X Y)
:= HasExp.univ Z e

/-! #brief The universal map factors.
-/
theorem expon.univ.factor {C : Cat.{ℓobj ℓhom}}
    {X Y : C^.obj}
    [X_Y_HasExp : HasExp C X Y]
    [exp_Y_HasFinProduct : HasFinProduct C [expon C X Y, Y]]
    {Z : C^.obj}
    [Z_Y_HasFinProduct : HasFinProduct C [Z, Y]]
    {e : C^.hom (finproduct C [Z, Y]) X}
    : e = expon.eval C X Y ∘∘ finproduct.hom (expon.univ C e ↗ C^.id Y ↗↗)
:= HasExp.factor Z e

/-! #brief The universal map is unique.
-/
theorem expon.univ.uniq {C : Cat.{ℓobj ℓhom}}
    {X Y : C^.obj}
    [X_Y_HasExp : HasExp C X Y]
    [exp_Y_HasFinProduct : HasFinProduct C [expon C X Y, Y]]
    {Z : C^.obj} [Z_Y_HasFinProduct : HasFinProduct C [Z, Y]]
    (e : C^.hom (finproduct C [Z, Y]) X)
    (u : C^.hom Z (expon C X Y))
    (ωu : e = expon.eval C X Y ∘∘ finproduct.hom (u ↗ C^.id Y ↗↗))
    : u = expon.univ C e
:= @HasExp.uniq C X Y X_Y_HasExp exp_Y_HasFinProduct Z Z_Y_HasFinProduct e u ωu

/-! #brief The universal map induced by eval is the identity.
-/
theorem expon.univ_eval {C : Cat.{ℓobj ℓhom}}
    {X Y : C^.obj}
    [X_Y_HasExp : HasExp C X Y]
    [exp_Y_HasFinProduct : HasFinProduct C [expon C X Y, Y]]
    : expon.univ C (expon.eval C X Y) = C^.id (expon C X Y)
:= eq.symm (expon.univ.uniq _ _
              (eq.trans (eq.symm C^.circ_id_right)
                (Cat.circ.congr_right (eq.symm finproduct.hom₂.id))))

/- -----------------------------------------------------------------------
Homs induce maps between exponentials.
----------------------------------------------------------------------- -/

/-! #brief Hom induced by composition on the right.
-/
definition expon.circ_right {C : Cat.{ℓobj ℓhom}}
    {Z X Y : C^.obj}
    [Z_X_HasExp : HasExp C Z X]
    [Z_Y_HasExp : HasExp C Z Y]
    [exp_Y_HasFinProduct : HasFinProduct C [expon C Z Y, Y]]
    [exp_X_HasFinProduct : HasFinProduct C [expon C Z Y, X]]
    (f : C^.hom X Y)
    : C^.hom (expon C Z Y) (expon C Z X)
:= expon.univ C (C^.circ (expon.eval C Z Y) (finproduct.hom (C^.id (expon C Z Y) ↗ f ↗↗)))

/-! #brief Hom induced by composition on the left.
-/
definition expon.circ_left {C : Cat.{ℓobj ℓhom}}
    {X Y Z : C^.obj}
    [X_Z_HasExp : HasExp C X Z]
    [Y_Z_HasExp : HasExp C Y Z]
    [exp_Z_HasFinProduct : HasFinProduct C [expon C X Z, Z]]
    (g : C^.hom X Y)
    : C^.hom (expon C X Z) (expon C Y Z)
:= expon.univ C (C^.circ g (expon.eval C X Z))

/-! #brief Exponential objects are unique up-to unique isomorphism.
-/
definition expon.iso {C : Cat.{ℓobj ℓhom}}
    {X Y : C^.obj}
    (X_Y_HasExp₁ X_Y_HasExp₂ : HasExp C X Y)
    [exp_Y_HasFinProduct₁ : HasFinProduct C [@expon C X Y X_Y_HasExp₁, Y]]
    : C^.hom (@expon C X Y X_Y_HasExp₁) (@expon C X Y X_Y_HasExp₂)
:= @expon.circ_left C X X Y X_Y_HasExp₁ X_Y_HasExp₂ exp_Y_HasFinProduct₁ (C^.id X)

theorem expon.iso.eq {C : Cat.{ℓobj ℓhom}}
    {X Y : C^.obj}
    (X_Y_HasExp₁ X_Y_HasExp₂ : HasExp C X Y)
    [exp_Y_HasFinProduct₁ : HasFinProduct C [@expon C X Y X_Y_HasExp₁, Y]]
    [exp_Y_HasFinProduct₂ : HasFinProduct C [@expon C X Y X_Y_HasExp₂, Y]]
    : expon.iso X_Y_HasExp₂ X_Y_HasExp₁ ∘∘ expon.iso X_Y_HasExp₁ X_Y_HasExp₂
       = C^.id (@expon C X Y X_Y_HasExp₁)
:= begin
     unfold expon.iso expon.circ_left,
     repeat { rw C^.circ_id_left },
     rw -expon.univ_eval,
     refine @expon.univ.uniq C X Y X_Y_HasExp₁ exp_Y_HasFinProduct₁ _ exp_Y_HasFinProduct₁ _ _ _,
     refine eq.trans _
             (Cat.circ.congr_right
               (eq.trans
                 (eq.symm (finproduct.hom₂.circ
                             (@expon.univ C _ _ X_Y_HasExp₁ _ exp_Y_HasFinProduct₂ (@expon.eval C X Y X_Y_HasExp₂ exp_Y_HasFinProduct₂)) ⟨⟨Y⟩⟩
                             (@expon.univ C _ _ X_Y_HasExp₂ _ exp_Y_HasFinProduct₁ (@expon.eval C X Y X_Y_HasExp₁ exp_Y_HasFinProduct₁)) ⟨⟨Y⟩⟩))
                 (by rw C^.circ_id_right))),
     refine eq.trans _ (eq.symm C^.circ_assoc),
     refine eq.trans _ (Cat.circ.congr_left (@expon.univ.factor C X Y X_Y_HasExp₁ _ _ exp_Y_HasFinProduct₂ _)),
     apply expon.univ.factor
   end

/-! #brief Exponential objects are unique up-to unique isomorphism.
-/
definition expon.Iso {C : Cat.{ℓobj ℓhom}}
    {X Y : C^.obj}
    (X_Y_HasExp₁ X_Y_HasExp₂ : HasExp C X Y)
    [exp_Y_HasFinProduct₁ : HasFinProduct C [@expon C X Y X_Y_HasExp₁, Y]]
    [exp_Y_HasFinProduct₂ : HasFinProduct C [@expon C X Y X_Y_HasExp₂, Y]]
    : Iso (expon.iso X_Y_HasExp₁ X_Y_HasExp₂)
          (expon.iso X_Y_HasExp₂ X_Y_HasExp₁)
:= { id₁ := expon.iso.eq X_Y_HasExp₁ X_Y_HasExp₂
   , id₂ := expon.iso.eq X_Y_HasExp₂ X_Y_HasExp₁
   }

/- -----------------------------------------------------------------------
The exponential functor.
----------------------------------------------------------------------- -/

/-! #brief The exponential functor.
-/
definition ExpFun (C : Cat.{ℓobj ℓhom})
    [C_HasAllExp : HasAllExp C]
    [C_HasAllFinProducts : HasAllFinProducts C]
    (W : C^.obj)
    : Fun C C
:= { obj := λ X, expon C X W
   , hom := λ X Y f, expon.circ_left f
   , hom_id := λ X
               , begin
                   dsimp [expon.circ_left],
                   rw C^.circ_id_left,
                   apply expon.univ_eval
                 end
   , hom_circ
      := λ X Y Z g f
         , begin
             dsimp [expon.circ_left],
             refine eq.symm (expon.univ.uniq _ _ _),
             refine eq.trans _
                     (Cat.circ.congr_right
                       (eq.trans
                         (eq.symm (finproduct.hom₂.circ
                                    (expon.univ C (g ∘∘ expon.eval C Y W)) ⟨⟨W⟩⟩
                                    (expon.univ C (f ∘∘ expon.eval C X W)) ⟨⟨W⟩⟩))
                         (by rw C^.circ_id_right))),
             refine eq.trans _ (eq.symm C^.circ_assoc),
             refine eq.trans _ (Cat.circ.congr_left expon.univ.factor),
             refine eq.trans (eq.symm C^.circ_assoc)
                (eq.trans (Cat.circ.congr_right expon.univ.factor) C^.circ_assoc),
           end
   }

-- /- -----------------------------------------------------------------------
-- The dependent product functor.
-- ----------------------------------------------------------------------- -/

-- /-! #brief The fiber functor.
-- -/
-- definition FiberFun {C : Cat.{ℓobj ℓhom}}
--     {B A : C^.obj} (f : C^.hom B A)
--     [C_HasAllExp : HasAllExp (OverCat C A)]
--     [C_HasAllFinProducts : HasAllFinProducts (OverCat C A)]
--     : Fun (OverCat C A) (OverCat C A)
-- := ExpFun (OverCat C A) { obj := B, hom := f }

-- /-! #brief The dependent product functor.
-- -/
-- definition DepProdFun {C : Cat.{ℓobj ℓhom}}
--     {B A : C^.obj} (f : C^.hom B A)
--     [C_HasAllExp : HasAllExp (OverCat C A)]
--     [C_HasAllFinProducts : HasAllFinProducts (OverCat C A)]
--     : Fun (OverCat C B) (OverCat C A)
-- := FiberFun f □□ DepSumFun f

-- /-! #brief Preservation of co-limits by DepProdFun.
-- -/
-- instance DepProdFun.PresCoLimit {C : Cat.{ℓobj ℓhom}}
--     {B A : C^.obj} (f : C^.hom B A)
--     [C_HasAllExp : HasAllExp (OverCat C A)]
--     [C_HasAllFinProducts : HasAllFinProducts (OverCat C A)]
--     [f_HasPullbacksAlong : HasPullbacksAlong C f]
--     {X : Cat.{ℓobjx ℓhomx}}
--     (L : Fun X (OverCat C B))
--     [f_PresCoLimitsFrom : PresCoLimitsFrom (FiberFun f) X]
--     : PresCoLimit L (DepProdFun f)
-- := @PresCoLimit.comp _ _ _ _
--      L (DepSumFun f)
--      (Adj.left.PresCoLimit (DepSum_BaseChange.Adj f) L)
--      (FiberFun f)
--      (PresCoLimitsFrom.pres_colimit (FiberFun f) _)

-- /-! #brief Counit of the adjunction between base change and dependent product.
-- -/
-- definition BaseChange_DepProd.Adj.counit.com {C : Cat.{ℓobj ℓhom}}
--     {B A : C^.obj} (f : C^.hom B A)
--     [C_HasAllLocalExp : HasAllLocalExp C]
--     [C_HasAllPullbacks : HasAllPullbacks C]
--     : ∀ (Q : OverObj C B)
--       , OverHom C B
--           ((BaseChangeFun f □□ DepProdFun f)^.obj Q)
--           Q
-- | (OverObj.mk Q h)
-- := { hom := (expon.eval (OverCat C A) (OverObj.mk Q (f ∘∘ h)) (OverObj.mk B f))^.hom
--               ∘∘ sorry
-- -- begin
-- --   dsimp [Fun.comp, BaseChangeFun, HasAllExp.DepProdFun, ExpFun, BaseChangeFun.obj, OverObj.dom],
-- -- end
--    , triangle := sorry
--    }

-- /-! #brief Counit of the adjunction between base change and dependent product.
-- -/
-- definition BaseChange_DepProd.Adj.counit {C : Cat.{ℓobj ℓhom}}
--     {B A : C^.obj} (f : C^.hom B A)
--     [C_HasAllLocalExp : HasAllLocalExp C]
--     [C_HasAllPullbacks : HasAllPullbacks C]
--     : NatTrans (BaseChangeFun f □□ DepProdFun f)
--                (Fun.id (OverCat C B))
-- := { com := BaseChange_DepProd.Adj.counit.com f
--    , natural
--       := λ X Y h
--          , sorry
--    }

-- /-! #brief Unit of the adjunction between base change and dependent product.
-- -/
-- definition BaseChange_DepProd.Adj.unit.com {C : Cat.{ℓobj ℓhom}}
--     {B A : C^.obj} (f : C^.hom B A)
--     [C_HasAllLocalExp : HasAllLocalExp C]
--     [C_HasAllPullbacks : HasAllPullbacks C]
--     (Q : OverObj C A)
--     : OverHom C A
--         Q
--         ((DepProdFun f □□ BaseChangeFun f)^.obj Q)
-- := { hom :=
-- (expon.univ (OverCat C A)
-- begin
--   dsimp [Fun.comp, DepSumFun, BaseChangeFun, DepProdFun, ExpFun, BaseChangeFun.obj, OverObj.dom],
--   exact sorry
-- end
-- )^.hom
--    , triangle := sorry
--    }

-- /-! #brief Unit of the adjunction between base change and dependent product.
-- -/
-- definition BaseChange_DepProd.Adj.unit {C : Cat.{ℓobj ℓhom}}
--     {B A : C^.obj} (f : C^.hom B A)
--     [C_HasAllLocalExp : HasAllLocalExp C]
--     [C_HasAllPullbacks : HasAllPullbacks C]
--     : NatTrans (Fun.id (OverCat C A))
--                (DepProdFun f □□ BaseChangeFun f)
-- := { com := BaseChange_DepProd.Adj.unit.com f
--    , natural
--       := λ X Y h
--          , sorry
--    }

-- /-! #brief Base change is adjoint to dependent product.
-- -/
-- definition BaseChange_DepProd.Adj (C : Cat.{ℓobj ℓhom})
--     {B A : C^.obj} (f : C^.hom B A)
--     [C_HasAllLocalExp : HasAllLocalExp C]
--     [C_HasAllPullbacks : HasAllPullbacks C]
--     : Adj (BaseChangeFun f) (DepProdFun f)
-- := { counit := BaseChange_DepProd.Adj.counit f
--    , unit := BaseChange_DepProd.Adj.unit f
--    , id_left := sorry
--    , id_right := sorry
--    }

-- /-! #brief Locally cartesian closed categories have dependent product.
-- -/
-- instance HasAllExp.HasDepProdFun (C : Cat.{ℓobj ℓhom})
--     [C_HasAllLocalExp : HasAllLocalExp C]
--     [C_HasAllPullbacks : HasAllPullbacks C]
--     : HasDepProdFun C
-- := { depprod := λ x y f, HasAllExp.DepProdFun C f
--    , adj := λ x y f f_HasPullbacksAlong, begin end -- HasAllExp.BaseChange_DepProd.Adj C f
--    }

end qp


/-
Copyright (c) 2021 Shing Tak Lam. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Shing Tak Lam
-/

import topology.algebra.order.proj_Icc
import topology.continuous_function.ordered
import topology.compact_open
import topology.unit_interval

/-!
# Homotopy between functions

> THIS FILE IS SYNCHRONIZED WITH MATHLIB4.
> Any changes to this file require a corresponding PR to mathlib4.

In this file, we define a homotopy between two functions `f₀` and `f₁`. First we define
`continuous_map.homotopy` between the two functions, with no restrictions on the intermediate
maps. Then, as in the formalisation in HOL-Analysis, we define
`continuous_map.homotopy_with f₀ f₁ P`, for homotopies between `f₀` and `f₁`, where the
intermediate maps satisfy the predicate `P`. Finally, we define
`continuous_map.homotopy_rel f₀ f₁ S`, for homotopies between `f₀` and `f₁` which are fixed
on `S`.

## Definitions

* `continuous_map.homotopy f₀ f₁` is the type of homotopies between `f₀` and `f₁`.
* `continuous_map.homotopy_with f₀ f₁ P` is the type of homotopies between `f₀` and `f₁`, where
  the intermediate maps satisfy the predicate `P`.
* `continuous_map.homotopy_rel f₀ f₁ S` is the type of homotopies between `f₀` and `f₁` which
  are fixed on `S`.

For each of the above, we have

* `refl f`, which is the constant homotopy from `f` to `f`.
* `symm F`, which reverses the homotopy `F`. For example, if `F : continuous_map.homotopy f₀ f₁`,
  then `F.symm : continuous_map.homotopy f₁ f₀`.
* `trans F G`, which concatenates the homotopies `F` and `G`. For example, if
  `F : continuous_map.homotopy f₀ f₁` and `G : continuous_map.homotopy f₁ f₂`, then
  `F.trans G : continuous_map.homotopy f₀ f₂`.

We also define the relations

* `continuous_map.homotopic f₀ f₁` is defined to be `nonempty (continuous_map.homotopy f₀ f₁)`
* `continuous_map.homotopic_with f₀ f₁ P` is defined to be
  `nonempty (continuous_map.homotopy_with f₀ f₁ P)`
* `continuous_map.homotopic_rel f₀ f₁ P` is defined to be
  `nonempty (continuous_map.homotopy_rel f₀ f₁ P)`

and for `continuous_map.homotopic` and `continuous_map.homotopic_rel`, we also define the
`setoid` and `quotient` in `C(X, Y)` by these relations.

## References

- [HOL-Analysis formalisation](https://isabelle.in.tum.de/library/HOL/HOL-Analysis/Homotopy.html)
-/

noncomputable theory

universes u v w

variables {F : Type*} {X : Type u} {Y : Type v} {Z : Type w}
variables [topological_space X] [topological_space Y] [topological_space Z]

open_locale unit_interval

namespace continuous_map

/-- `continuous_map.homotopy f₀ f₁` is the type of homotopies from `f₀` to `f₁`.

When possible, instead of parametrizing results over `(f : homotopy f₀ f₁)`,
you should parametrize over `{F : Type*} [homotopy_like F f₀ f₁] (f : F)`.

When you extend this structure, make sure to extend `continuous_map.homotopy_like`. -/
structure homotopy (f₀ f₁ : C(X, Y)) extends C(I × X, Y) :=
(map_zero_left' : ∀ x, to_fun (0, x) = f₀ x)
(map_one_left' : ∀ x, to_fun (1, x) = f₁ x)

section
set_option old_structure_cmd true

/-- `continuous_map.homotopy_like F f₀ f₁` states that `F` is a type of homotopies between `f₀` and
`f₁`.

You should extend this class when you extend `continuous_map.homotopy`. -/
class homotopy_like (F : Type*) (f₀ f₁ : out_param $ C(X, Y))
  extends continuous_map_class F (I × X) Y :=
(map_zero_left (f : F) : ∀ x, f (0, x) = f₀ x)
(map_one_left (f : F) : ∀ x, f (1, x) = f₁ x)

end

-- `f₀` and `f₁` are `out_param` so this is not dangerous
attribute [nolint dangerous_instance] homotopy_like.to_continuous_map_class

namespace homotopy

section

variables {f₀ f₁ : C(X, Y)}

instance : homotopy_like (homotopy f₀ f₁) f₀ f₁ :=
{ coe := λ f, f.to_fun,
  coe_injective' := λ f g h, by { obtain ⟨⟨_, _⟩, _⟩ := f, obtain ⟨⟨_, _⟩, _⟩ := g, congr' },
  map_continuous := λ f, f.continuous_to_fun,
  map_zero_left := λ f, f.map_zero_left',
  map_one_left := λ f, f.map_one_left' }

/-- Helper instance for when there's too many metavariables to apply `fun_like.has_coe_to_fun`
directly. -/
instance : has_coe_to_fun (homotopy f₀ f₁) (λ _, I × X → Y) := fun_like.has_coe_to_fun

@[ext]
lemma ext {F G : homotopy f₀ f₁} (h : ∀ x, F x = G x) : F = G := fun_like.ext _ _ h

/-- See Note [custom simps projection]. We need to specify this projection explicitly in this case,
because it is a composition of multiple projections. -/
def simps.apply (F : homotopy f₀ f₁) : I × X → Y := F

initialize_simps_projections homotopy (to_continuous_map_to_fun -> apply, -to_continuous_map)

/-- Deprecated. Use `map_continuous` instead. -/
protected lemma continuous (F : homotopy f₀ f₁) : continuous F := F.continuous_to_fun

@[simp]
lemma apply_zero (F : homotopy f₀ f₁) (x : X) : F (0, x) = f₀ x := F.map_zero_left' x

@[simp]
lemma apply_one (F : homotopy f₀ f₁) (x : X) : F (1, x) = f₁ x := F.map_one_left' x

@[simp]
lemma coe_to_continuous_map (F : homotopy f₀ f₁) : ⇑F.to_continuous_map = F := rfl

/--
Currying a homotopy to a continuous function fron `I` to `C(X, Y)`.
-/
def curry (F : homotopy f₀ f₁) : C(I, C(X, Y)) := F.to_continuous_map.curry

@[simp]
lemma curry_apply (F : homotopy f₀ f₁) (t : I) (x : X) : F.curry t x = F (t, x) := rfl

/--
Continuously extending a curried homotopy to a function from `ℝ` to `C(X, Y)`.
-/
def extend (F : homotopy f₀ f₁) : C(ℝ, C(X, Y)) := F.curry.Icc_extend zero_le_one

lemma extend_apply_of_le_zero (F : homotopy f₀ f₁) {t : ℝ} (ht : t ≤ 0) (x : X) :
  F.extend t x = f₀ x :=
begin
  rw [←F.apply_zero],
  exact continuous_map.congr_fun (set.Icc_extend_of_le_left (zero_le_one' ℝ) F.curry ht) x,
end

lemma extend_apply_of_one_le (F : homotopy f₀ f₁) {t : ℝ} (ht : 1 ≤ t) (x : X) :
  F.extend t x = f₁ x :=
begin
  rw [←F.apply_one],
  exact continuous_map.congr_fun (set.Icc_extend_of_right_le (zero_le_one' ℝ) F.curry ht) x,
end

@[simp]
lemma extend_apply_coe (F : homotopy f₀ f₁) (t : I) (x : X) : F.extend t x = F (t, x) :=
continuous_map.congr_fun (set.Icc_extend_coe (zero_le_one' ℝ) F.curry t) x

@[simp]
lemma extend_apply_of_mem_I (F : homotopy f₀ f₁) {t : ℝ} (ht : t ∈ I) (x : X) :
  F.extend t x = F (⟨t, ht⟩, x) :=
continuous_map.congr_fun (set.Icc_extend_of_mem (zero_le_one' ℝ) F.curry ht) x

lemma congr_fun {F G : homotopy f₀ f₁} (h : F = G) (x : I × X) : F x = G x :=
continuous_map.congr_fun (congr_arg _ h) x

lemma congr_arg (F : homotopy f₀ f₁) {x y : I × X} (h : x = y) : F x = F y :=
F.to_continuous_map.congr_arg h

end

/--
Given a continuous function `f`, we can define a `homotopy f f` by `F (t, x) = f x`
-/
@[simps]
def refl (f : C(X, Y)) : homotopy f f :=
{ to_fun := λ x, f x.2,
  map_zero_left' := λ _, rfl,
  map_one_left' := λ _, rfl }

instance : inhabited (homotopy (continuous_map.id X) (continuous_map.id X)) := ⟨homotopy.refl _⟩

/--
Given a `homotopy f₀ f₁`, we can define a `homotopy f₁ f₀` by reversing the homotopy.
-/
@[simps]
def symm {f₀ f₁ : C(X, Y)} (F : homotopy f₀ f₁) : homotopy f₁ f₀ :=
{ to_fun := λ x, F (σ x.1, x.2),
  map_zero_left' := by norm_num,
  map_one_left' := by norm_num }

@[simp]
lemma symm_symm {f₀ f₁ : C(X, Y)} (F : homotopy f₀ f₁) : F.symm.symm = F :=
by { ext, simp }

/--
Given `homotopy f₀ f₁` and `homotopy f₁ f₂`, we can define a `homotopy f₀ f₂` by putting the first
homotopy on `[0, 1/2]` and the second on `[1/2, 1]`.
-/
def trans {f₀ f₁ f₂ : C(X, Y)} (F : homotopy f₀ f₁) (G : homotopy f₁ f₂) :
  homotopy f₀ f₂ :=
{ to_fun := λ x, if (x.1 : ℝ) ≤ 1/2 then F.extend (2 * x.1) x.2 else G.extend (2 * x.1 - 1) x.2,
  continuous_to_fun := begin
    refine continuous_if_le (continuous_induced_dom.comp continuous_fst) continuous_const
      (F.continuous.comp (by continuity)).continuous_on
      (G.continuous.comp (by continuity)).continuous_on _,
    rintros x hx,
    norm_num [hx],
  end,
  map_zero_left' := λ x, by norm_num,
  map_one_left' := λ x, by norm_num }

lemma trans_apply {f₀ f₁ f₂ : C(X, Y)} (F : homotopy f₀ f₁) (G : homotopy f₁ f₂)
  (x : I × X) : (F.trans G) x =
  if h : (x.1 : ℝ) ≤ 1/2 then
    F (⟨2 * x.1, (unit_interval.mul_pos_mem_iff zero_lt_two).2 ⟨x.1.2.1, h⟩⟩, x.2)
  else
    G (⟨2 * x.1 - 1, unit_interval.two_mul_sub_one_mem_iff.2 ⟨(not_le.1 h).le, x.1.2.2⟩⟩, x.2) :=
show ite _ _ _ = _,
by split_ifs; { rw [extend, continuous_map.coe_Icc_extend, set.Icc_extend_of_mem], refl }

lemma symm_trans {f₀ f₁ f₂ : C(X, Y)} (F : homotopy f₀ f₁) (G : homotopy f₁ f₂) :
  (F.trans G).symm = G.symm.trans F.symm :=
begin
  ext x,
  simp only [symm_apply, trans_apply],
  split_ifs with h₁ h₂,
  { change (x.1 : ℝ) ≤ _ at h₂,
    change (1 : ℝ) - x.1 ≤ _ at h₁,
    have ht : (x.1 : ℝ) = 1/2,
    { linarith },
    norm_num [ht] },
  { congr' 2,
    apply subtype.ext,
    simp only [unit_interval.coe_symm_eq, subtype.coe_mk],
    linarith },
  { congr' 2,
    apply subtype.ext,
    simp only [unit_interval.coe_symm_eq, subtype.coe_mk],
    linarith },
  { change ¬ (x.1 : ℝ) ≤ _ at h,
    change ¬ (1 : ℝ) - x.1 ≤ _ at h₁,
    exfalso, linarith }
end

/--
Casting a `homotopy f₀ f₁` to a `homotopy g₀ g₁` where `f₀ = g₀` and `f₁ = g₁`.
-/
@[simps]
def cast {f₀ f₁ g₀ g₁ : C(X, Y)} (F : homotopy f₀ f₁) (h₀ : f₀ = g₀) (h₁ : f₁ = g₁) :
  homotopy g₀ g₁ :=
{ to_fun := F,
  map_zero_left' := by simp [←h₀],
  map_one_left' := by simp [←h₁] }

/--
If we have a `homotopy f₀ f₁` and a `homotopy g₀ g₁`, then we can compose them and get a
`homotopy (g₀.comp f₀) (g₁.comp f₁)`.
-/
@[simps]
def hcomp {f₀ f₁ : C(X, Y)} {g₀ g₁ : C(Y, Z)} (F : homotopy f₀ f₁) (G : homotopy g₀ g₁) :
  homotopy (g₀.comp f₀) (g₁.comp f₁) :=
{ to_fun := λ x, G (x.1, F x),
  map_zero_left' := by simp,
  map_one_left' := by simp }

end homotopy

/--
Given continuous maps `f₀` and `f₁`, we say `f₀` and `f₁` are homotopic if there exists a
`homotopy f₀ f₁`.
-/
def homotopic (f₀ f₁ : C(X, Y)) : Prop :=
nonempty (homotopy f₀ f₁)

namespace homotopic

@[refl]
lemma refl (f : C(X, Y)) : homotopic f f := ⟨homotopy.refl f⟩

@[symm]
lemma symm ⦃f g : C(X, Y)⦄ (h : homotopic f g) : homotopic g f := h.map homotopy.symm

@[trans]

lemma hcomp {f₀ f₁ : C(X, Y)} {g₀ g₁ : C(Y, Z)} (h₀ : homotopic f₀ f₁) (h₁ : homotopic g₀ g₁) :
  homotopic (g₀.comp f₀) (g₁.comp f₁) :=
h₀.map2 homotopy.hcomp h₁

lemma equivalence : equivalence (@homotopic X Y _ _) := ⟨refl, symm, trans⟩

end homotopic

/--
The type of homotopies between `f₀ f₁ : C(X, Y)`, where the intermediate maps satisfy the predicate
`P : C(X, Y) → Prop`
-/
structure homotopy_with (f₀ f₁ : C(X, Y)) (P : C(X, Y) → Prop) extends homotopy f₀ f₁ :=
(prop' : ∀ t, P ⟨λ x, to_fun (t, x),
  continuous.comp continuous_to_fun (continuous_const.prod_mk continuous_id')⟩)

namespace homotopy_with

section

variables {f₀ f₁ : C(X, Y)} {P : C(X, Y) → Prop}

instance : has_coe_to_fun (homotopy_with f₀ f₁ P) (λ _, I × X → Y) := ⟨λ F, F.to_fun⟩

lemma coe_fn_injective : @function.injective (homotopy_with f₀ f₁ P) (I × X → Y) coe_fn :=
begin
  rintros ⟨⟨⟨F, _⟩, _⟩, _⟩ ⟨⟨⟨G, _⟩, _⟩, _⟩ h,
  congr' 3,
end

@[ext]
lemma ext {F G : homotopy_with f₀ f₁ P} (h : ∀ x, F x = G x) : F = G :=
coe_fn_injective $ funext h

/-- See Note [custom simps projection]. We need to specify this projection explicitly in this case,
because it is a composition of multiple projections. -/
def simps.apply (F : homotopy_with f₀ f₁ P) : I × X → Y := F

initialize_simps_projections homotopy_with
  (to_homotopy_to_continuous_map_to_fun -> apply, -to_homotopy_to_continuous_map)

@[continuity]
protected lemma continuous (F : homotopy_with f₀ f₁ P) : continuous F := F.continuous_to_fun

@[simp]
lemma apply_zero (F : homotopy_with f₀ f₁ P) (x : X) : F (0, x) = f₀ x := F.map_zero_left' x

@[simp]
lemma apply_one (F : homotopy_with f₀ f₁ P) (x : X) : F (1, x) = f₁ x := F.map_one_left' x

@[simp]
lemma coe_to_continuous_map (F : homotopy_with f₀ f₁ P) : ⇑F.to_continuous_map = F := rfl

@[simp]
lemma coe_to_homotopy (F : homotopy_with f₀ f₁ P) : ⇑F.to_homotopy = F := rfl

lemma prop (F : homotopy_with f₀ f₁ P) (t : I) : P (F.to_homotopy.curry t) := F.prop' t

lemma extend_prop (F : homotopy_with f₀ f₁ P) (t : ℝ) : P (F.to_homotopy.extend t) :=
begin
  by_cases ht₀ : 0 ≤ t,
  { by_cases ht₁ : t ≤ 1,
    { convert F.prop ⟨t, ht₀, ht₁⟩,
      ext,
      rw [F.to_homotopy.extend_apply_of_mem_I ⟨ht₀, ht₁⟩, F.to_homotopy.curry_apply] },
    { convert F.prop 1,
      ext,
      rw [F.to_homotopy.extend_apply_of_one_le (le_of_not_le ht₁), F.to_homotopy.curry_apply,
          F.to_homotopy.apply_one] } },
  { convert F.prop 0,
    ext,
    rw [F.to_homotopy.extend_apply_of_le_zero (le_of_not_le ht₀), F.to_homotopy.curry_apply,
        F.to_homotopy.apply_zero] }
end

end

variable {P : C(X, Y) → Prop}

/--
Given a continuous function `f`, and a proof `h : P f`, we can define a `homotopy_with f f P` by
`F (t, x) = f x`
-/
@[simps]
def refl (f : C(X, Y)) (hf : P f) : homotopy_with f f P :=
{ prop' := λ t, by { convert hf, cases f, refl },
  ..homotopy.refl f }

instance : inhabited (homotopy_with (continuous_map.id X) (continuous_map.id X) (λ f, true)) :=
⟨homotopy_with.refl _ trivial⟩

/--
Given a `homotopy_with f₀ f₁ P`, we can define a `homotopy_with f₁ f₀ P` by reversing the homotopy.
-/
@[simps]
def symm {f₀ f₁ : C(X, Y)} (F : homotopy_with f₀ f₁ P) : homotopy_with f₁ f₀ P :=
{ prop' := λ t, by simpa using F.prop (σ t),
  ..F.to_homotopy.symm }

@[simp]
lemma symm_symm {f₀ f₁ : C(X, Y)} (F : homotopy_with f₀ f₁ P) : F.symm.symm = F :=
ext $ homotopy.congr_fun $ homotopy.symm_symm _

/--
Given `homotopy_with f₀ f₁ P` and `homotopy_with f₁ f₂ P`, we can define a `homotopy_with f₀ f₂ P`
by putting the first homotopy on `[0, 1/2]` and the second on `[1/2, 1]`.
-/
def trans {f₀ f₁ f₂ : C(X, Y)} (F : homotopy_with f₀ f₁ P) (G : homotopy_with f₁ f₂ P) :
  homotopy_with f₀ f₂ P :=
{ prop' := λ t, begin
    simp only [homotopy.trans],
    change P ⟨λ _, ite ((t : ℝ) ≤ _) _ _, _⟩,
    split_ifs,
    { exact F.extend_prop _ },
    { exact G.extend_prop _ }
  end,
  ..F.to_homotopy.trans G.to_homotopy }

lemma trans_apply {f₀ f₁ f₂ : C(X, Y)} (F : homotopy_with f₀ f₁ P) (G : homotopy_with f₁ f₂ P)
  (x : I × X) : (F.trans G) x =
  if h : (x.1 : ℝ) ≤ 1/2 then
    F (⟨2 * x.1, (unit_interval.mul_pos_mem_iff zero_lt_two).2 ⟨x.1.2.1, h⟩⟩, x.2)
  else
    G (⟨2 * x.1 - 1, unit_interval.two_mul_sub_one_mem_iff.2 ⟨(not_le.1 h).le, x.1.2.2⟩⟩, x.2) :=
homotopy.trans_apply _ _ _

lemma symm_trans {f₀ f₁ f₂ : C(X, Y)} (F : homotopy_with f₀ f₁ P) (G : homotopy_with f₁ f₂ P) :
  (F.trans G).symm = G.symm.trans F.symm :=
ext $ homotopy.congr_fun $ homotopy.symm_trans _ _

/--
Casting a `homotopy_with f₀ f₁ P` to a `homotopy_with g₀ g₁ P` where `f₀ = g₀` and `f₁ = g₁`.
-/
@[simps]
def cast {f₀ f₁ g₀ g₁ : C(X, Y)} (F : homotopy_with f₀ f₁ P) (h₀ : f₀ = g₀) (h₁ : f₁ = g₁) :
  homotopy_with g₀ g₁ P :=
{ prop' := F.prop,
  ..F.to_homotopy.cast h₀ h₁ }

end homotopy_with

/--
Given continuous maps `f₀` and `f₁`, we say `f₀` and `f₁` are homotopic with respect to the
predicate `P` if there exists a `homotopy_with f₀ f₁ P`.
-/
def homotopic_with (f₀ f₁ : C(X, Y)) (P : C(X, Y) → Prop) : Prop :=
nonempty (homotopy_with f₀ f₁ P)

namespace homotopic_with

variable {P : C(X, Y) → Prop}

@[refl]
lemma refl (f : C(X, Y)) (hf : P f) : homotopic_with f f P :=
⟨homotopy_with.refl f hf⟩

@[symm]
lemma symm ⦃f g : C(X, Y)⦄ (h : homotopic_with f g P) : homotopic_with g f P := ⟨h.some.symm⟩

@[trans]
lemma trans ⦃f g h : C(X, Y)⦄ (h₀ : homotopic_with f g P) (h₁ : homotopic_with g h P) :
  homotopic_with f h P :=
⟨h₀.some.trans h₁.some⟩

end homotopic_with

/--
A `homotopy_rel f₀ f₁ S` is a homotopy between `f₀` and `f₁` which is fixed on the points in `S`.
-/
abbreviation homotopy_rel (f₀ f₁ : C(X, Y)) (S : set X) :=
homotopy_with f₀ f₁ (λ f, ∀ x ∈ S, f x = f₀ x ∧ f x = f₁ x)

namespace homotopy_rel

section

variables {f₀ f₁ : C(X, Y)} {S : set X}

lemma eq_fst (F : homotopy_rel f₀ f₁ S) (t : I) {x : X} (hx : x ∈ S) :
  F (t, x) = f₀ x := (F.prop t x hx).1

lemma eq_snd (F : homotopy_rel f₀ f₁ S) (t : I) {x : X} (hx : x ∈ S) :
  F (t, x) = f₁ x := (F.prop t x hx).2

lemma fst_eq_snd (F : homotopy_rel f₀ f₁ S) {x : X} (hx : x ∈ S) :
  f₀ x = f₁ x := F.eq_fst 0 hx ▸ F.eq_snd 0 hx

end

variables {f₀ f₁ f₂ : C(X, Y)} {S : set X}

/--
Given a map `f : C(X, Y)` and a set `S`, we can define a `homotopy_rel f f S` by setting
`F (t, x) = f x` for all `t`. This is defined using `homotopy_with.refl`, but with the proof
filled in.
-/
@[simps]
def refl (f : C(X, Y)) (S : set X) : homotopy_rel f f S :=
homotopy_with.refl f (λ x hx, ⟨rfl, rfl⟩)

/--
Given a `homotopy_rel f₀ f₁ S`, we can define a `homotopy_rel f₁ f₀ S` by reversing the homotopy.
-/
@[simps]
def symm (F : homotopy_rel f₀ f₁ S) : homotopy_rel f₁ f₀ S :=
{ prop' := λ t x hx, by simp [F.eq_snd _ hx, F.fst_eq_snd hx],
  ..homotopy_with.symm F }

@[simp]
lemma symm_symm (F : homotopy_rel f₀ f₁ S) : F.symm.symm = F :=
homotopy_with.symm_symm F

/--
Given `homotopy_rel f₀ f₁ S` and `homotopy_rel f₁ f₂ S`, we can define a `homotopy_rel f₀ f₂ S`
by putting the first homotopy on `[0, 1/2]` and the second on `[1/2, 1]`.
-/
def trans (F : homotopy_rel f₀ f₁ S) (G : homotopy_rel f₁ f₂ S) : homotopy_rel f₀ f₂ S :=
{ prop' := λ t, begin
    intros x hx,
    simp only [homotopy.trans],
    change (⟨λ _, ite ((t : ℝ) ≤ _) _ _, _⟩ : C(X, Y)) _ = _ ∧ _ = _,
    split_ifs,
    { simp [(homotopy_with.extend_prop F (2 * t) x hx).1, F.fst_eq_snd hx, G.fst_eq_snd hx] },
    { simp [(homotopy_with.extend_prop G (2 * t - 1) x hx).1, F.fst_eq_snd hx, G.fst_eq_snd hx] },
  end,
  ..homotopy.trans F.to_homotopy G.to_homotopy }

lemma trans_apply (F : homotopy_rel f₀ f₁ S) (G : homotopy_rel f₁ f₂ S)
  (x : I × X) : (F.trans G) x =
  if h : (x.1 : ℝ) ≤ 1/2 then
    F (⟨2 * x.1, (unit_interval.mul_pos_mem_iff zero_lt_two).2 ⟨x.1.2.1, h⟩⟩, x.2)
  else
    G (⟨2 * x.1 - 1, unit_interval.two_mul_sub_one_mem_iff.2 ⟨(not_le.1 h).le, x.1.2.2⟩⟩, x.2) :=
homotopy.trans_apply _ _ _

lemma symm_trans (F : homotopy_rel f₀ f₁ S) (G : homotopy_rel f₁ f₂ S) :
  (F.trans G).symm = G.symm.trans F.symm :=
homotopy_with.ext $ homotopy.congr_fun $ homotopy.symm_trans _ _

/--
Casting a `homotopy_rel f₀ f₁ S` to a `homotopy_rel g₀ g₁ S` where `f₀ = g₀` and `f₁ = g₁`.
-/
@[simps]
def cast {f₀ f₁ g₀ g₁ : C(X, Y)} (F : homotopy_rel f₀ f₁ S) (h₀ : f₀ = g₀) (h₁ : f₁ = g₁) :
  homotopy_rel g₀ g₁ S :=
{ prop' := λ t x hx, by { simpa [←h₀, ←h₁] using F.prop t x hx },
  ..homotopy.cast F.to_homotopy h₀ h₁ }

end homotopy_rel

/--
Given continuous maps `f₀` and `f₁`, we say `f₀` and `f₁` are homotopic relative to a set `S` if
there exists a `homotopy_rel f₀ f₁ S`.
-/
def homotopic_rel (f₀ f₁ : C(X, Y)) (S : set X) : Prop :=
nonempty (homotopy_rel f₀ f₁ S)

namespace homotopic_rel

variable {S : set X}

@[refl]
lemma refl (f : C(X, Y)) : homotopic_rel f f S := ⟨homotopy_rel.refl f S⟩

@[symm]
lemma symm ⦃f g : C(X, Y)⦄ (h : homotopic_rel f g S) : homotopic_rel g f S :=
  h.map homotopy_rel.symm

@[trans]
lemma trans ⦃f g h : C(X, Y)⦄ (h₀ : homotopic_rel f g S) (h₁ : homotopic_rel g h S) :
  homotopic_rel f h S :=
h₀.map2 homotopy_rel.trans h₁

lemma equivalence : equivalence (λ f g : C(X, Y), homotopic_rel f g S) :=
⟨refl, symm, trans⟩

end homotopic_rel

end continuous_map