/- -----------------------------------------------------------------------
Categories.
----------------------------------------------------------------------- -/

import .s1_categories

namespace qp

open stdaux

universe variables ℓ₁ ℓ₂ ℓ₃ ℓ₄ ℓobj ℓhom ℓobj₁ ℓhom₁ ℓobj₂ ℓhom₂ ℓobj₃ ℓhom₃ ℓobj₄ ℓhom₄ ℓobj₅ ℓhom₅

/-! #brief A functor between categories.
-/
structure Fun (C : Cat.{ℓobj₁ ℓhom₁}) (D : Cat.{ℓobj₂ ℓhom₂})
    : Type (max ℓobj₁ ℓhom₁ ℓobj₂ ℓhom₂)
:= (obj : C^.obj → D^.obj)
   (hom : ∀ {x y : C^.obj}, C^.hom x y → D^.hom (obj x) (obj y))
   (hom_id : ∀ {x : C^.obj}, hom ⟨⟨x⟩⟩ = ⟨⟨obj x⟩⟩)
   (hom_circ : ∀ {x y z : C^.obj}
                 {g : C^.hom y z} {f : C^.hom x y}
               , hom (g ∘∘ f) = hom g ∘∘ hom f)

attribute [simp] Fun.hom_id

-- A functor between categories.
-- \rightrightarrows
notation C `⇉` D := Fun C D

/-! #brief Helper for proving two functors are equal.
-/
theorem Fun.eq {C : Cat.{ℓobj₁ ℓhom₁}} {D : Cat.{ℓobj₂ ℓhom₂}}
    : ∀ {F G : Fun C D}
        (ωobj : ∀ (x : C^.obj), F^.obj x = G^.obj x)
        (ωhom : ∀ (ω : ∀ (x : C^.obj), F^.obj x = G^.obj x)
                  {x y : C^.obj} (f : C^.hom x y)
                , F^.hom f == G^.hom f)
      , F = G
| (Fun.mk Fobj Fhom Fhom_id Fhom_circ)
  (Fun.mk Gobj Ghom Ghom_id Ghom_circ)
  ωobj ωhom
:= begin
     assert ωobj' : Fobj = Gobj, { exact funext ωobj },
     subst ωobj',
     assert ωhom' : @Fhom = @Ghom,
     { apply funext, intro x,
       apply funext, intro y,
       apply funext, intro f,
       apply eq_of_heq,
       apply ωhom ωobj
     },
     subst ωhom'
   end

/-! #brief Helper for proving two functors are heterogeneously equal.
-/
theorem Fun.heq
    : ∀ {C₁ : Cat.{ℓobj₁ ℓhom₁}} {D₁ : Cat.{ℓobj₂ ℓhom₂}} {F₁ : Fun C₁ D₁}
        {C₂ : Cat.{ℓobj₁ ℓhom₁}} {D₂ : Cat.{ℓobj₂ ℓhom₂}} {F₂ : Fun C₂ D₂}
        (ωC : C₁ = C₂) (ωD : D₁ = D₂)
        (ωobj : ∀ (x₁ : C₁^.obj) (x₂ : C₂^.obj)
                , x₁ == x₂ → F₁^.obj x₁ == F₂^.obj x₂)
        (ωhom : ∀ (x₁ y₁ : C₁^.obj) (x₂ y₂ : C₂^.obj)
                  (f₁ : C₁^.hom x₁ y₁) (f₂ : C₂^.hom x₂ y₂)
                , f₁ == f₂ → (F₁^.hom f₁) == (F₂^.hom f₂))
      , F₁ == F₂
| C D F₁ .(C) .(D) F₂ (eq.refl .(C)) (eq.refl .(D)) ωobj ωhom
:= begin
     apply heq_of_eq,
     apply Fun.eq,
     { intro x,
       apply eq_of_heq,
       apply ωobj,
       apply heq.refl
     },
     { intros ωobj x y f,
       apply ωhom,
       apply heq.refl
     }
   end

/-! #brief Congruence on objects.
-/
theorem Fun.congr_obj {C : Cat.{ℓobj₁ ℓhom₁}} {D : Cat.{ℓobj₂ ℓhom₂}}
    {F : Fun C D}
    : ∀ {x y : C^.obj}
        (ω : x = y)
      , F^.obj x = F^.obj y
| x .(x) (eq.refl .(x)) := rfl

/-! #brief Congruence on homs.
-/
theorem Fun.congr_hom {C : Cat.{ℓobj₁ ℓhom₁}} {D : Cat.{ℓobj₂ ℓhom₂}}
    {F : Fun C D}
    : ∀ {x y : C^.obj} {f₁ f₂ : C^.hom x y}
        (ω : f₁ = f₂)
      , F^.hom f₁ = F^.hom f₂
| x y f .(f) (eq.refl .(f)) := rfl

/-! #brief Action of a functor on a cast_hom.
-/
theorem Fun.cast_hom {C : Cat.{ℓobj₁ ℓhom₁}} {D : Cat.{ℓobj₂ ℓhom₂}}
    {F : Fun C D}
    : ∀ {x y : C^.obj}
        {ω : x = y}
      , F^.hom (cast_hom ω) = cast_hom begin rw ω end
| x .(x) (eq.refl .(x)) := F^.hom_id

/- -----------------------------------------------------------------------
Functors are morphisms of categories.
----------------------------------------------------------------------- -/

/-! #brief The identity functor.
-/
definition Fun.id (C : Cat.{ℓobj ℓhom}) : Fun C C
:= { obj := λ x, x
   , hom := λ x y f, f
   , hom_id := λ x, rfl
   , hom_circ := λ x y z g f, rfl
   }

@[simp] theorem Fun.id.simp_obj {C : Cat.{ℓobj ℓhom}}
    (c : C^.obj)
    : (Fun.id C)^.obj c = c
:= rfl

@[simp] theorem Fun.id.simp_hom {C : Cat.{ℓobj ℓhom}}
    {c₁ c₂ : C^.obj} (f : C^.hom c₁ c₂)
    : (Fun.id C)^.hom f = f
:= rfl

/-! #brief Composition of functors.
-/
definition Fun.comp {B : Cat.{ℓobj₁ ℓhom₁}} {C : Cat.{ℓobj₂ ℓhom₂}} {D : Cat.{ℓobj₃ ℓhom₃}}
    (G : Fun C D) (F : Fun B C)
    : Fun B D
:= { obj := λ x, G^.obj (F^.obj x)
   , hom := λ x y f, G^.hom (F^.hom f)
   , hom_id := λ x, begin dsimp, simp end
   , hom_circ := λ x y z g f, begin dsimp, simp [Fun.hom_circ] end
   }

-- Composition of functors.
-- \Box\Box
infixl ` □□ ` : 150 := Fun.comp

@[simp] theorem Fun.comp.simp_obj {B : Cat.{ℓobj₁ ℓhom₁}} {C : Cat.{ℓobj₂ ℓhom₂}} {D : Cat.{ℓobj₃ ℓhom₃}}
    (G : Fun C D) (F : Fun B C) (x : B^.obj)
    : (Fun.comp G F)^.obj x = G^.obj (F^.obj x)
:= rfl

@[simp] theorem Fun.comp.simp_hom {B : Cat.{ℓobj₁ ℓhom₁}} {C : Cat.{ℓobj₂ ℓhom₂}} {D : Cat.{ℓobj₃ ℓhom₃}}
    (G : Fun C D) (F : Fun B C) {x₁ x₂ : B^.obj} (f : B^.hom x₁ x₂)
    : (Fun.comp G F)^.hom f = G^.hom (F^.hom f)
:= rfl

/-! #brief Composition of functors is associative.
-/
theorem Fun.comp_assoc {B : Cat.{ℓobj₁ ℓhom₁}} {C : Cat.{ℓobj₂ ℓhom₂}} {D : Cat.{ℓobj₃ ℓhom₃}} {E : Cat.{ℓobj₄ ℓhom₄}}
    {H : Fun D E} {G : Fun C D} {F : Fun B C}
    : Fun.comp H (Fun.comp G F) = Fun.comp (Fun.comp H G) F
:= begin
     apply Fun.eq,
     { intro b, repeat {rw [Fun.comp.simp_obj]} },
     { intros ωobj x y f, repeat {rw [Fun.comp.simp_hom]}, apply heq.refl }
   end

/-! #brief The identity functor is a left-identity for composition.
-/
@[simp] theorem Fun.comp_id_left {C : Cat.{ℓobj₁ ℓhom₁}} {D : Cat.{ℓobj₂ ℓhom₂}}
    {F : Fun C D}
    : Fun.comp (Fun.id D) F = F
:= begin
     apply Fun.eq,
     { intro x, rw [Fun.comp.simp_obj, Fun.id.simp_obj] },
     { intros ωobj x y f, rw [Fun.comp.simp_hom, Fun.id.simp_hom], apply heq.refl }
   end

/-! #brief The identity functor is a right-identity for composition.
-/
@[simp] theorem Fun.comp_id_right {C : Cat.{ℓobj₁ ℓhom₁}} {D : Cat.{ℓobj₂ ℓhom₂}}
    {F : Fun C D}
    : Fun.comp F (Fun.id C) = F
:= begin
     apply Fun.eq,
     { intro x, rw [Fun.comp.simp_obj, Fun.id.simp_obj] },
     { intros ωobj x y f, rw [Fun.comp.simp_hom, Fun.id.simp_hom], apply heq.refl }
   end

/-! #brief Iterated composition of endofunctors.
-/
definition Fun.iter_comp {C : Cat.{ℓobj₁ ℓhom₁}}
    (F : Fun C C)
    : ℕ → Fun C C
| 0 := Fun.id C
| (nat.succ n) := Fun.comp F (Fun.iter_comp n)

/-! #brief Fun.iter_comp absorbs on the left.
-/
definition Fun.iter_comp_fold_left {C : Cat.{ℓobj₁ ℓhom₁}}
    {F : Fun C C}
    {n : ℕ}
    : Fun.comp F (Fun.iter_comp F n)
       = Fun.iter_comp F (nat.succ n)
:= rfl

/-! #brief Fun.iter_comp absorbs on the right.
-/
definition Fun.iter_comp_fold_right {C : Cat.{ℓobj₁ ℓhom₁}}
    {F : Fun C C}
    : ∀ {n : ℕ}
      , Fun.comp (Fun.iter_comp F n) F
         = Fun.iter_comp F (nat.succ n)
| 0 := rfl
| (nat.succ n)
:= begin
     dsimp [Fun.iter_comp],
     rw -Fun.comp_assoc,
     rw Fun.iter_comp_fold_right,
     trivial
   end

/-! #brief Iterated composition of endofunctors.
-/
definition Fun.iter_comp' {C : Cat.{ℓobj₁ ℓhom₁}}
    (F : Fun C C)
    : ℕ → Fun C C
| 0 := Fun.id C
| (nat.succ n) := Fun.comp (Fun.iter_comp' n) F

/-! @brief Fun.iter_comp and Fun.iter_comp' are equal.
-/
theorem Fun.iter_comp_assoc {C : Cat.{ℓobj₁ ℓhom₁}}
    {F : Fun C C}
    : ∀ {n : ℕ}
      , Fun.iter_comp F n = Fun.iter_comp' F n
| 0 := rfl
| (nat.succ n)
:= begin
     dsimp [Fun.iter_comp, Fun.iter_comp'],
     rw [-Fun.iter_comp_assoc, Fun.iter_comp_fold_left, Fun.iter_comp_fold_right]
   end

/-! #brief Fun.iter_comp absorbs on the left.
-/
definition Fun.iter_comp'_fold_left {C : Cat.{ℓobj₁ ℓhom₁}}
    {F : Fun C C}
    {n : ℕ}
    : Fun.comp F (Fun.iter_comp' F n)
       = Fun.iter_comp' F (nat.succ n)
:= begin
     repeat { rw -Fun.iter_comp_assoc },
     exact Fun.iter_comp_fold_left
   end

/-! #brief Fun.iter_comp absorbs on the right.
-/
definition Fun.iter_comp'_fold_right {C : Cat.{ℓobj₁ ℓhom₁}}
    {F : Fun C C}
    {n : ℕ}
    : Fun.comp (Fun.iter_comp' F n) F
       = Fun.iter_comp' F (nat.succ n)
:= begin
     repeat { rw -Fun.iter_comp_assoc },
     exact Fun.iter_comp_fold_right
   end

/- -----------------------------------------------------------------------
Constant functors.
----------------------------------------------------------------------- -/

/-! #brief A constant functor.
-/
definition ConstFun (C : Cat.{ℓobj₁ ℓhom₁}) {D : Cat.{ℓobj₂ ℓhom₂}}
    (d : D^.obj)
    : Fun C D
:= { obj := λ c, d
   , hom := λ c₁ c₂ f, D^.id d
   , hom_id := λ c, rfl
   , hom_circ := λ c₁ c₂ c₃ g f, eq.symm D^.circ_id_right
   }

/- -----------------------------------------------------------------------
The initial and final functors.
----------------------------------------------------------------------- -/

/-! #brief The final functor.
-/
definition FinalFun (C : Cat.{ℓobj₂ ℓhom₂})
    : Fun C UnitCat.{ℓobj₁ ℓhom₁}
:= { obj := λ c, punit.star
   , hom := λ c₁ c₂ f, punit.star
   , hom_id := λ c, rfl
   , hom_circ := λ c₁ c₂ c₃ g f, rfl
   }

/-! #brief The final functor is unique.
-/
theorem FinalFun.uniq {C : Cat.{ℓobj₂ ℓhom₂}}
    {F : Fun C UnitCat.{ℓobj₁ ℓhom₁}}
    : F = FinalFun.{ℓobj₁ ℓhom₁} C
:= Fun.eq
    (λ c, begin cases F^.obj c, trivial end)
    (λ ω c₁ c₂ f, begin cases F^.hom f, trivial end)

/-! #brief The initial functor.
-/
definition InitFun (C : Cat.{ℓobj₂ ℓhom₂})
    : Fun EmptyCat.{ℓobj₁ ℓhom₁} C
:= { obj := λ e, by cases e
   , hom := λ e₁ e₂ f, by cases f
   , hom_id := λ e, by cases e
   , hom_circ := λ e₁ e₂ e₃ g f, by cases f
   }

/-! #brief The initial functor is unique.
-/
theorem InitFun.uniq {C : Cat.{ℓobj₂ ℓhom₂}}
    {F : Fun EmptyCat.{ℓobj₁ ℓhom₁} C}
    : F = InitFun.{ℓobj₁ ℓhom₁} C
:= Fun.eq
    (λ c, by cases c)
    (λ ω c₁ c₂ f, by cases f)

/- -----------------------------------------------------------------------
Functors and isomorphisms.
----------------------------------------------------------------------- -/

/-! #brief Functors preserve isomorphisms.
-/
theorem Fun.preserves_Iso {C : Cat.{ℓobj₁ ℓhom₁}} {D : Cat.{ℓobj₂ ℓhom₂}}
    (F : Fun C D)
    {c₁ c₂ : C^.obj}
    {f₁₂ : C^.hom c₁ c₂} {f₂₁ : C^.hom c₂ c₁}
    (iso : Iso f₁₂ f₂₁)
    : Iso (F^.hom f₁₂) (F^.hom f₂₁)
:= { id₁ := by calc F^.hom f₂₁ ∘∘ F^.hom f₁₂
                        = F^.hom (f₂₁ ∘∘ f₁₂) : by rw F^.hom_circ
                    ... = F^.hom (C^.id c₁)   : by rw iso^.id₁
                    ... = ⟨⟨F^.obj c₁⟩⟩       : by rw F^.hom_id
   , id₂ := by calc F^.hom f₁₂ ∘∘ F^.hom f₂₁
                        = F^.hom (f₁₂ ∘∘ f₂₁) : by rw F^.hom_circ
                    ... = F^.hom (C^.id c₂)   : by rw iso^.id₂
                    ... = ⟨⟨F^.obj c₂⟩⟩       : by rw F^.hom_id
   }

/- -----------------------------------------------------------------------
The category of categories.
----------------------------------------------------------------------- -/

/-! #brief A category of categories.
-/
definition CatOfCats
    : Cat.{((max ℓobj ℓhom) + 1) ((max ℓobj ℓhom) + 1)}
:= { obj := Cat.{ℓobj ℓhom}
   , hom := Fun
   , id := Fun.id
   , circ := @Fun.comp
   , circ_assoc := @Fun.comp_assoc
   , circ_id_left := @Fun.comp_id_left
   , circ_id_right := @Fun.comp_id_right
   }

/-! #brief The Lean object functor.
-/
definition CatOfCats.ObjFun
    : Fun CatOfCats.{ℓobj ℓhom} LeanCat.{ℓobj}
:= { obj := λ C, C^.obj
   , hom := λ C₁ C₂ F, F^.obj
   , hom_id := λ C, rfl
   , hom_circ := λ C₁ C₂ C₃ g f, rfl
   }

/-! #brief A general hom in a category.
-/
structure Cat.GeneralHom (C : Cat.{ℓobj₁ ℓhom₁})
    : Type (max ℓobj₁ ℓhom₁)
:= (dom : C^.obj)
   (codom : C^.obj)
   (hom : C^.hom dom codom)

/-! #brief The Lean hom functor.
-/
definition CatOfCats.HomFun
    : Fun CatOfCats.{ℓobj ℓhom} LeanCat.{max ℓobj ℓhom}
:= { obj := Cat.GeneralHom
   , hom
      := λ C₁ C₂ F h
         , { dom := F^.obj h^.dom
           , codom := F^.obj h^.codom
           , hom := F^.hom h^.hom
           }
   , hom_id := λ C, begin apply funext, intro x, cases x, trivial end
   , hom_circ := λ C₁ C₂ C₃ g f, begin apply funext, intro x, cases x, trivial end
   }

/- -----------------------------------------------------------------------
The Lean universe-level functors.
----------------------------------------------------------------------- -/

/-! #brief Lift the universe level to the max.
-/
inductive Lean.LevelMax (A : Type.{ℓ₁}) : Type (max ℓ₁ ℓ₂)
| lift : A → Lean.LevelMax

definition Lean.LevelMax.unlift {A : Type.{ℓ₁}}
    : Lean.LevelMax.{ℓ₁ ℓ₂} A → A
| (Lean.LevelMax.lift a) := a

-- /-! #brief Lean.LevelMax.lift is injective.
-- -/
-- theorem Lean.LevelMax.lift.inj {A : Type.{ℓ₁}}
--     : ∀ {a₁ a₂ : A}
--         (ω : Lean.LevelMax.lift.{ℓ₁ ℓ₂} a₁ = Lean.LevelMax.lift.{ℓ₁ ℓ₂} a₂)
--       , a₁ = a₂
-- | a .(a) (eq.refl .(Lean.LevelMax.lift.{ℓ₁ ℓ₂} a)) := rfl

/-! #brief Apply a function to a Lean.Level1.
-/
definition Lean.LevelMax.map {A : Type.{ℓ₁}} {B : Type.{ℓ₂}}
    (f : A → B)
    : Lean.LevelMax.{ℓ₁ ℓ₃} A → Lean.LevelMax.{ℓ₂ ℓ₄} B
| (Lean.LevelMax.lift a) := Lean.LevelMax.lift (f a)

/-! #brief Increasing the universe level to the max.
-/
definition LeanCat.LevelMax
    : Fun LeanCat.{ℓ₁} LeanCat.{max ℓ₁ ℓ₂}
:= { obj := Lean.LevelMax
   , hom := @Lean.LevelMax.map
   , hom_id := λ X, begin apply funext, intro x, cases x, trivial end
   , hom_circ := λ X Y Z g f, begin apply funext, intro x, cases x, trivial end
   }

/-! #brief Lift the universe level of a type by 1.
-/
@[reducible] definition Lean.Level1 (A : Type.{ℓ₁}) : Type (ℓ₁ + 1)
:= Lean.LevelMax.{ℓ₁ (ℓ₁ + 1)} A

/-! #brief Apply a function to a Lean.Level1.
-/
definition Lean.Level1.map {A : Type.{ℓ₁}} {B : Type.{ℓ₂}}
    (f : A → B)
    : Lean.Level1 A → Lean.Level1 B
:= Lean.LevelMax.map f

/-! #brief Increasing the universe level by 1.
-/
definition LeanCat.Level1
    : Fun LeanCat.{ℓ₁} LeanCat.{ℓ₁ + 1}
:= LeanCat.LevelMax.{ℓ₁ (ℓ₁ + 1)}

/- -----------------------------------------------------------------------
Bijections of categories and conjugate functors.
----------------------------------------------------------------------- -/

/-! #brief A bijection of categories.
-/
structure Cat.Bij {C : Cat.{ℓobj₁ ℓhom₁}} {D : Cat.{ℓobj₂ ℓhom₂}}
    (F : Fun C D)
    (G : Fun D C)
    : Prop
:= (id₁ : Fun.comp G F = Fun.id C)
   (id₂ : Fun.comp F G = Fun.id D)

/-! #brief Bijections of categories can be 'flipped' to the other direction.
-/
theorem Cat.Bij.flip {C : Cat.{ℓobj₁ ℓhom₁}} {D : Cat.{ℓobj₂ ℓhom₂}}
    {F : Fun C D}
    {G : Fun D C}
    (bij : Cat.Bij F G)
    : Cat.Bij G F
:= { id₁ := bij^.id₂
   , id₂ := bij^.id₁
   }

/-! #brief Bijections have unique inverses.
-/
theorem Cat.Bij.inv_uniq₂ {C : Cat.{ℓobj₁ ℓhom₁}} {D : Cat.{ℓobj₂ ℓhom₂}}
    {F : Fun C D}
    {G₁ G₂ : Fun D C}
    (bij₁ : Cat.Bij F G₁)
    (bij₂ : Cat.Bij F G₂)
    : G₁ = G₂
:= by calc G₁  = G₁ □□ Fun.id D : by rw Fun.comp_id_right
           ... = G₁ □□ (F □□ G₂) : by rw bij₂^.id₂
           ... = G₁ □□ F □□ G₂   : by rw Fun.comp_assoc
           ... = Fun.id C □□ G₂ : by rw bij₁^.id₁
           ... = G₂             : by rw Fun.comp_id_left

/-! #brief Bijections have unique inverses.
-/
theorem Cat.Bij.inv_uniq₁ {C : Cat.{ℓobj₁ ℓhom₁}} {D : Cat.{ℓobj₂ ℓhom₂}}
    {F₁ F₂ : Fun C D}
    {G : Fun D C}
    (bij₁ : Cat.Bij F₁ G)
    (bij₂ : Cat.Bij F₂ G)
    : F₁ = F₂
:= Cat.Bij.inv_uniq₂ (Cat.Bij.flip bij₁) (Cat.Bij.flip bij₂)

/-! #brief The identity functor is a bijection of categories.
-/
theorem Fun.id.Bij (C : Cat.{ℓobj ℓhom})
    : Cat.Bij (Fun.id C) (Fun.id C)
:= { id₁ := Fun.comp_id_left
   , id₂ := Fun.comp_id_left
   }

/-! #brief The composition of two bijections is again a bijection.
-/
theorem Fun.comp.bij
    {B : Cat.{ℓobj₁ ℓhom₁}} {C : Cat.{ℓobj₂ ℓhom₂}} {D : Cat.{ℓobj₃ ℓhom₃}}
    {F₂ : Fun C D} {G₂ : Fun D C} (bij₂ : Cat.Bij F₂ G₂)
    {F₁ : Fun B C} {G₁ : Fun C B} (bij₁ : Cat.Bij F₁ G₁)
    : Cat.Bij (Fun.comp F₂ F₁) (Fun.comp G₁ G₂)
:= { id₁
      := by calc
          G₁ □□ G₂ □□ (F₂ □□ F₁)
              = G₁ □□ (G₂ □□ F₂) □□ F₁  : by repeat { rw Fun.comp_assoc }
          ... = G₁ □□ Fun.id C □□ F₁    : by rw bij₂^.id₁
          ... = G₁ □□ F₁                : by rw Fun.comp_id_right
          ... = Fun.id B                : by rw bij₁^.id₁
   , id₂
      := by calc
          F₂ □□ F₁ □□ (G₁ □□ G₂)
              = F₂ □□ (F₁ □□ G₁) □□ G₂  : by repeat { rw Fun.comp_assoc }
          ... = F₂ □□ (Fun.id C) □□ G₂  : by rw bij₁^.id₂
          ... = F₂ □□ G₂                : by rw Fun.comp_id_right
          ... = Fun.id D                : by rw bij₂^.id₂
   }

/-! #brief The casting functor.
-/
definition CastFun
    : ∀ {C₁ C₂ : Cat.{ℓobj ℓhom}}
        (ω : C₁ = C₂)
       , Fun C₁ C₂
| C .(C) (eq.refl .(C)) := Fun.id C

/-! #brief The casting functor is trivial on eq.refl.
-/
theorem CastFun.refl
    : ∀ {C : Cat.{ℓobj ℓhom}}
         (ω : C = C)
      , CastFun ω = Fun.id C
| C (eq.refl .(C)) := rfl

/-! #brief The casting functor is compatible with transitivity.
-/
theorem CastFun.trans
    : ∀ {C₁ C₂ C₃ : Cat.{ℓobj ℓhom}}
        (ω₂₃ : C₂ = C₃)
        (ω₁₂ : C₁ = C₂)
      , CastFun ω₂₃ □□ CastFun ω₁₂ = CastFun (eq.trans ω₁₂ ω₂₃)
| C .(C) .(C) (eq.refl .(C)) (eq.refl .(C)) := Fun.comp_id_right

/-! #brief The casting functor is a bijection of categories.
-/
theorem CastFun.Bij
    : ∀ {C₁ C₂ : Cat.{ℓobj ℓhom}}
         (ω₁₂ : C₁ = C₂)
         (ω₂₁ : C₂ = C₁)
      , Cat.Bij (CastFun ω₁₂) (CastFun ω₂₁)
| C .(C) (eq.refl .(C)) (eq.refl .(C)) := Fun.id.Bij C

/-! #brief A pair of conjugate functors.
-/
structure Fun.Conj {C₁ C₂ : Cat.{ℓobj₁ ℓhom₁}} {D₁ D₂ : Cat.{ℓobj₂ ℓhom₂}}
    (FC₁₂ : Fun C₁ C₂) (FC₂₁ : Fun C₂ C₁)
    (FD₁₂ : Fun D₁ D₂) (FD₂₁ : Fun D₂ D₁)
    (F₁ : Fun C₁ D₁) (F₂ : Fun C₂ D₂)
    : Prop
:= (dom_bij : Cat.Bij FC₁₂ FC₂₁)
   (codom_bij : Cat.Bij FD₁₂ FD₂₁)
   (id₂ : F₂ = Fun.comp (Fun.comp FD₁₂ F₁) FC₂₁)

theorem Fun.Conj.outside {C₁ C₂ : Cat.{ℓobj₁ ℓhom₁}} {D₁ D₂ : Cat.{ℓobj₂ ℓhom₂}}
    {FC₁₂ : Fun C₁ C₂} {FC₂₁ : Fun C₂ C₁}
    {FD₁₂ : Fun D₁ D₂} {FD₂₁ : Fun D₂ D₁}
    {F₁ : Fun C₁ D₁} {F₂ : Fun C₂ D₂}
    (conj : Fun.Conj FC₁₂ FC₂₁ FD₁₂ FD₂₁ F₁ F₂)
    : Fun.comp FD₂₁ F₂ = Fun.comp F₁ FC₂₁
:= by calc FD₂₁ □□ F₂
               = FD₂₁ □□ (FD₁₂ □□ F₁ □□ FC₂₁) : by rw conj^.id₂
           ... = (FD₂₁ □□ FD₁₂) □□ F₁ □□ FC₂₁ : by repeat {rw Fun.comp_assoc}
           ... = Fun.id D₁ □□ F₁ □□ FC₂₁     : by rw conj^.codom_bij^.id₁
           ... = F₁ □□ FC₂₁                   : by rw Fun.comp_id_left

theorem Fun.Conj.inside {C₁ C₂ : Cat.{ℓobj₁ ℓhom₁}} {D₁ D₂ : Cat.{ℓobj₂ ℓhom₂}}
    {FC₁₂ : Fun C₁ C₂} {FC₂₁ : Fun C₂ C₁}
    {FD₁₂ : Fun D₁ D₂} {FD₂₁ : Fun D₂ D₁}
    {F₁ : Fun C₁ D₁} {F₂ : Fun C₂ D₂}
    (conj : Fun.Conj FC₁₂ FC₂₁ FD₁₂ FD₂₁ F₁ F₂)
    : Fun.comp F₂ FC₁₂ = Fun.comp FD₁₂ F₁
:= by calc F₂ □□ FC₁₂
               = (FD₁₂ □□ F₁ □□ FC₂₁) □□ FC₁₂ : by rw conj^.id₂
           ... = FD₁₂ □□ F₁ □□ (FC₂₁ □□ FC₁₂) : by repeat {rw Fun.comp_assoc}
           ... = FD₁₂ □□ F₁ □□ Fun.id C₁     : by rw conj^.dom_bij^.id₁
           ... = FD₁₂ □□ F₁                  : by rw Fun.comp_id_right

theorem Fun.Conj.id₁ {C₁ C₂ : Cat.{ℓobj₁ ℓhom₁}} {D₁ D₂ : Cat.{ℓobj₂ ℓhom₂}}
    {FC₁₂ : Fun C₁ C₂} {FC₂₁ : Fun C₂ C₁}
    {FD₁₂ : Fun D₁ D₂} {FD₂₁ : Fun D₂ D₁}
    {F₁ : Fun C₁ D₁} {F₂ : Fun C₂ D₂}
    (conj : Fun.Conj FC₁₂ FC₂₁ FD₁₂ FD₂₁ F₁ F₂)
    : Fun.comp (Fun.comp FD₂₁ F₂) FC₁₂ = F₁
:= by calc FD₂₁ □□ F₂ □□ FC₁₂
               = FD₂₁ □□ (FD₁₂ □□ F₁ □□ FC₂₁) □□ FC₁₂   : by rw conj^.id₂
           ... = (FD₂₁ □□ FD₁₂) □□ F₁ □□ (FC₂₁ □□ FC₁₂) : by repeat {rw Fun.comp_assoc}
           ... = Fun.id D₁ □□ F₁ □□ Fun.id C₁           : by rw [conj^.dom_bij^.id₁, conj^.codom_bij^.id₁]
           ... = F₁                                     : by rw [Fun.comp_id_left, Fun.comp_id_right]

/-! #brief Conjugate functors can be 'flipped' to the other direction.
-/
theorem Fun.conj {C₁ C₂ : Cat.{ℓobj₁ ℓhom₁}} {D₁ D₂ : Cat.{ℓobj₂ ℓhom₂}}
    {FC₁₂ : Fun C₁ C₂} {FC₂₁ : Fun C₂ C₁}
    {FD₁₂ : Fun D₁ D₂} {FD₂₁ : Fun D₂ D₁}
    {F₁ : Fun C₁ D₁} {F₂ : Fun C₂ D₂}
    (conj : Fun.Conj FC₁₂ FC₂₁ FD₁₂ FD₂₁ F₁ F₂)
    : Fun.Conj FC₂₁ FC₁₂ FD₂₁ FD₁₂ F₂ F₁
:= { dom_bij := Cat.Bij.flip conj^.dom_bij
   , codom_bij := Cat.Bij.flip conj^.codom_bij
   , id₂ := eq.symm conj^.id₁
   }

/- -----------------------------------------------------------------------
Over-categories over final objects.
----------------------------------------------------------------------- -/

/-! #brief The over-category over a final is iso to the original category.
-/
definition OverFinal.to (C : Cat.{ℓobj ℓhom})
    [C_HasFinal : HasFinal C]
    : Fun C (OverCat C (final C))
:= { obj := λ c, { obj := c, hom := final_hom c }
   , hom := λ c₁ c₂ f, { hom := f, triangle := eq.symm (final_hom.uniq C) }
   , hom_id := λ c, OverHom.eq rfl
   , hom_circ := λ c₁ c₂ c₃ g f, OverHom.eq rfl
   }

/-! #brief The over-category over a final is iso to the original category.
-/
definition OverFinal.from (C : Cat.{ℓobj ℓhom})
    [C_HasFinal : HasFinal C]
    : Fun (OverCat C (final C)) C
:= { obj := λ c, c^.obj
   , hom := λ c₁ c₂ f, f^.hom
   , hom_id := λ c, rfl
   , hom_circ := λ c₁ c₂ c₃ g f, rfl
   }

/-! #brief The over-category over a final is iso to the original category.
-/
definition OverFinal.Bij (C : Cat.{ℓobj ℓhom})
    [C_HasFinal : HasFinal C]
    : Cat.Bij (OverFinal.to C) (OverFinal.from C)
:= { id₁ := rfl
   , id₂ := Fun.eq
             (λ c, OverObj.eq rfl (heq_of_eq (eq.symm (final_hom.uniq C))))
             (λ ω x y f, OverHom.heq (ω _) (ω _) (heq.refl _))
   }

/- -----------------------------------------------------------------------
Forgetful functors between the algebraic categories.
----------------------------------------------------------------------- -/

/-! #brief The forgetful functor from CatOfMonoids to CatOfSemigroups.
-/
definition FrgtMonoidSemigroupFun
    : Fun CatOfMonoids.{ℓ₁} CatOfSemigroups.{ℓ₁}
:= { obj := λ A
            , { fst := A^.fst
              , snd := @monoid.to_semigroup A^.fst A^.snd
              }
   , hom := λ A B f
            , { val := f^.val
              , property := monoid.hom.to_hom f^.property
              }
   , hom_id := λ A, subtype.eq rfl
   , hom_circ := λ A B C g f, subtype.eq rfl
   }

/-! #brief The forgetful functor from CatOfGroups to CatOfMonoids.
-/
definition FrgtGroupMonoidFun
    : Fun CatOfGroups.{ℓ₁} CatOfMonoids.{ℓ₁}
:= { obj := λ A
            , { fst := A^.fst
              , snd := @group.to_monoid A^.fst A^.snd
              }
   , hom := λ A B f
            , { val := f^.val
              , property := @group.hom.to_monoid_hom _ A^.snd _ B^.snd _ f^.property
              }
   , hom_id := λ A, subtype.eq rfl
   , hom_circ := λ A B C g f, subtype.eq rfl
   }

/- -----------------------------------------------------------------------
Functors between categories induced by monoids and groups.
----------------------------------------------------------------------- -/

/-! #brief Every monoid homomorphism induces a functor.
-/
definition MonoidFun
    {A : Type ℓ₁} [A_monoid : monoid A]
    {B : Type ℓ₁} [B_monoid : monoid B]
    {f : A → B}
    (f_hom : monoid.hom f)
    : Fun (MonoidCat A) (MonoidCat B)
:= { obj := λ u, punit.star
   , hom := λ u₁ u₂ a, f a
   , hom_id := λ u, f_hom^.id
   , hom_circ := λ u₁ u₂ u₃ a₂ a₁, f_hom^.dist a₂ a₁
   }

/-! #brief Every group homomorphism induces a functor.
-/
definition GroupFun
    {A : Type ℓ₁} [A_group : group A]
    {B : Type ℓ₁} [B_group : group B]
    {f : A → B}
    (f_hom : group.hom f)
    : Fun (GroupCat A) (GroupCat B)
:= MonoidFun (group.hom.to_monoid_hom f_hom)

/- -----------------------------------------------------------------------
Functors between preorder categories.
----------------------------------------------------------------------- -/

/-! #brief Every monotone function induces a functor.
-/
definition PreorderFun
    {A : Type ℓ₁} {r : A → A → Prop}
    {r_refl : reflexive r} {r_trans : transitive r}
    {B : Type ℓ₂} {s : B → B → Prop}
    {s_refl : reflexive s} {s_trans : transitive s}
    (f : A → B)
    (f_monotone : monotone r s f)
    : Fun (PreorderCat r r_refl r_trans) (PreorderCat s s_refl s_trans)
:= { obj := f
   , hom := f_monotone
   , hom_id := λ a, proof_irrel _ _
   , hom_circ := λ a₁ a₂ a₃ g f, proof_irrel _ _
   }

@[simp] definition PreorderFun.simp_obj
    {A : Type ℓ₁} {r : A → A → Prop}
    {r_refl : reflexive r} {r_trans : transitive r}
    {B : Type ℓ₂} {s : B → B → Prop}
    {s_refl : reflexive s} {s_trans : transitive s}
    (f : A → B)
    (f_monotone : monotone r s f)
    (a : A)
    : (@PreorderFun A r r_refl r_trans B s s_refl s_trans f f_monotone)^.obj a = f a
:= rfl

@[simp] definition PreorderFun.simp_hom
    {A : Type ℓ₁} {r : A → A → Prop}
    {r_refl : reflexive r} {r_trans : transitive r}
    {B : Type ℓ₂} {s : B → B → Prop}
    {s_refl : reflexive s} {s_trans : transitive s}
    (f : A → B)
    (f_monotone : monotone r s f)
    {a₁ a₂ : A} (ω : r a₁ a₂)
    : (@PreorderFun A r r_refl r_trans B s s_refl s_trans f f_monotone)^.hom ω = f_monotone a₁ a₂ ω
:= rfl

/-! #brief Every function induces a functor between object categories.
-/
definition ObjFun {A : Type ℓ₁} {B : Type ℓ₂} (f : A → B)
    : Fun (ObjCat A) (ObjCat B)
:= PreorderFun f (λ a₁ a₂, congr_arg f)

@[simp] definition ObjFun.simp_obj {A : Type ℓ₁} {B : Type ℓ₂} (f : A → B)
    (a : A)
    : (ObjFun f)^.obj a = f a
:= rfl

@[simp] definition ObjFun.simp_hom {A : Type ℓ₁} {B : Type ℓ₂} (f : A → B)
    {a₁ a₂ : A} (ω : a₁ = a₂)
    : (ObjFun f)^.hom ω = congr_arg f ω
:= rfl

/- -----------------------------------------------------------------------
Functors out of product categories.
----------------------------------------------------------------------- -/

/-! #brief Left-projection out of a product category.
-/
definition ProdCat.π₁ (C : Cat.{ℓobj₁ ℓhom₁}) (D : Cat.{ℓobj₂ ℓhom₂})
    : Fun (ProdCat C D) C
:= { obj := λ x, x^.fst
   , hom := λ x y f, f^.fst
   , hom_id := λ x, rfl
   , hom_circ := λ x y z g f, rfl
   }

/-! #brief Right-projection out of a product category.
-/
definition ProdCat.π₂ (C : Cat.{ℓobj₁ ℓhom₁}) (D : Cat.{ℓobj₂ ℓhom₂})
    : Fun (ProdCat C D) D
:= { obj := λ x, x^.snd
   , hom := λ x y f, f^.snd
   , hom_id := λ x, rfl
   , hom_circ := λ x y z g f, rfl
   }

/-! #brief Pairs of functors induce functors into the product category.
-/
definition ProdCat.into {B : Cat.{ℓobj₁ ℓhom₁}} {C : Cat.{ℓobj₂ ℓhom₂}} {D : Cat.{ℓobj₃ ℓhom₃}}
    (l : Fun B C)
    (r : Fun B D)
    : Fun B (ProdCat C D)
:= { obj := λ b, { fst := l^.obj b, snd := r^.obj b }
   , hom := λ b₁ b₂ f, { fst := l^.hom f, snd := r^.hom f }
   , hom_id := λ b, begin rw [l^.hom_id, r^.hom_id], trivial end
   , hom_circ := λ b₁ b₂ b₃ g f, begin rw [l^.hom_circ, r^.hom_circ], trivial end
   }

/-! #brief Factoring through Product.into.
-/
theorem ProdCat.π₁_into {B : Cat.{ℓobj₁ ℓhom₁}} {C : Cat.{ℓobj₂ ℓhom₂}} {D : Cat.{ℓobj₃ ℓhom₃}}
    {l : Fun B C}
    {r : Fun B D}
    : Fun.comp (ProdCat.π₁ C D) (ProdCat.into l r) = l
:= begin
     apply Fun.eq,
     { intro b, trivial },
     { intros ωobj b₁ b₂ f, trivial },
   end

/-! #brief Factoring through Product.into.
-/
theorem ProdCat.π₂_into {B : Cat.{ℓobj₁ ℓhom₁}} {C : Cat.{ℓobj₂ ℓhom₂}} {D : Cat.{ℓobj₃ ℓhom₃}}
    {l : Fun B C}
    {r : Fun B D}
    : Fun.comp (ProdCat.π₂ C D) (ProdCat.into l r) = r
:= begin
     apply Fun.eq,
     { intro b, trivial },
     { intros ωobj b₁ b₂ f, trivial },
   end

/-! #brief ProdCat.into on the projections is trivial.
-/
theorem ProdCat.into_π {C : Cat.{ℓobj₁ ℓhom₁}} {D : Cat.{ℓobj₂ ℓhom₂}}
    : ProdCat.into (ProdCat.π₁ C D) (ProdCat.π₂ C D) = Fun.id (ProdCat C D)
:= begin
     apply Fun.eq,
     { intro cd, cases cd with c d, trivial },
     { intros ωobj cd₁ cd₂ f, cases f with f₁ f₂, trivial }
   end

/-! #brief Composition of ProdCat.into.
-/
theorem ProdCat.into.comp
    {A : Cat.{ℓobj₁ ℓhom₁}}
    {B : Cat.{ℓobj₂ ℓhom₂}}
    {C : Cat.{ℓobj₃ ℓhom₃}}
    {D : Cat.{ℓobj₄ ℓhom₄}}
    {E : Cat.{ℓobj₅ ℓhom₅}}
    {l₁ : Fun A B} {r₁ : Fun A C}
    {l₂ : Fun (ProdCat B C) D} {r₂ : Fun (ProdCat B C) E}
    : Fun.comp (ProdCat.into l₂ r₂) (ProdCat.into l₁ r₁)
       = ProdCat.into (Fun.comp l₂ (ProdCat.into l₁ r₁))
                      (Fun.comp r₂ (ProdCat.into l₁ r₁))
:= begin
     apply Fun.eq,
     { intro a, trivial },
     { intros ωobj a₁ a₂ f, trivial },
   end

/-! #brief Flipping the order of a product.
-/
definition ProdCat.flip (C : Cat.{ℓobj₁ ℓhom₁}) (D : Cat.{ℓobj₂ ℓhom₂})
    : Fun (ProdCat C D) (ProdCat D C)
:= ProdCat.into (ProdCat.π₂ C D) (ProdCat.π₁ C D)

/-! #brief Flipping the order of a product is a bijection of categories.
-/
theorem ProdCat.flip.Bij (C : Cat.{ℓobj₁ ℓhom₁}) (D : Cat.{ℓobj₂ ℓhom₂})
    : Cat.Bij (ProdCat.flip C D) (ProdCat.flip D C)
:= { id₁ := begin
              unfold ProdCat.flip,
              rw [ProdCat.into.comp, ProdCat.π₂_into, ProdCat.π₁_into, ProdCat.into_π]
            end
   , id₂ := begin
              unfold ProdCat.flip,
              rw [ProdCat.into.comp, ProdCat.π₂_into, ProdCat.π₁_into, ProdCat.into_π]
            end
   }

/- -----------------------------------------------------------------------
Functors and opposite categories.
----------------------------------------------------------------------- -/

/-! #brief Casting into OpCat OpCat.
-/
definition OpCat_OpCat.inFun (C : Cat.{ℓobj ℓhom})
    : Fun C (OpCat (OpCat C))
:= CastFun (eq.symm (OpCat_OpCat C))

/-! #brief Casting out of OpCat OpCat.
-/
definition OpCat_OpCat.outFun (C : Cat.{ℓobj ℓhom})
    : Fun (OpCat (OpCat C)) C
:= CastFun (OpCat_OpCat C)

/-! #brief OpCat_OpCat.inFun and OpCat_OpCat.outFun form a bijection.
-/
definition OpCat_OpCat.Bij (C : Cat.{ℓobj ℓhom})
    : Cat.Bij (OpCat_OpCat.inFun C) (OpCat_OpCat.outFun C)
:= CastFun.Bij _ _

/-! #brief The opposite functor.
-/
definition OpFun {C : Cat.{ℓobj₁ ℓhom₁}} {D : Cat.{ℓobj₂ ℓhom₂}}
    (F : Fun C D)
    : Fun (OpCat C) (OpCat D)
:= { obj := λ c, F^.obj c
   , hom := λ c₁ c₂ f, F^.hom f
   , hom_id := λ c, F^.hom_id
   , hom_circ := λ c₁ c₂ c₃ g f, F^.hom_circ
   }

@[simp] theorem OpFun.simp_obj {C : Cat.{ℓobj₁ ℓhom₁}} {D : Cat.{ℓobj₂ ℓhom₂}}
    (F : Fun C D)
    (x : (OpCat C)^.obj)
    : (OpFun F)^.obj x = F^.obj x
:= rfl

@[simp] theorem OpFun.simp_hom {C : Cat.{ℓobj₁ ℓhom₁}} {D : Cat.{ℓobj₂ ℓhom₂}}
    (F : Fun C D)
    {x₁ x₂ : (OpCat C)^.obj} (f : (OpCat C)^.hom x₁ x₂)
    : (OpFun F)^.hom f = F^.hom f
:= rfl

/-! #brief The opposite functor preserves identity functors.
-/
theorem OpFun.id {C : Cat.{ℓobj ℓhom}}
    : OpFun (Fun.id C) = Fun.id (OpCat C)
:= begin
     apply Fun.eq,
     { intro c, trivial },
     { intros ωobj c₁ c₂ f, trivial }
   end

/-! #brief The opposite functor distributes over composition.
-/
theorem OpFun.comp {B : Cat.{ℓobj₁ ℓhom₁}} {C : Cat.{ℓobj₂ ℓhom₂}} {D : Cat.{ℓobj₃ ℓhom₃}}
    {G : Fun C D}
    {F : Fun B C}
    : OpFun (Fun.comp G F) = Fun.comp (OpFun G) (OpFun F)
:= begin
     apply Fun.eq,
     { intro c, trivial },
     { intros ωobj c₁ c₂ f, trivial }
   end

/-! #brief OpFun preserves bijections.
-/
theorem OpFun.Bij {C : Cat.{ℓobj₁ ℓhom₁}} {D : Cat.{ℓobj₂ ℓhom₂}}
    {F : Fun C D} {G : Fun D C}
    (bij : Cat.Bij F G)
    : Cat.Bij (OpFun F) (OpFun G)
:= { id₁ := by calc OpFun G □□ OpFun F
                        = OpFun (G □□ F)   : by rw OpFun.comp
                    ... = OpFun (Fun.id C) : by rw bij^.id₁
                    ... = Fun.id (OpCat C) : by rw OpFun.id
   , id₂ := by calc OpFun F □□ OpFun G
                        = OpFun (F □□ G)   : by rw OpFun.comp
                    ... = OpFun (Fun.id D) : by rw bij^.id₂
                    ... = Fun.id (OpCat D) : by rw OpFun.id
   }

/-! #brief OpFun sends OpCat_OpCat.inFun to OpCat_OpCat.outFun.
-/
theorem OpFun.inFun {C : Cat.{ℓobj ℓhom}}
    : OpFun (OpCat_OpCat.inFun C) = OpCat_OpCat.outFun (OpCat C)
:= begin cases C, exact OpFun.id end

/-! #brief OpFun sends OpCat_OpCat.outFun to OpCat_OpCat.inFun.
-/
theorem OpFun.outFun {C : Cat.{ℓobj ℓhom}}
    : OpFun (OpCat_OpCat.outFun C) = OpCat_OpCat.inFun (OpCat C)
:= begin cases C, exact OpFun.id end

/-! #brief OpFun is nearly an involution.
-/
definition OpFun_OpFun.Conj {C : Cat.{ℓobj₁ ℓhom₁}} {D : Cat.{ℓobj₂ ℓhom₂}}
    (F : Fun C D)
    : Fun.Conj _ _ _ _  F (OpFun (OpFun F))
:= { dom_bij := (OpCat_OpCat.Bij C)
   , codom_bij := (OpCat_OpCat.Bij D)
   , id₂ := begin
              apply Fun.eq,
              { intro c, cases C, cases D, trivial },
              { intros ωobj c₁ c₂ f, cases C, cases D, trivial }
            end
   }

/- -----------------------------------------------------------------------
Preservation of initial and final.
----------------------------------------------------------------------- -/

/-! #brief A functor which preserves final objects.
-/
class PresFinal {C : Cat.{ℓobj₁ ℓhom₁}} {D : Cat.{ℓobj₂ ℓhom₂}}
    (F : Fun C D)
    : Type (max ℓobj₁ ℓhom₁ ℓobj₂ ℓhom₂)
:= (hom : ∀ [C_HasFinal : HasFinal C]
            (d : D^.obj)
          , D^.hom d (F^.obj (final C)))
   (pres : ∀ [C_HasFinal : HasFinal C]
           , IsFinal D (F^.obj (final C)) hom)

/-! #brief Functors which preserve final objects yield instances of HasFinal.
-/
instance PresFinal.HasFinal {C : Cat.{ℓobj₁ ℓhom₁}} {D : Cat.{ℓobj₂ ℓhom₂}}
    [C_HasFinal : HasFinal C]
    (F : Fun C D) [F_PresFinal : PresFinal F]
    : HasFinal D
:= { obj := F^.obj (final C)
   , hom := PresFinal.hom F
   , final := PresFinal.pres F
   }

/-! #brief A functor which preserves initial objects.
-/
@[class] definition PresInit {C : Cat.{ℓobj₁ ℓhom₁}} {D : Cat.{ℓobj₂ ℓhom₂}}
    (F : Fun C D)
    : Type (max ℓobj₁ ℓhom₁ ℓobj₂ ℓhom₂)
:= PresFinal (OpFun F)
-- := (hom : ∀ [C_HasInit : HasInit C]
--             (d : D^.obj)
--           , D^.hom (F^.obj (init C)) d)
--    (pres : ∀ [C_HasInit : HasInit C]
--            , IsInit D (F^.obj (init C)) hom)

/-! #brief Functors which preserve initial objects yield instances of HasInit.
-/
instance PresInit.HasInit {C : Cat.{ℓobj₁ ℓhom₁}} {D : Cat.{ℓobj₂ ℓhom₂}}
    [C_HasInit : HasInit C]
    (F : Fun C D) [F_PresInit : PresInit F]
    : HasInit D
:= @PresFinal.HasFinal (OpCat C) (OpCat D) C_HasInit (OpFun F) F_PresInit

/- -----------------------------------------------------------------------
Functors and over and under categories.
----------------------------------------------------------------------- -/

/-! #brief Functor from OverCat.
-/
definition OverFun.out (C : Cat.{ℓobj₁ ℓhom₁}) (c : C^.obj)
    : Fun (OverCat C c) C
:= { obj := λ x, x^.obj
   , hom := λ x y f, f^.hom
   , hom_id := λ x, rfl
   , hom_circ := λ x y z g f, rfl
   }

/-! #brief Functors induce functors of over categories.
-/
definition OverFun {C : Cat.{ℓobj₁ ℓhom₁}} {D : Cat.{ℓobj₂ ℓhom₂}}
    (X : C^.obj)
    (F : Fun C D)
    : Fun (OverCat C X) (OverCat D (F^.obj X))
:= { obj := λ A, OverObj.mk (F^.obj A^.dom) (F^.hom A^.down)
   , hom := λ A B f, OverHom.mk (F^.hom f^.hom) (by rw [f^.triangle, F^.hom_circ])
   , hom_id := λ A, OverHom.eq F^.hom_id
   , hom_circ := λ a b c g f, OverHom.eq F^.hom_circ
   }

/-! #brief Heterogeneous equality for OverFun.
-/
theorem OverFun.heq {C : Cat.{ℓobj₁ ℓhom₁}} {D : Cat.{ℓobj₂ ℓhom₂}}
    {X : C^.obj}
    : ∀ {F₁ F₂ : Fun C D}
         (ω : F₁ = F₂)
      , OverFun X F₁ == OverFun X F₂
| F .(F) (eq.refl .(F)) := heq.refl _

/-! #brief OverFun preserves identity functors.
-/
theorem OverFun.id {C : Cat.{ℓobj₁ ℓhom₁}} (X : C^.obj)
    : OverFun X (Fun.id C) = Fun.id (OverCat C X)
:= begin
     apply Fun.eq,
     { intro a, apply OverObj.eq,
       { trivial },
       { trivial }
     },
     { intros ωobj a b f,
       apply OverHom.heq (ωobj _) (ωobj _),
       { trivial }
     }
   end

/-! #brief OverFun distributes over composition of functors.
-/
theorem OverFun.comp {B : Cat.{ℓobj₁ ℓhom₁}} {C : Cat.{ℓobj₂ ℓhom₂}} {D : Cat.{ℓobj₃ ℓhom₃}}
    {X : B^.obj} {G : Fun C D} {F : Fun B C}
    : OverFun X (Fun.comp G F) = Fun.comp (OverFun (F^.obj X) G) (OverFun X F)
:= begin
     apply Fun.eq,
     { intro a, trivial },
     { intros ωobj a b f, trivial }
   end

/-! #brief Functors induce functors of under categories.
-/
definition UnderFun {C : Cat.{ℓobj₁ ℓhom₁}} {D : Cat.{ℓobj₂ ℓhom₂}}
    (X : C^.obj)
    (F : Fun C D)
    : Fun (UnderCat C X) (UnderCat D (F^.obj X))
:= OpFun (@OverFun (OpCat C) (OpCat D) X (OpFun F))

/-! #brief UnderFun sends identity functors to identity functors.
-/
theorem UnderFun.id {C : Cat.{ℓobj₁ ℓhom₁}} (X : C^.obj)
    : UnderFun X (Fun.id C) = Fun.id (UnderCat C X)
:= by calc OpFun (@OverFun C⁻¹ C⁻¹ X (OpFun (Fun.id C)))
               = OpFun (@OverFun C⁻¹ C⁻¹ X (Fun.id C⁻¹)) : congr_arg OpFun (eq_of_heq (OverFun.heq OpFun.id))
           ... = OpFun (Fun.id (OverCat C⁻¹ X))          : congr_arg OpFun (OverFun.id X)
           ... = Fun.id (C\\X)                           : OpFun.id

/-! #brief UnderFun distributes over composition of functors.
-/
theorem UnderFun.comp {B : Cat.{ℓobj₁ ℓhom₁}} {C : Cat.{ℓobj₂ ℓhom₂}} {D : Cat.{ℓobj₃ ℓhom₃}}
    (X : B^.obj) (G : Fun C D) (F : Fun B C)
    : UnderFun X (Fun.comp G F) = Fun.comp (UnderFun (F^.obj X) G) (UnderFun X F)
:= by calc OpFun (@OverFun B⁻¹ D⁻¹ X (OpFun (G □□ F)))
               = OpFun (@OverFun B⁻¹ D⁻¹ X (OpFun G □□ OpFun F))                                       : congr_arg OpFun (eq_of_heq (OverFun.heq OpFun.comp))
           ... = OpFun (@OverFun C⁻¹ D⁻¹ ((OpFun F)^.obj X) (OpFun G) □□ @OverFun B⁻¹ C⁻¹ X (OpFun F)) : congr_arg OpFun (@OverFun.comp B⁻¹ C⁻¹ D⁻¹ X (OpFun G) (OpFun F))
           ... = OpFun (@OverFun C⁻¹ D⁻¹ (F^.obj X) (OpFun G)) □□ OpFun (@OverFun B⁻¹ C⁻¹ X (OpFun F)) : OpFun.comp

/-! #brief Under and over categories are dual concepts.
-/
definition Under_dual_Over (C : Cat.{ℓobj ℓhom}) (X : C^.obj)
    : UnderCat C X = OpCat (OverCat (OpCat C) X)
:= rfl

/-! #brief Over and under categories are dual concepts.
-/
definition Over_dual_Under (C : Cat.{ℓobj ℓhom}) (X : C^.obj)
    : OverCat C X = OpCat (UnderCat (OpCat C) X)
:= begin cases C, trivial end

/- -----------------------------------------------------------------------
Cone and co-cone categories.
----------------------------------------------------------------------- -/

/-! #brief An object in a cone category.
-/
structure Cone {C : Cat.{ℓobj₁ ℓhom₁}} {D : Cat.{ℓobj₂ ℓhom₂}}
    (F : Fun C D)
    : Type (max ℓobj₁ ℓobj₂ ℓhom₂)
:= (obj : D^.obj)
   (hom : ∀ (c : C^.obj), D^.hom obj (F^.obj c))
   (comm : ∀ {c₁ c₂ : C^.obj} (f : C^.hom c₁ c₂)
           , hom c₂ = F^.hom f ∘∘ hom c₁)

/-! #brief Composition of a cone with a hom.
-/
definition Cone.circ {C : Cat.{ℓobj₁ ℓhom₁}} {D : Cat.{ℓobj₂ ℓhom₂}}
    {F : Fun C D} (cone : Cone F)
    {d' : D^.obj} (h : D^.hom d' cone^.obj)
    : Cone F
:= { obj := d'
   , hom := λ c, D^.circ (cone^.hom c) h
   , comm := λ c₁ c₂ f
             , begin
                 rw D^.circ_assoc,
                 apply Cat.circ.congr_left,
                 apply cone^.comm
               end
   }

/-! #brief A hom in a cone category.
-/
structure ConeHom {C : Cat.{ℓobj₁ ℓhom₁}} {D : Cat.{ℓobj₂ ℓhom₂}}
    (F : Fun C D)
    (X Y : Cone F)
    : Type ℓhom₂
:= (mediate : D^.hom X^.obj Y^.obj)
   (factor : ∀ (c : C^.obj), X^.hom c = Y^.hom c ∘∘ mediate)

/-! #brief Equality of homs in a cone category.
-/
theorem ConeHom.eq {C : Cat.{ℓobj₁ ℓhom₁}} {D : Cat.{ℓobj₂ ℓhom₂}}
    {F : Fun C D}
    {X Y : Cone F}
    : ∀ {f₁ f₂ : ConeHom F X Y}
      , f₁^.mediate = f₂^.mediate
      → f₁ = f₂
| (ConeHom.mk f ω₁) (ConeHom.mk .(f) ω₂) (eq.refl .(f)) := rfl

/-! #brief An identity hom in a cone category.
-/
definition ConeHom.id {C : Cat.{ℓobj₁ ℓhom₁}} {D : Cat.{ℓobj₂ ℓhom₂}}
    {F : Fun C D}
    (X : Cone F)
    : ConeHom F X X
:= { mediate := D^.id X^.obj
   , factor := λ c, eq.symm D^.circ_id_right
   }

@[simp] theorem ConeHom.id.simp_mediate {C : Cat.{ℓobj₁ ℓhom₁}} {D : Cat.{ℓobj₂ ℓhom₂}}
    {F : Fun C D}
    {X : Cone F}
    : (ConeHom.id X)^.mediate = D^.id X^.obj
:= rfl

/-! #brief Composition of two homs in a cone category.
-/
definition ConeHom.comp {C : Cat.{ℓobj₁ ℓhom₁}} {D : Cat.{ℓobj₂ ℓhom₂}}
    {F : Fun C D}
    {X Y Z : Cone F}
    (g : ConeHom F Y Z) (f : ConeHom F X Y)
    : ConeHom F X Z
:= { mediate := D^.circ g^.mediate f^.mediate
   , factor := λ c, by rw [D^.circ_assoc, -g^.factor, -f^.factor]
   }

@[simp] theorem ConeHom.comp.simp_mediate {C : Cat.{ℓobj₁ ℓhom₁}} {D : Cat.{ℓobj₂ ℓhom₂}}
    {F : Fun C D}
    {X Y Z : Cone F}
    {g : ConeHom F Y Z} {f : ConeHom F X Y}
    : (ConeHom.comp g f)^.mediate = D^.circ g^.mediate f^.mediate
:= rfl

/-! #brief Composition of cone homs is associative.
-/
theorem ConeHom.comp_assoc {C : Cat.{ℓobj₁ ℓhom₁}} {D : Cat.{ℓobj₂ ℓhom₂}}
    {F : Fun C D}
    {X Y Z W : Cone F}
    (h : ConeHom F Z W) (g : ConeHom F Y Z) (f : ConeHom F X Y)
    : ConeHom.comp h (ConeHom.comp g f) = ConeHom.comp (ConeHom.comp h g) f
:= ConeHom.eq D^.circ_assoc

/-! #brief Left-identity for cone hom composition.
-/
theorem ConeHom.comp_id_left {C : Cat.{ℓobj₁ ℓhom₁}} {D : Cat.{ℓobj₂ ℓhom₂}}
    {F : Fun C D}
    {A B : Cone F} {f : ConeHom F A B}
    : ConeHom.comp (ConeHom.id B) f = f
:= ConeHom.eq D^.circ_id_left

/-! #brief Right-identity for cone hom composition.
-/
theorem ConeHom.comp_id_right {C : Cat.{ℓobj₁ ℓhom₁}} {D : Cat.{ℓobj₂ ℓhom₂}}
    {F : Fun C D}
    {A B : Cone F} {f : ConeHom F A B}
    : ConeHom.comp f (ConeHom.id A) = f
:= ConeHom.eq D^.circ_id_right

/-! #brief A cone category.
-/
definition ConeCat {C : Cat.{ℓobj₁ ℓhom₁}} {D : Cat.{ℓobj₂ ℓhom₂}}
    (F : Fun C D)
    : Cat.{(max ℓobj₁ ℓobj₂ ℓhom₂) (ℓhom₂ + 1)}
:= { obj := Cone F
   , hom := ConeHom F
   , id := ConeHom.id
   , circ := @ConeHom.comp C D F
   , circ_assoc := @ConeHom.comp_assoc C D F
   , circ_id_left := @ConeHom.comp_id_left C D F
   , circ_id_right := @ConeHom.comp_id_right C D F
   }

/-! #brief Equal functors give equal cone categories.
-/
definition ConeCat.CastFun {C : Cat.{ℓobj₁ ℓhom₁}} {D : Cat.{ℓobj₂ ℓhom₂}}
    {F₁ F₂ : Fun C D}
    (ω : F₁ = F₂)
    : Fun (ConeCat F₁) (ConeCat F₂)
:= CastFun (congr_arg ConeCat ω)

/-! #brief A co-cone category.
-/
definition CoConeCat {C : Cat.{ℓobj₁ ℓhom₁}} {D : Cat.{ℓobj₂ ℓhom₂}}
    (F : Fun C D)
    : Cat.{(max ℓobj₁ ℓobj₂ ℓhom₂) (ℓhom₂ + 1)}
:= ConeCat (OpFun F)

/-! #brief Equal functors give equal co-cone categories.
-/
definition CoConeCat.CastFun {C : Cat.{ℓobj₁ ℓhom₁}} {D : Cat.{ℓobj₂ ℓhom₂}}
    {F₁ F₂ : Fun C D}
    (ω : F₁ = F₂)
    : Fun (CoConeCat F₁) (CoConeCat F₂)
:= CastFun (congr_arg CoConeCat ω)

/-! #brief An object in a co-cone category.
-/
definition CoCone {C : Cat.{ℓobj₁ ℓhom₁}} {D : Cat.{ℓobj₂ ℓhom₂}}
    (F : Fun C D)
    : Type (max ℓobj₁ ℓobj₂ ℓhom₂)
:= (CoConeCat F)^.obj

/-! #brief Composition of a co-cone with a hom.
-/
definition CoCone.circ {C : Cat.{ℓobj₁ ℓhom₁}} {D : Cat.{ℓobj₂ ℓhom₂}}
    {F : Fun C D} (ccone : CoCone F)
    {d' : D^.obj} (h : D^.hom ccone^.obj d')
    : CoCone F
:= Cone.circ ccone h

/-! #brief Construct an object in a co-cone category.
-/
definition CoCone.mk {C : Cat.{ℓobj₁ ℓhom₁}} {D : Cat.{ℓobj₂ ℓhom₂}}
    {F : Fun C D}
    (d : D^.obj)
    (to : ∀ (c : C^.obj), D^.hom (F^.obj c) d)
    (ω : ∀ {c₁ c₂ : C^.obj} (f : C^.hom c₁ c₂)
         , to c₁ = to c₂ ∘∘ F^.hom f)
    : CoCone F
:= { obj := d
   , hom := to
   , comm := λ c₁ c₂, ω
   }

/-! #brief A hom in a co-cone category.
-/
definition CoConeHom {C : Cat.{ℓobj₁ ℓhom₁}} {D : Cat.{ℓobj₂ ℓhom₂}}
    (F : Fun C D)
    (A B : CoCone F)
    : Type ℓhom₂
:= (CoConeCat F)^.hom A B

/-! #brief Construct a hom in a co-cone category.
-/
definition CoConeHom.mk {C : Cat.{ℓobj₁ ℓhom₁}} {D : Cat.{ℓobj₂ ℓhom₂}}
    {F : Fun C D}
    {A B : CoCone F}
    (f : D^.hom B^.obj A^.obj)
    (ω : ∀ (c : C^.obj), A^.hom c = f ∘∘ B^.hom c)
    : CoConeHom F A B
:= { mediate := f
   , factor := ω
   }

/-! #brief Co-cones and cones are dual concepts.
-/
theorem CoCone_dual_Cone {C : Cat.{ℓobj₁ ℓhom₁}} {D : Cat.{ℓobj₂ ℓhom₂}}
    (F : Fun C D)
    : CoConeCat F = ConeCat (OpFun F)
:= rfl

/-! #brief Cones and co-cones are dual concepts.
-/
theorem Cone_dual_CoCone {C : Cat.{ℓobj₁ ℓhom₁}} {D : Cat.{ℓobj₂ ℓhom₂}}
    (F : Fun C D)
    : (ConeCat F) = (CoConeCat (OpFun F))
:= begin
     cases C, cases D, cases F,
     exact rfl,
   end

/- -----------------------------------------------------------------------
Functors and cone and co-cone categories.
----------------------------------------------------------------------- -/

/-! #brief Functors induce functors on cone categories by composition on the left.
-/
definition LeftConeFun {B : Cat.{ℓobj₁ ℓhom₁}} {C : Cat.{ℓobj₂ ℓhom₂}} {D : Cat.{ℓobj₃ ℓhom₃}}
    (G : Fun C D)
    (F : Fun B C)
    : Fun (ConeCat F) (ConeCat (G □□ F))
:= { obj := λ c, { obj := G^.obj c^.obj
                 , hom := λ a, G^.hom (c^.hom a)
                 , comm := λ a₁ a₂ f
                           , begin
                               rw [c^.comm f, G^.hom_circ],
                               trivial
                             end
                 }
   , hom := λ c₁ c₂ h, { mediate := G^.hom h^.mediate
                      , factor := λ b, begin dsimp, rw [h^.factor, G^.hom_circ] end
                      }
   , hom_id := λ c, ConeHom.eq G^.hom_id
   , hom_circ := λ c₁ c₂ c₃ g f, ConeHom.eq G^.hom_circ
   }

/-! #brief Functors induce functors on cone categories by composition on the right.
-/
definition RightConeFun {B : Cat.{ℓobj₁ ℓhom₁}} {C : Cat.{ℓobj₂ ℓhom₂}} {D : Cat.{ℓobj₃ ℓhom₃}}
    (G : Fun C D)
    (F : Fun B C)
    : Fun (ConeCat G) (ConeCat (G □□ F))
:= { obj := λ c, { obj := c^.obj
                 , hom := λ a, (c^.hom (F^.obj a))
                 , comm := λ a₁ a₂ f, c^.comm (F^.hom f)
                 }
   , hom := λ c₁ c₂ h, { mediate := h^.mediate
                      , factor := λ b, h^.factor (F^.obj b)
                      }
   , hom_id := λ c, rfl
   , hom_circ := λ c₁ c₂ c₃ g f, rfl
   }

/-! #brief Functors induce functors on cone categories by composition.
-/
definition ConeFun
    {A : Cat.{ℓobj₁ ℓhom₁}} {B : Cat.{ℓobj₂ ℓhom₂}} {C : Cat.{ℓobj₃ ℓhom₃}} {D : Cat.{ℓobj₄ ℓhom₄}}
    (H : Fun C D)
    (G : Fun B C)
    (F : Fun A B)
    : Fun (ConeCat G) (ConeCat (H □□ G □□ F))
:= Fun.comp (RightConeFun (Fun.comp H G) F) (LeftConeFun H G)

/-! #brief Functors induce functors on co-cone categories by composition on the left.
-/
definition LeftCoConeFun {B : Cat.{ℓobj₁ ℓhom₁}} {C : Cat.{ℓobj₂ ℓhom₂}} {D : Cat.{ℓobj₃ ℓhom₃}}
    (H : Fun C D)
    (F : Fun B C)
    : Fun (CoConeCat F) (CoConeCat (H □□ F))
:= LeftConeFun (OpFun H) (OpFun F)

/-! #brief Functors induce functors on co-cone categories by composition on the left.
-/
definition RightCoConeFun {B : Cat.{ℓobj₁ ℓhom₁}} {C : Cat.{ℓobj₂ ℓhom₂}} {D : Cat.{ℓobj₃ ℓhom₃}}
    (F : Fun C D)
    (H : Fun B C)
    : Fun (CoConeCat F) (CoConeCat (F □□ H))
:= RightConeFun (OpFun F) (OpFun H)

/-! #brief Functors induce functors on co-cone categories by composition.
-/
definition CoConeFun
    {A : Cat.{ℓobj₁ ℓhom₁}} {B : Cat.{ℓobj₂ ℓhom₂}} {C : Cat.{ℓobj₃ ℓhom₃}} {D : Cat.{ℓobj₄ ℓhom₄}}
    (H : Fun C D)
    (G : Fun B C)
    (F : Fun A B)
    : Fun (CoConeCat G) (CoConeCat (H □□ G □□ F))
:= ConeFun (OpFun H) (OpFun G) (OpFun F)

end qp


import MLIR.Semantics.Fitree

theorem Fitree.map_const:
    (Functor.mapConst: R₁ → Fitree E R₂ → Fitree E R₁)
    = Functor.map ∘ Function.const R₂ :=
  rfl

theorem Fitree.id_map (t: Fitree E R):
    id <$> t = t := by
  simp [Functor.map]
  induction t with
  | Ret _ => rfl
  | Vis _ _ ih => simp [bind, ih]

theorem Fitree.comp_map (f: R₁ → R₂) (g: R₂ → R₃) (t: Fitree E R₁):
    (g ∘ f) <$> t = g <$> f <$> t := by
  simp [Functor.map]
  induction t with
  | Ret _ => rfl
  | Vis _ _ ih => simp [bind, ih]

instance {E}: LawfulFunctor (Fitree E) where
  map_const  := Fitree.map_const
  id_map     := Fitree.id_map
  comp_map   := Fitree.comp_map

theorem Fitree.seqLeft_eq (t₁: Fitree E R₁) (t₂: Fitree E R₂):
    t₁ <* t₂ = Function.const R₂ <$> t₁ <*> t₂ := by
  simp [SeqLeft.seqLeft, Seq.seq]
  induction t₁ with
  | Ret _ => rfl
  | Vis _ _ ih => simp [bind]; funext _; simp [ih]; sorry -- rfl

theorem Fitree.seqRight_eq (t₁: Fitree E R₁) (t₂: Fitree E R₂):
    t₁ *> t₂ = Function.const R₁ id <$> t₁ <*> t₂ := by
  simp [SeqRight.seqRight, Seq.seq]
  induction t₁ with
  | Ret _ =>
    simp [Function.const, Function.comp, bind]
  | Vis _ _ ih =>
    simp [bind]; funext _; simp [ih]; sorry

theorem Fitree.pure_seq (f: R₁ → R₂) (t: Fitree E R₁):
    pure f <*> t = f <$> t :=
  rfl

theorem Fitree.map_pure (f: R₁ → R₂) (r: R₁):
    f <$> (pure r) = pure (f := Fitree E) (f r) :=
  rfl

theorem Fitree.seq_pure (f: Fitree E (R₁ → R₂)) (r: R₁):
    f <*> pure r = (fun h => h r) <$> f :=
  rfl

theorem Fitree.seq_assoc (t₁: Fitree E R₁)
    (t₂: Fitree E (R₁ → R₂)) (t₃: Fitree E (R₂ → R₃)):
    t₃ <*> (t₂ <*> t₁) = ((@Function.comp R₁ R₂ R₃) <$> t₃) <*> t₂ <*> t₁ := by
  sorry

instance {E}: LawfulApplicative (Fitree E) where
  seqLeft_eq   := Fitree.seqLeft_eq
  seqRight_eq  := Fitree.seqRight_eq
  pure_seq     := Fitree.pure_seq
  map_pure     := Fitree.map_pure
  seq_pure     := Fitree.seq_pure
  seq_assoc    := Fitree.seq_assoc

theorem Fitree.bind_pure_comp (f: R₁ → R₂) (t: Fitree E R₁):
    bind t (fun r => pure (f r)) = f <$> t :=
  rfl

theorem Fitree.bind_map (f: Fitree E (R₁ → R₂)) (t: Fitree E R₁):
    bind f (. <$> t) = f <*> t :=
  rfl

theorem Fitree.pure_bind (r: R₁) (k: R₁ → Fitree E R₂):
    bind (pure r) k = k r :=
  rfl

theorem Fitree.bind_assoc (t: Fitree E R₁)
    (k₁: R₁ → Fitree E R₂) (k₂: R₂ → Fitree E R₃):
    bind (bind t k₁) k₂ = bind t (fun x => bind (k₁ x) k₂) := by
  induction t with
  | Ret _ => rfl
  | Vis _ _ ih => simp [bind];

instance {E}: LawfulMonad (Fitree E) where
  bind_pure_comp  := Fitree.bind_pure_comp
  bind_map        := Fitree.bind_map
  pure_bind       := Fitree.pure_bind
  bind_assoc      := Fitree.bind_assoc


import category_theory.equivalence

open category_theory

variables {C : Type*} [category C]
variables {D : Type*} [category D]

lemma equiv_reflects_mono {X Y : C} (f : X ⟶ Y) (e : C ≌ D)
  (hef : mono (e.functor.map f)) : mono f :=
begin
  -- My first instinct is always to call `tidy`, to see how far it gets:
  tidy,

  -- It seems it unfolded the definition of `mono` in the goal for us,
  -- and introduced some new hypotheses. That seems pretty reasonable for this problem!

  -- If you like, you can ask `tidy` what it did by calling `tidy?`.
  -- Often some human intervention is required to clean up the output,
  -- but on this occasion it's pretty good.
  sorry
end


import str init.data.set data.set
namespace operators
open str
-- Type to know if some actions are available or if there is a deadlock
universe u
inductive completed (α : Type _)
	| deadlock {} : completed
	| some   {} : α → completed

-- Operator used to complete a STR by adding implicit transitions
-- this operator is applicable only if the execution cannot deadlock
def add_implicit_transitions
    (C A : Type)
    (str : STR C A)
    (h   : ∀ c, ∃ a ∈ str.actions c, str.execute c a ≠ ∅)
    [∀ c, decidable (str.actions c = ∅)]
: STR C (completed A) :=
{
    initial := str.initial,
    actions := λ c, if str.actions c = ∅ then
            (singleton completed.deadlock)
        else
            { oa | ∀ a ∈ str.actions c, oa = completed.some a },
    execute := λ c oa, match oa with
        | completed.deadlock  := singleton c
        | completed.some a := str.execute c a
    end
}

-- deadlock = exists a configuration without fanout
-- three potential sources of deadlock
-- + actions, if from a source there is no action fireable
-- + execute, ∀ a ∈ str.actions c, str.execute c a = ∅ , all action from c lead to empty sets when executed

def no_deadlock
  (C A : Type)
  (str : STR C A)
: Prop :=
  ∀ c,
    (str.actions c).nonempty
  ∧ ∃ a ∈ str.actions c, (str.execute c a).nonempty

def has_deadlock
  (C A : Type)
  (str : STR C A)
: Prop :=
  ∃ c,
    str.actions c = ∅
  ∨ ∀ a ∈ str.actions c, str.execute c a = ∅

def deadlock_configuration
  {C A : Type}
  (str : STR C A)
  (c : C)
: Prop :=
  str.actions c = ∅
  ∨ ∀ a ∈ str.actions c, str.execute c a = ∅

@[simp]
def add_implicit_steps
  (C A : Type)
  (str : STR C A)
  [∀ c, decidable (str.actions c = ∅)]
  [∀ c, decidable (∀ a ∈ str.actions c, str.execute c a = ∅)]
: STR C (completed A) :=
{
  initial := str.initial,
  actions := λ c,
              if  str.actions c = ∅
                ∨ ∀ a ∈ str.actions c, str.execute c a = ∅
              then
                  singleton completed.deadlock
              else
                  { oa | ∀ a ∈ str.actions c, oa = (completed.some a)},
  execute := λ c oa, match oa with
        | completed.deadlock  := singleton c
        | completed.some a := str.execute c a
        end
}

def actions_empty
  (C A : Type) (str : STR C A) (c : C) :=
str.actions c = ∅
def all_executions_block (C A : Type) (str : STR C A) (c : C) :=
(∀ a ∈ str.actions c, str.execute c a = ∅)

def add_implicit_steps'
  (C A : Type)
  (str : STR C A)
  -- [∀ c, decidable (str.actions c = ∅)]
  -- [∀ c, decidable (∀ a ∈ str.actions c, str.execute c a = ∅)]
: STR C (completed A) :=
{
  initial := str.initial,
  actions := λ c, { a | (str.actions c = ∅ ∨ (∀ a ∈ str.actions c, str.execute c a = ∅) → a = completed.deadlock)
                        ∨ ∀ oa ∈ str.actions c, a = (completed.some oa)},
  execute := λ c oa, match oa with
        | completed.deadlock  := singleton c
        | completed.some a := str.execute c a
        end
}

theorem add_imp_rem_deadlock
  (C: Type)
  (A: Type)
  [hA : inhabited A]
  (str : STR C A)
  (deadlock : ¬ no_deadlock C A str)
  [∀ c, decidable (str.actions c = ∅)]
  [∀ c, decidable (∀ (a : A), a ∈ str.actions c → str.execute c a = ∅)]
  [∀ c, decidable (deadlock_configuration str c)]
:
  no_deadlock C (completed A) (add_implicit_steps C A str)
:=
begin
  simp * at *, intro, simp at *, split_ifs,
    finish *,
    split, sorry,

    revert h, simp at *,
    refine classical.skolem.mpr _, refine ex_of_psig _, refine ⟨_, _⟩,
  intro, exact completed.deadlock,

  refine imp_and_distrib.mpr _, split,
  revert deadlock, unfold no_deadlock,

  simp * at *, intros, revert ᾰ_1, refine not_imp.mpr _, split,
  revert ᾰ, refine imp_or_distrib.mpr _, refine or.inl _, safe *,
   sorry,
  -- -- hint,
  -- refine not_imp.mpr _, norm_num, revert ᾰ, exact set.not_nonempty_iff_eq_empty.mp, simp [not_nonempty_iff_eq_empty],

  sorry, sorry
end

end operators


/-
Copyright (c) 2018 Mario Carneiro. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Mario Carneiro

! This file was ported from Lean 3 source module data.list.dedup
! leanprover-community/mathlib commit f694c7dead66f5d4c80f446c796a5aad14707f0e
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathlib.Data.List.Nodup

/-!
# Erasure of duplicates in a list

This file proves basic results about `List.dedup` (definition in `Data.List.Defs`).
`dedup l` returns `l` without its duplicates. It keeps the earliest (that is, rightmost)
occurrence of each.

## Tags

duplicate, multiplicity, nodup, `nub`
-/

universe u

namespace List

variable {α : Type u} [DecidableEq α]

@[simp]
theorem dedup_nil : dedup [] = ([] : List α) :=
  rfl
#align list.dedup_nil List.dedup_nil

theorem dedup_cons_of_mem' {a : α} {l : List α} (h : a ∈ dedup l) : dedup (a :: l) = dedup l :=
  pwFilter_cons_of_neg <| by simpa only [forall_mem_ne, not_not] using h
#align list.dedup_cons_of_mem' List.dedup_cons_of_mem'

theorem dedup_cons_of_not_mem' {a : α} {l : List α} (h : a ∉ dedup l) :
    dedup (a :: l) = a :: dedup l :=
  pwFilter_cons_of_pos <| by simpa only [forall_mem_ne] using h
#align list.dedup_cons_of_not_mem' List.dedup_cons_of_not_mem'

@[simp]
theorem mem_dedup {a : α} {l : List α} : a ∈ dedup l ↔ a ∈ l := by
  have := not_congr (@forall_mem_pwFilter α (· ≠ ·) _ ?_ a l)
  simpa only [dedup, forall_mem_ne, not_not] using this
  intros x y z xz
  exact not_and_or.1 <| mt (fun h ↦ h.1.trans h.2) xz

#align list.mem_dedup List.mem_dedup

@[simp]
theorem dedup_cons_of_mem {a : α} {l : List α} (h : a ∈ l) : dedup (a :: l) = dedup l :=
  dedup_cons_of_mem' <| mem_dedup.2 h
#align list.dedup_cons_of_mem List.dedup_cons_of_mem

@[simp]
theorem dedup_cons_of_not_mem {a : α} {l : List α} (h : a ∉ l) : dedup (a :: l) = a :: dedup l :=
  dedup_cons_of_not_mem' <| mt mem_dedup.1 h
#align list.dedup_cons_of_not_mem List.dedup_cons_of_not_mem

theorem dedup_sublist : ∀ l : List α, dedup l <+ l :=
  pwFilter_sublist
#align list.dedup_sublist List.dedup_sublist

theorem dedup_subset : ∀ l : List α, dedup l ⊆ l :=
  pwFilter_subset
#align list.dedup_subset List.dedup_subset

theorem subset_dedup (l : List α) : l ⊆ dedup l := fun _ => mem_dedup.2
#align list.subset_dedup List.subset_dedup

theorem nodup_dedup : ∀ l : List α, Nodup (dedup l) :=
  pairwise_pwFilter
#align list.nodup_dedup List.nodup_dedup

theorem dedup_eq_self {l : List α} : dedup l = l ↔ Nodup l :=
  pwFilter_eq_self
#align list.dedup_eq_self List.dedup_eq_self

protected theorem Nodup.dedup {l : List α} (h : l.Nodup) : l.dedup = l :=
  List.dedup_eq_self.2 h
#align list.nodup.dedup List.Nodup.dedup

@[simp]
theorem dedup_idempotent {l : List α} : dedup (dedup l) = dedup l :=
  pwFilter_idempotent
#align list.dedup_idempotent List.dedup_idempotent

theorem dedup_append (l₁ l₂ : List α) : dedup (l₁ ++ l₂) = l₁ ∪ dedup l₂ := by
  induction' l₁ with a l₁ IH; · rfl
  simp only [instUnionList, cons_union] at *
  rw [← IH, cons_append]
  by_cases h : a ∈ dedup (l₁ ++ l₂)
  · rw [dedup_cons_of_mem' h, insert_of_mem h]
  · rw [dedup_cons_of_not_mem' h, insert_of_not_mem h]
#align list.dedup_append List.dedup_append

theorem replicate_dedup {x : α} : ∀ {k}, k ≠ 0 → (replicate k x).dedup = [x]
  | 0, h => (h rfl).elim
  | 1, _ => rfl
  | n + 2, _ => by
    rw [replicate_succ, dedup_cons_of_mem (mem_replicate.2 ⟨n.succ_ne_zero, rfl⟩),
      replicate_dedup n.succ_ne_zero]
#align list.replicate_dedup List.replicate_dedup

theorem count_dedup (l : List α) (a : α) : l.dedup.count a = if a ∈ l then 1 else 0 := by
  simp_rw [count_eq_of_nodup <| nodup_dedup l, mem_dedup]
#align list.count_dedup List.count_dedup

/-- Summing the count of `x` over a list filtered by some `p` is just `countp` applied to `p` -/
theorem sum_map_count_dedup_filter_eq_countp (p : α → Bool) (l : List α) :
    ((l.dedup.filter p).map fun x => l.count x).sum = l.countp p := by
  induction' l with a as h
  · simp
  · simp_rw [List.countp_cons, List.count_cons', List.sum_map_add]
    congr 1
    · refine' _root_.trans _ h
      by_cases ha : a ∈ as
      · simp [dedup_cons_of_mem ha]
      · simp only [dedup_cons_of_not_mem ha, List.filter]
        match p a with
        | true => simp only [List.map_cons, List.sum_cons, List.count_eq_zero.2 ha, zero_add]
        | false => simp only
    · by_cases hp : p a
      · refine' _root_.trans (sum_map_eq_nsmul_single a _ fun _ h _ => by simp [h]) _
        simp [hp, count_dedup]
      · refine' _root_.trans (List.sum_eq_zero fun n hn => _) (by simp [hp])
        obtain ⟨a', ha'⟩ := List.mem_map.1 hn
        split_ifs at ha' with ha
        · simp only [ha, mem_filter, mem_dedup, find?, mem_cons, true_or, hp,
            and_false, false_and] at ha'
        · exact ha'.2.symm
#align list.sum_map_count_dedup_filter_eq_countp List.sum_map_count_dedup_filter_eq_countp

theorem sum_map_count_dedup_eq_length (l : List α) :
    (l.dedup.map fun x => l.count x).sum = l.length := by
  simpa using sum_map_count_dedup_filter_eq_countp (fun _ => True) l
#align list.sum_map_count_dedup_eq_length List.sum_map_count_dedup_eq_length

end List


import lambda_calculus.notation
import lambda_calculus.utlc.basic
import lambda_calculus.utlc.identities
import lambda_calculus.utlc.reduction
import logic.relation

namespace lambda_calculus
namespace utlc
namespace η

local notation a `[` b `:=` c  `]` : 70 := has_substitution.substitution a b c

variables {f g f' g' x y z: utlc}

@[simp]
def head_step : utlc → utlc → Prop := λ f g, f = Λ (g ↑¹ 0)·↓0

instance : has_η_reduction utlc := ⟨ reduction_step_of head_step ⟩

@[simp] theorem down_step {n: ℕ}: ¬ ↓n →η g :=
begin
  simp [has_η_reduction.step, reduction_step],
end

theorem lambda_step_lambda : f →η g → (Λ f) →η (Λ g) :=
begin
  intro p,
  simp [has_η_reduction.step, reduction_step],
  exact or.inr p
end

theorem lambda_step_head (f: utlc): Λ (f ↑¹ 0)·↓0 →η f :=
by simp [has_η_reduction.step, reduction_step]

theorem lambda_step_head': f = (g ↑¹ 0)·↓0 → Λ f →η g :=
by { intro p, rw[p], exact lambda_step_head _ }

theorem lambda_step_iff: Λ f →η g ↔ (∃ x, g = x ∧ f = (x ↑¹ 0)·↓0) ∨ (∃ x, g = Λ x ∧ f →η x) :=
by simp [has_η_reduction.step, reduction_step]

theorem lambda_step_cases : Λ f →η g → (∃ x, g = Λ x ∧ f →η x ∨ g = x ∧ f = (x ↑¹ 0)·↓0) :=
begin
  simp [has_η_reduction.step, reduction_step],
  intro p,
  cases p,
  use g,
  exact or.inr ⟨rfl, p⟩,
  cases g,
  all_goals { simp [has_η_reduction.step, reduction_step] at * },
  any_goals { contradiction },
  use g,
  exact or.inl ⟨rfl, p⟩,
end

theorem lambda_step_cases': Λ f →η g → (∃ x, g = Λ x ∧ f →η x) ∨ ∃ x, g = x ∧ f = (x ↑¹ 0)·↓0 :=
begin
  intro p,
  cases lambda_step_cases p,
  cases h,
  left,
  use w,
  assumption,
  right,
  use w,
  assumption,
end

theorem dot_step_dot_left : f →η f' → (f·g) →η (f'·g) :=
begin
  intro p,
  simp [has_η_reduction.step, reduction_step],
  exact or.inl p,
end

theorem dot_step_dot_right : g →η g' → (f·g) →η (f·g') :=
begin
  intro p,
  simp [has_η_reduction.step, reduction_step],
  exact or.inr p,
end

theorem dot_step_iff: (f·f') →η g ↔ ∃ x x', g = x·x' ∧ (x' = f' ∧ f →η x ∨ x = f ∧ f' →η x') :=
begin
  cases g,
  all_goals { simp [has_η_reduction.step, and_assoc] },
end

theorem dot_step_iff': (f·f') →η g ↔ (∃ x x', x' = f' ∧ g = x·x' ∧ f →η x) ∨ (∃ x x', x = f ∧ g = x·x' ∧ f' →η x') :=
begin
  cases g,
  all_goals { simp [has_η_reduction.step, and_assoc] },
end

theorem dot_step_cases: (f·f') →η g → ∃ x x', g = x·x' ∧ (x' = f' ∧ f →η x ∨ x = f ∧ f' →η x') :=
begin
  cases g,
  all_goals { simp [has_η_reduction.step, and_assoc] },
end

theorem dot_step_cases': (f·f') →η g → (∃ x x', x' = f' ∧ g = x·x' ∧ f →η x) ∨ (∃ x x', x = f ∧ g = x·x' ∧ f' →η x') :=
begin
  cases g,
  all_goals { simp [has_η_reduction.step, and_assoc] },
end

theorem reduction_step_shift (n: ℕ): f ↑¹ n →η g ↑¹ n → f →η g :=
begin
  induction f generalizing g n,
  { simp[down_shift] },
  { simp,
    intro p,
    cases lambda_step_cases p with x p,
    cases p with p p,
    { cases p with hgx hfx,
      have h: (g ↑¹ n).uses n = x.uses (n + 1),
      { simp [hgx, uses] },
      have h: ∃ y, x = y ↑¹ (n+1),
      { apply shift_of_uses_zero,
        rw [← h],
        simp [shift_uses] },
      cases h with y hy,
      rw [hy,
          ← show (Λ y) ↑¹ n = Λ y ↑¹ (n+1), by simp,
          shift_inj_iff] at hgx,
      rw [hgx],
      apply lambda_step_lambda,
      apply f_ih,
      rw [← hy],
      apply hfx },
    { cases p with hgx hfx,
      -- rw [← hgx, ← shift_comm] at hfx,
      apply lambda_step_head',
      rw [← shift_inj_iff (n + 1), hfx],
      simp [down_shift],
      rw [← shift_comm_zero, hgx] } },
  { simp,
    intro p,
    cases g;
    try { simp[has_η_reduction.step, reduction_step, dot_step_iff, down_shift] at p,
      contradiction },
    rcases dot_step_cases p with ⟨x, y, hgxy, p⟩,
    simp at hgxy,
    simp,
    cases p with p p,
    cases p with hfy hfx,
    simp [hfy] at hgxy,
    rw [hgxy.right],
    rw [← hgxy.left] at hfx,
    exact dot_step_dot_left (f_ih_f _ hfx),
    cases p with hfx hfy,
    simp [hfx] at hgxy,
    rw [hgxy.left],
    rw [← hgxy.right] at hfy,
    exact dot_step_dot_right (f_ih_g _ hfy)
     }
end

theorem reduction_step_uses: f →η g → ∀ n, f.uses n = g.uses n :=
begin
  induction f generalizing g,
  { all_goals { simp } },
  { intros p n,
    cases lambda_step_cases p with x p,
    cases p with p p,
    { simp [uses, p.left], exact f_ih p.right _},
    { simp [uses, p, show 0 ≠ n + 1, by linarith] } },
  {
    intros p m,
    rcases dot_step_cases p with ⟨x, y, hg, p⟩,
    cases p with p p,
    { simp [p.left, hg, uses],
      apply f_ih_f p.right },
    { simp [p.left, hg, uses],
      apply f_ih_g p.right } }
end

theorem reduction_step_size: f →η g → f.size = g.size + 3 :=
begin
  induction f generalizing g;
  simp,
  simp [lambda_step_iff],
  intro p,
  cases p,
  { rw [p], simp },
  { rcases p with ⟨x, hgx, hfx⟩,
    simp [f_ih hfx, hgx] },
  { intro p,
    rcases dot_step_cases p with ⟨x, y, hgxy, p⟩,
    cases p with p p;
    rcases p with ⟨heq, hstep⟩,
    simp [f_ih_f hstep, hgxy, ← heq],
    ring,
    simp [f_ih_g hstep, hgxy, ← heq],
    ring,
  }
end

theorem reduction_step_size_mono: f →η g → g.size < f.size :=
by intro p; simp [reduction_step_size p]

@[simp] theorem down_reduction_iff {n: ℕ}: ↓n ↠η g ↔ g = ↓n :=
begin
  split;
  intro p,
  cases relation.refl_trans_gen.cases_head p,
  { apply h.symm },
  { simp at h, contradiction },
  rw [p],
end

theorem lambda_reduction_lambda: f ↠η f' → Λ f ↠η Λ f' :=
begin
  intro p,
  induction p,
  { refl },
  apply relation.refl_trans_gen.tail,
  assumption,
  apply lambda_step_lambda,
  assumption,
end

theorem dot_reduction_dot_left: f ↠η f' → f·g ↠η f'·g :=
begin
  intro p,
  induction p,
  { refl },
  apply relation.refl_trans_gen.tail,
  assumption,
  apply dot_step_dot_left,
  assumption,
end

theorem dot_reduction_dot_right: g ↠η g' → f·g ↠η f·g' :=
begin
  intro p,
  induction p,
  { refl },
  apply relation.refl_trans_gen.tail,
  assumption,
  apply dot_step_dot_right,
  assumption,
end

theorem dot_reduction_dot: f ↠η f' → g ↠η g' → f·g ↠η f'·g' :=
begin
  intros p q,
  apply trans,
  apply dot_reduction_dot_left,
  assumption,
  apply dot_reduction_dot_right,
  assumption,
end

theorem dot_exists_reduction (h: f ↠η g): ∀ {m n}, f = m·n → ∃ x y, g = x·y ∧ m ↠η x ∧ n ↠η y :=
begin
  induction h using relation.refl_trans_gen.head_induction_on with f f' hf hfg ih,
  { intros m n p,
    refine ⟨ m, n, p, by refl, by refl⟩ },
  { intros m n p,
    rw [p] at hf,
    rcases dot_step_cases hf with ⟨a, b, hab, h⟩,
    rcases ih hab with ⟨i, j, ih⟩,
    refine ⟨i, j, ih.left, trans _ ih.right.left, trans _ ih.right.right⟩;
    cases h;
    try { simp[h] };
    cases h;
    try { apply relation.refl_trans_gen.single, assumption } }
end

theorem dot_reduction_cases (h: f·f' ↠η g): ∃ x y, g = x·y ∧ f ↠η x ∧ f' ↠η y := dot_exists_reduction h rfl

theorem dot_reduction_dot_iff: f·g ↠η f'·g' ↔ f ↠η f' ∧ g ↠η g' :=
begin
  split,
  { intro p,
    have h := dot_exists_reduction p rfl,
    simp [and.assoc] at h,
    assumption },
  intro p,
  apply dot_reduction_dot p.left p.right,
end

theorem shift_head_step_shift {n: ℕ}: head_step (f ↑¹ n) (g ↑¹ n) ↔ head_step f g :=
begin
  cases f;
  cases g;
  try { simp };
  cases f;
  try { simp[down_shift] };
  cases f_f;
  cases f_g;
  simp [down_shift];
  split_ifs;
  simp;
  try { simp [← @shift_comm 1 (n + 1) _ (by linarith)] };
  try { simp [← @shift_comm 0 n _ (by linarith)] };
  repeat { intro };
  try { linarith };
  split;
  intro;
  try { linarith },
  rw [← @shift_inj_iff _ (n + 1 + 1), shift_comm],
  assumption,
  linarith,
  rw [← shift_comm, shift_inj_iff],
  assumption,
  linarith,
end

theorem head_step_substitution: head_step f f' → ∀ n g, f[n:=g] ↠η f'[n:=g]  :=
begin
  simp only [head_step],
  intros p n g,
  simp [p],
  apply relation.refl_trans_gen.single,
  apply lambda_step_head',
  simp,
  apply substitution_shift_ge,
  apply nat.zero_le _,
end

def head_reduced : utlc → bool
| (↓ _):= true
| (Λ f) := match f with
  | (↓ _) := true
  | (Λ _) := true
  | (f·g) := f.uses 0 > 0 ∨ g ≠ ↓0
  end
| (_·_) := true

def reduced := reduced_of head_reduced

theorem head_reduced_iff_not_head_step: head_reduced f ↔ ∀ g, ¬ head_step f g :=
begin
  cases f;
  try { cases f };
  simp[head_reduced],
  split,
  { intros p g q,
    cases p,
    exfalso,
    apply (ne_of_lt p).symm,
    rw [q],
    apply shift_uses_self,
    assumption },
  intros p,
  obtain h|h|h := nat.lt_trichotomy (f_f.uses 0) 0,
  { simp at h, contradiction },
  { cases shift_of_uses_zero h with g h,
    right,
    apply p g h },
  { left, apply h },
end

theorem reduced_iff_not_reduction (f: utlc): reduced f ↔ ∀ g, ¬ f →η g :=
  reduced_iff_not_reduction_step @head_reduced_iff_not_head_step _

@[simp] theorem down_reduced (n: ℕ): reduced ↓n := by simp [reduced, head_reduced, down_reduced]

theorem lambda_reduced (f: utlc): reduced (Λ f) ↔ head_reduced (Λ f) ∧ reduced f :=
by simp [reduced, head_reduced, lambda_reduced]

@[simp] theorem dot_reduced (f g: utlc): reduced (f·g) ↔ reduced f ∧ reduced g := by simp [reduced, head_reduced, dot_reduced]

-- inductive hypothesis useful when dealing with η reductions
-- splits (Λ f·↓0) up to handle the (Λ f)·g ⇔ f[0:=g] case
-- theorem η_induction_on (p: utlc → Prop): Π (f: utlc)
--   (down: Π n, p ↓n)
--   (dot_lambda: Π x (hx: p x) (h: x.uses 0 = 0), p (Λ x·↓0))
--   (lambda: Π x (hx: p x) (h: head_reduced x), p (Λ x))
--   (dot : Π x y (hx: p x) (hy: p y), p (x·y)),
--   (p f)
-- | (↓n) := λ hn hx hdx hlx, hn n
-- | (Λ x) := λ hn hx hdx hlx, hx x (β_induction_on x hn hx hdx hlx)

end η
end utlc
end lambda_calculus


/-
Copyright (c) 2018 Jeremy Avigad. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Author: Jeremy Avigad

The initial algebra of a multivariate qpf is again a qpf.
-/
import ..mvpfunctor.M .basic
universe u

namespace mvqpf
open typevec
open mvfunctor (liftp liftr)

variables {n : ℕ} {F : typevec.{u} (n+1) → Type u} [mvfunctor F] [q : mvqpf F]
include q

def corecF {α : typevec n} {β : Type*} (g : β → F (α.append1 β)) : β → q.P.M α :=
q.P.M_corec (λ x, repr (g x))

theorem corecF_eq {α : typevec n} {β : Type*} (g : β → F (α.append1 β)) (x : β) :
  q.P.M_dest (corecF g x) = append_fun id (corecF g) <$$> repr (g x) :=
by rw [corecF, q.P.M_dest_corec]

def is_precongr {α : typevec n} (r : q.P.M α → q.P.M α → Prop) : Prop :=
  ∀ ⦃x y⦄, r x y →
    abs (append_fun id (quot.mk r) <$$> q.P.M_dest x) =
      abs (append_fun id (quot.mk r) <$$> q.P.M_dest y)

def Mcongr {α : typevec n} : q.P.M α → q.P.M α → Prop :=
λ x y, ∃ r, is_precongr r ∧ r x y

def cofix (F : typevec (n + 1) → Type u) [mvfunctor F] [q : mvqpf F] (α : typevec n):=
quot (@Mcongr _ F _ q α)

def cofix.map {α β : typevec n} (g : α ⟹ β) : cofix F α → cofix F β :=
quot.lift (λ x : q.P.M α, quot.mk Mcongr (g <$$> x))
  begin
    rintros a₁ a₂ ⟨r, pr, ra₁a₂⟩, apply quot.sound,
    let r' := λ b₁ b₂, ∃ a₁ a₂ : q.P.M α, r a₁ a₂ ∧ b₁ = g <$$> a₁ ∧ b₂ = g <$$> a₂,
    use r', split,
    { show is_precongr r',
      rintros b₁ b₂ ⟨a₁, a₂, ra₁a₂, b₁eq, b₂eq⟩,
      let u : quot r → quot r' := quot.lift (λ x : q.P.M α, quot.mk r' (g <$$> x))
        (by { intros a₁ a₂ ra₁a₂, apply quot.sound, exact ⟨a₁, a₂, ra₁a₂, rfl, rfl⟩ }),
      have hu : (quot.mk r' ∘ λ x : q.P.M α, g <$$> x) = u ∘ quot.mk r,
        { ext x, refl },
      rw [b₁eq, b₂eq, q.P.M_dest_map, q.P.M_dest_map, ←q.P.comp_map, ←q.P.comp_map],
      rw [←append_fun_comp, id_comp, hu, hu, ←comp_id g, append_fun_comp],
      rw [q.P.comp_map, q.P.comp_map, abs_map, pr ra₁a₂, ←abs_map] },
    show r' (g <$$> a₁) (g <$$> a₂), from ⟨a₁, a₂, ra₁a₂, rfl, rfl⟩
  end

instance cofix.mvfunctor : mvfunctor (cofix F) :=
{ map := @cofix.map _ _ _ _}

def cofix.corec {α : typevec n} {β : Type u} (g : β → F (α.append1 β)) : β → cofix F α :=
λ x, quot.mk  _ (corecF g x)

def cofix.dest {α : typevec n} : cofix F α → F (α.append1 (cofix F α)) :=
quot.lift
  (λ x, append_fun id (quot.mk Mcongr) <$$> (abs (q.P.M_dest x)))
  begin
    rintros x y ⟨r, pr, rxy⟩, dsimp,
    have : ∀ x y, r x y → Mcongr x y,
    { intros x y h, exact ⟨r, pr, h⟩ },
    rw [←quot.factor_mk_eq _ _ this], dsimp,
    conv { to_lhs,
      rw [append_fun_comp_id, comp_map, ←abs_map, pr rxy, abs_map, ←comp_map,
        ←append_fun_comp_id] }
  end

theorem cofix.dest_corec {α : typevec n} {β : Type u} (g : β → F (α.append1 β)) (x : β) :
  cofix.dest (cofix.corec g x) = append_fun id (cofix.corec g) <$$> g x :=
begin
  conv { to_lhs, rw [cofix.dest, cofix.corec] }, dsimp,
  rw [corecF_eq, abs_map, abs_repr, ←comp_map, ←append_fun_comp], reflexivity
end

def cofix.mk {α : typevec n} : F (α.append1 $ cofix F α) → cofix F α :=
cofix.corec (λ x, append_fun id (λ i : cofix F α, cofix.dest.{u} i) <$$> x)

private theorem cofix.bisim_aux {α : typevec n}
    (r : cofix F α → cofix F α → Prop)
    (h' : ∀ x, r x x)
    (h : ∀ x y, r x y →
      append_fun id (quot.mk r) <$$> cofix.dest x = append_fun id (quot.mk r) <$$> cofix.dest y) :
  ∀ x y, r x y → x = y :=
begin
  intro x, apply quot.induction_on x, clear x,
  intros x y, apply quot.induction_on y, clear y,
  intros y rxy,
  apply quot.sound,
  let r' := λ x y, r (quot.mk _ x) (quot.mk _ y),
  have : is_precongr r',
  { intros a b r'ab,
      have  h₀ :
          append_fun id (quot.mk r ∘ quot.mk Mcongr) <$$> abs (q.P.M_dest a) =
          append_fun id (quot.mk r ∘ quot.mk Mcongr) <$$> abs (q.P.M_dest b) :=
        by rw [append_fun_comp_id, comp_map, comp_map]; exact h _ _ r'ab,
    have h₁ : ∀ u v : q.P.M α, Mcongr u v → quot.mk r' u = quot.mk r' v,
    { intros u v cuv, apply quot.sound, dsimp [r'], rw quot.sound cuv, apply h' },
    let f : quot r → quot r' := quot.lift (quot.lift (quot.mk r') h₁)
      begin
        intro c, apply quot.induction_on c, clear c,
        intros c d, apply quot.induction_on d, clear d,
        intros d rcd, apply quot.sound, apply rcd
      end,
    have : f ∘ quot.mk r ∘ quot.mk Mcongr = quot.mk r' := rfl,
    rw [←this, append_fun_comp_id, q.P.comp_map, q.P.comp_map, abs_map, abs_map, abs_map,
         abs_map, h₀] },
  refine ⟨r', this, rxy⟩
end

theorem cofix.bisim_rel {α : typevec n}
    (r : cofix F α → cofix F α → Prop)
    (h : ∀ x y, r x y →
      append_fun id (quot.mk r) <$$> cofix.dest x = append_fun id (quot.mk r) <$$> cofix.dest y) :
  ∀ x y, r x y → x = y :=
let r' x y := x = y ∨ r x y in
begin
  intros x y rxy,
  apply cofix.bisim_aux r',
  { intro x, left, reflexivity },
  { intros x y r'xy,
    cases r'xy, { rw r'xy },
    have : ∀ x y, r x y → r' x y := λ x y h, or.inr h,
    rw ←quot.factor_mk_eq _ _ this, dsimp,
    rw [append_fun_comp_id, append_fun_comp_id],
    rw [@comp_map _ _ _ q _ _ _ (append_fun id (quot.mk r)),
        @comp_map _ _ _ q _ _ _ (append_fun id (quot.mk r))],
    rw h _ _ r'xy },
  right, exact rxy
end

theorem cofix.bisim {α : typevec n}
    (r : cofix F α → cofix F α → Prop)
    (h : ∀ x y, r x y → liftr (rel_last α r) (cofix.dest x) (cofix.dest y)) :
  ∀ x y, r x y → x = y :=
begin
  apply cofix.bisim_rel,
  intros x y rxy,
  rcases (liftr_iff (rel_last α r) _ _).mp (h x y rxy) with ⟨a, f₀, f₁, dxeq, dyeq, h'⟩,
  rw [dxeq, dyeq, ←abs_map, ←abs_map, mvpfunctor.map_eq, mvpfunctor.map_eq],
  rw [←split_drop_fun_last_fun f₀, ←split_drop_fun_last_fun f₁],
  rw [append_fun_comp_split_fun, append_fun_comp_split_fun],
  rw [id_comp, id_comp],
  congr' 2, ext i j, cases i with _ i; dsimp,
  { change f₀ _ j = f₁ _ j, apply h' _ j },
  apply quot.sound,
  apply h' _ j
end

theorem cofix.bisim' {α : typevec n} {β : Type*} (Q : β → Prop) (u v : β → cofix F α)
    (h : ∀ x, Q x → ∃ a f' f₀ f₁,
      cofix.dest (u x) = abs ⟨a, q.P.append_contents f' f₀⟩ ∧
      cofix.dest (v x) = abs ⟨a, q.P.append_contents f' f₁⟩ ∧
      ∀ i, ∃ x', Q x' ∧ f₀ i = u x' ∧ f₁ i = v x') :
  ∀ x, Q x → u x = v x :=
λ x Qx,
let R := λ w z : cofix F α, ∃ x', Q x' ∧ w = u x' ∧ z = v x' in
cofix.bisim R
  (λ x y ⟨x', Qx', xeq, yeq⟩,
    begin
      rcases h x' Qx' with ⟨a, f', f₀, f₁, ux'eq, vx'eq, h'⟩,
      rw liftr_iff,
      refine ⟨a, q.P.append_contents f' f₀, q.P.append_contents f' f₁,
        xeq.symm ▸ ux'eq, yeq.symm ▸ vx'eq, _⟩,
      intro i, cases i,
      { intro j, apply eq.refl },
      apply h',
    end)
  _ _ ⟨x, Qx, rfl, rfl⟩

lemma cofix.mk_dest {α : typevec n} (x : cofix F α) : cofix.mk (cofix.dest x) = x :=
begin
  apply cofix.bisim_rel (λ x y : cofix F α, x = cofix.mk (cofix.dest y)) _ _ _ rfl, dsimp,
  intros x y h, rw h,
  conv { to_lhs, congr, skip, rw [cofix.mk], rw cofix.dest_corec},
  rw [←comp_map, ←append_fun_comp, id_comp],
  rw [←comp_map, ←append_fun_comp, id_comp, ←cofix.mk],
  congr' 2,
  ext u, apply quot.sound, refl
end

lemma cofix.dest_mk {α : typevec n} (x : F (α.append1 $ cofix F α)) : cofix.dest (cofix.mk x) = x :=
begin
  have : cofix.mk ∘ cofix.dest = @_root_.id (cofix F α) := funext cofix.mk_dest,
  rw [cofix.mk, cofix.dest_corec, ←comp_map, ←cofix.mk, ← append_fun_comp, this, id_comp, append_fun_id_id, id_map]
end

noncomputable instance mvqpf_cofix : mvqpf (cofix F) :=
{ P         := q.P.Mp,
  abs       := λ α, quot.mk Mcongr,
  repr'     := λ α, quot.out,
  abs_repr' := λ α, quot.out_eq,
  abs_map   := λ α β g x, rfl
}

end mvqpf


import SciLean.Core.Functions
import SciLean.Tactic.RemoveLambdaLet

open Function

open SciLean

variable {α β γ : Type}
variable {X Y Z : Type} [Hilbert X] [Hilbert Y] [Hilbert Z]

example (f : Y → Z) (g : X → Y) (z : Z) [HasAdjoint f] [HasAdjoint g] : (f ∘ g)† z = g† (f† z) := by simp; done
example (f g : X → Y) [HasAdjoint f] [HasAdjoint g] (y : Y) : (λ x => f x + g x)† y = f† y + g† y := by simp; done

example (y : Y) (r : ℝ)
  : (λ x => ⟪x,y⟫)† r = r*y := by simp; done
example (y : X) (r : ℝ)
  : (λ x => ⟪x,y⟫ + ⟪y,x⟫)† r = r * y + r * y := by simp; done
example (r : ℝ) (x' : X)
  : (λ x : X => r*((λ x'' => ⟪x', x''⟫) x))† = λ s => (r * s) * x' := by simp; done

example {n : Nat} (a : Fin n) [Nonempty (Fin n)]
  : (λ (f : Fin n → ℝ) i => f (i - a))† = (λ (f : Fin n → ℝ) x => f (x + a)) :=
  by funext f i; simp[sum_into_lambda]; done
example {ι} [Enumtype ι]
  : (λ x : ι → X => sum x)† = (λ (x : X) (i : ι) => x) := by simp done
example {n} (c : Fin n)  [Nonempty (Fin n)]
  : (λ (g : Fin n → ℝ) => (λ i => g (i+c)))† = (fun f x => f (x - c)) := by simp[Function.comp,sum_into_lambda]; done

example {ι} [Enumtype ι] (f : ι → X → Y) [∀ i, HasAdjoint (f i)]
  : (λ x i => f i x)† = (λ y => ∑ i, (f i)† (y i)) := by funext y; simp done
example {ι} [Enumtype ι] [Nonempty ι] (f : ι → X → Y) [∀ i, HasAdjoint (f i)]
  : (λ (g : ι → X) i => f i (g i))† = (λ h i => (1:ℝ) * ((f i)† (h i))) := by funext h i; simp[sum_into_lambda]; done

example (y : ℝ) : (λ x : ℝ => x * y)† 1 = ⟪1,y⟫ := by simp done
example (y : ℝ) : (λ x : ℝ => y * x)† 1 = y := by simp done

-- set_option trace.Meta.Tactic.simp.discharge true in
example (a b : ℝ) (x : X)
  : (λ dx : X => (a * ⟪x, dx⟫) * b)† 1 = (a * ⟪1,b⟫) * x :=
by simp; unfold hold; simp done

example {ι} [Enumtype ι] [Nonempty ι] (i : ι) (c : ℝ)
  : (fun (x : ι → ℝ) => x i * c)† 1 = (fun j => kron i j * ⟪1,c⟫)
  := by simp; unfold hold; simp done

example -- [NonZero n]
  : (λ (x : Fin n → ℝ) => sum λ i => x i)† 1 = (λ i => (1 : ℝ)) := by simp done

example {n} (f : Fin n → ℝ) (c : Fin n) [Nonempty (Fin n)]
  : (λ (g : Fin n → ℝ) => sum (λ i => (f i) * (g (i+c))))† (1 : ℝ) = (fun i => f (i - c)) := by funext i; simp[sum_into_lambda]; done

-- set_option trace.Meta.Tactic.simp.discharge true in
-- set_option trace.Meta.Tactic.simp.rewrite true in
-- example {n} (f : Fin n → ℝ) [Nonempty (Fin n)]
--   : (fun df : Fin n → ℝ => ∑ i, df i * f i + f i * df i)† 1 = λ i => ⟪1,f i⟫ + f i := by funext i; simp; unfold hold; simp; simp only [sum_into_lambda]; done

-- example {n} (f : Fin n → ℝ) (i : Fin n) [Nonempty (Fin n)]
--   : (λ (x : Fin n → ℝ) => x i * f i)† = λ (y : ℝ) j => kron i j * ⟪y, f i⟫
--   := by funext x j; simp; unfold hold; simp done

example {X Y : Type} [Hilbert X] [Hilbert Y] : (Prod.fst : X × Y → X)† = λ x : X => (x, 0) := by simp
example {X Y : Type} [Hilbert X] [Hilbert Y] : (Prod.snd : X × Y → Y)† = λ y : Y => (0, y) := by simp
example {X Y : Type} [Hilbert X] [Hilbert Y] : (λ ((x,y) : X × Y) => x)† = λ x : X => (x, (0:Y)) := by simp
example {X Y : Type} [Hilbert X] [Hilbert Y] : (λ ((x,y) : X × Y) => y)† = λ y : Y => ((0:X), y) := by simp

set_option trace.Meta.Tactic.simp.discharge true in
example : (λ (x : Fin n → ℝ) => Function.comp (HMul.hMul 2) x)† = 0 := by rw[Function.comp.arg_g.adj_simp]; simp[comp]; admit

@[simp (low-2) ↓]
theorem asdf {ι : Type} [Enumtype ι] (f : Y → Z) [HasAdjoint f]
  : (λ (g : ι → Y) i => f (g i))† = λ (g' : ι → Z) i => f† (g' i)  := sorry

example : (λ (x : Fin n → ℝ) => ∑ i, x i)† = 0 := by simp; admit
example : (λ (x : Fin n → ℝ) => ∑ i, 1 * x i)† = 0 := by simp; admit

example : HasAdjoint (λ x : ℝ => 2 * x) := by infer_instance

set_option synthInstance.maxSize 2000 in
set_option synthInstance.maxHeartbeats 200000 in
set_option pp.funBinderTypes true in
set_option trace.Meta.Tactic.simp.rewrite true in
set_option trace.Meta.Tactic.simp.discharge true in
-- set_option trace.Meta.Tactic.simp.unify true in
example : (λ (x : Fin n → ℝ) i => 2 * x i)† = 0 :=
by
  simp -- [-SciLean.swap.arg_y.adj_simp]
  simp; admit

example : (λ (x : Fin n → ℝ) i => 2 * x i)† = 0 := by simp; admit

example : (λ (x : Fin n → ℝ) => ∑ i, 2 * x i)† = 0 := by simp; admit


import algebra.group.to_additive
import algebra.group.units
import tactic

-- work in a namespace so that it doesn't matter if names clash
namespace test
@[to_additive bar0]
def foo0 {α} [has_mul α] [has_one α] (x y : α) : α := x * y * 1

class {u v} my_has_pow (α : Type u) (β : Type v) :=
(pow : α → β → α)

class my_has_scalar (M : Type*) (α : Type*) := (smul : M → α → α)

attribute [to_additive_reorder 1] my_has_pow
attribute [to_additive_reorder 1 4] my_has_pow.pow
attribute [to_additive test.my_has_scalar] my_has_pow
attribute [to_additive test.my_has_scalar.smul] my_has_pow.pow

-- set_option pp.universes true
-- set_option pp.implicit true
-- set_option pp.notation false

@[priority 10000]
local infix ` ^ `:80 := my_has_pow.pow

@[to_additive bar1]
def foo1 {α} [my_has_pow α ℕ] (x : α) (n : ℕ) : α := @my_has_pow.pow α ℕ _ x n

instance dummy : my_has_pow ℕ $ plift ℤ := ⟨λ _ _, 0⟩

set_option pp.universes true
@[to_additive bar2]
def foo2 {α} [my_has_pow α ℕ] (x : α) (n : ℕ) (m : plift ℤ) : α := x ^ (n ^ m)

@[to_additive bar3]
def foo3 {α} [my_has_pow α ℕ] (x : α) : ℕ → α := @my_has_pow.pow α ℕ _ x

@[to_additive bar4]
def {a b} foo4 {α : Type a} : Type b → Type (max a b) := @my_has_pow α

@[to_additive bar4_test]
lemma foo4_test {α β : Type*} : @foo4 α β = @my_has_pow α β := rfl

@[to_additive bar5]
def foo5 {α} [my_has_pow α ℕ] [my_has_pow ℕ ℤ] : true := trivial

@[to_additive bar6]
def foo6 {α} [my_has_pow α ℕ] : α → ℕ → α := @my_has_pow.pow α ℕ _

@[to_additive bar7]
def foo7 := @my_has_pow.pow

open tactic
/- test the eta-expansion applied on `foo6`. -/
run_cmd do
env ← get_env,
reorder ← to_additive.reorder_attr.get_cache,
d ← get_decl `test.foo6,
let e := d.value.eta_expand env reorder,
let t := d.type.eta_expand env reorder,
let decl := declaration.defn `test.barr6 d.univ_params t e d.reducibility_hints d.is_trusted,
add_decl decl,
skip

/-! Test the namespace bug (#8733). This code should *not* generate a lemma
  `add_some_def.in_namespace`. -/
def some_def.in_namespace : bool := ff

def some_def {α : Type*} [has_mul α] (x : α) : α :=
if some_def.in_namespace then x * x else x

-- cannot apply `@[to_additive]` to `some_def` if `some_def.in_namespace` doesn't have the attribute
run_cmd do
  dict ← to_additive.aux_attr.get_cache,
  success_if_fail
    (transform_decl_with_prefix_dict dict ff tt mk_name_map mk_name_map mk_name_map
      `some_def `add_some_def []),
  skip

attribute [to_additive some_other_name] some_def.in_namespace
attribute [to_additive add_some_def] some_def

run_cmd success_if_fail (get_decl `add_some_def.in_namespace)

example : (add_units.mk_of_add_eq_zero 0 0 (by simp) : ℕ)
        = (add_units.mk_of_add_eq_zero 0 0 (by simp) : ℕ) :=
by norm_cast

-- TODO test alias

-- test @[to_additive_relevant_args] and to_additive.first_multiplicative_arg

-- first multiplicative argument: f
def foo_mul {I J K : Type*} (n : ℕ) {f : I → Type*} (L : Type*) [∀ i (n : ℕ), bool → has_one (f i)]
  [has_add I] [has_mul L] : true :=
trivial

@[to_additive]
instance pi.has_one {I : Type*} {f : I → Type*} [∀ i, has_one $ f i] : has_one (Π i : I, f i) :=
⟨λ _, 1⟩

run_cmd do
  n ← to_additive.first_multiplicative_arg `test.pi.has_one,
  guard $ n = 2,
  n ← to_additive.first_multiplicative_arg `test.foo_mul,
  guard $ n = 5

@[to_additive]
def nat_pi_has_one {α : Type*} [has_one α] : has_one (Π x : ℕ, α) := by apply_instance

@[to_additive]
def pi_nat_has_one {I : Type*} : has_one (Π x : I, ℕ) := by apply_instance

end test


/-
Copyright (c) 2020 Bhavik Mehta. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Bhavik Mehta
-/
import data.list.chain
import category_theory.is_connected
import category_theory.sigma.basic
import category_theory.full_subcategory

/-!
# Connected components of a category

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

Defines a type `connected_components J` indexing the connected components of a category, and the
full subcategories giving each connected component: `component j : Type u₁`.
We show that each `component j` is in fact connected.

We show every category can be expressed as a disjoint union of its connected components, in
particular `decomposed J` is the category (definitionally) given by the sigma-type of the connected
components of `J`, and it is shown that this is equivalent to `J`.
-/

universes v₁ v₂ v₃ u₁ u₂

noncomputable theory

open category_theory.category

namespace category_theory

attribute [instance, priority 100] is_connected.is_nonempty

variables {J : Type u₁} [category.{v₁} J]
variables {C : Type u₂} [category.{u₁} C]

/-- This type indexes the connected components of the category `J`. -/
def connected_components (J : Type u₁) [category.{v₁} J] : Type u₁ := quotient (zigzag.setoid J)

instance [inhabited J] : inhabited (connected_components J) := ⟨quotient.mk' default⟩

/-- Given an index for a connected component, produce the actual component as a full subcategory. -/
@[derive category]
def component (j : connected_components J) : Type u₁ := full_subcategory (λ k, quotient.mk' k = j)

/-- The inclusion functor from a connected component to the whole category. -/
@[derive [full, faithful], simps {rhs_md := semireducible}]
def component.ι (j) : component j ⥤ J :=
full_subcategory_inclusion _

/-- Each connected component of the category is nonempty. -/
instance (j : connected_components J) : nonempty (component j) :=
begin
  apply quotient.induction_on' j,
  intro k,
  refine ⟨⟨k, rfl⟩⟩,
end

instance (j : connected_components J) : inhabited (component j) := classical.inhabited_of_nonempty'

/-- Each connected component of the category is connected. -/
instance (j : connected_components J) : is_connected (component j) :=
begin
  -- Show it's connected by constructing a zigzag (in `component j`) between any two objects
  apply is_connected_of_zigzag,
  rintro ⟨j₁, hj₁⟩ ⟨j₂, rfl⟩,
  -- We know that the underlying objects j₁ j₂ have some zigzag between them in `J`
  have h₁₂ : zigzag j₁ j₂ := quotient.exact' hj₁,
  -- Get an explicit zigzag as a list
  rcases list.exists_chain_of_relation_refl_trans_gen h₁₂ with ⟨l, hl₁, hl₂⟩,
  -- Everything which has a zigzag to j₂ can be lifted to the same component as `j₂`.
  let f : Π x, zigzag x j₂ → component (quotient.mk' j₂) := λ x h, ⟨x, quotient.sound' h⟩,
  -- Everything in our chosen zigzag from `j₁` to `j₂` has a zigzag to `j₂`.
  have hf : ∀ (a : J), a ∈ l → zigzag a j₂,
  { intros i hi,
    apply list.chain.induction (λ t, zigzag t j₂) _ hl₁ hl₂ _ _ _ (or.inr hi),
    { intros j k,
      apply relation.refl_trans_gen.head },
    { apply relation.refl_trans_gen.refl } },
  -- Now lift the zigzag from `j₁` to `j₂` in `J` to the same thing in `component j`.
  refine ⟨l.pmap f hf, _, _⟩,
  { refine @@list.chain_pmap_of_chain _ _ _ f (λ x y _ _ h, _) hl₁ h₁₂ _,
    exact zag_of_zag_obj (component.ι _) h },
  { erw list.last_pmap _ f (j₁ :: l) (by simpa [h₁₂] using hf) (list.cons_ne_nil _ _),
    exact full_subcategory.ext _ _ hl₂ },
end

/--
The disjoint union of `J`s connected components, written explicitly as a sigma-type with the
category structure.
This category is equivalent to `J`.
-/
abbreviation decomposed (J : Type u₁) [category.{v₁} J] :=
Σ (j : connected_components J), component j

/--
The inclusion of each component into the decomposed category. This is just `sigma.incl` but having
this abbreviation helps guide typeclass search to get the right category instance on `decomposed J`.
-/
-- This name may cause clashes further down the road, and so might need to be changed.
abbreviation inclusion (j : connected_components J) : component j ⥤ decomposed J :=
sigma.incl _

/-- The forward direction of the equivalence between the decomposed category and the original. -/
@[simps {rhs_md := semireducible}]
def decomposed_to (J : Type u₁) [category.{v₁} J] : decomposed J ⥤ J :=
sigma.desc component.ι

@[simp]
lemma inclusion_comp_decomposed_to (j : connected_components J) :
  inclusion j ⋙ decomposed_to J = component.ι j :=
rfl

instance : full (decomposed_to J) :=
{ preimage :=
  begin
    rintro ⟨j', X, hX⟩ ⟨k', Y, hY⟩ f,
    dsimp at f,
    have : j' = k',
      rw [← hX, ← hY, quotient.eq'],
      exact relation.refl_trans_gen.single (or.inl ⟨f⟩),
    subst this,
    refine sigma.sigma_hom.mk f,
  end,
  witness' :=
  begin
    rintro ⟨j', X, hX⟩ ⟨_, Y, rfl⟩ f,
    have : quotient.mk' Y = j',
    { rw [← hX, quotient.eq'],
      exact relation.refl_trans_gen.single (or.inr ⟨f⟩) },
    subst this,
    refl,
  end }

instance : faithful (decomposed_to J) :=
{ map_injective' :=
  begin
    rintro ⟨_, j, rfl⟩ ⟨_, k, hY⟩ ⟨f⟩ ⟨g⟩ e,
    change f = g at e,
    subst e,
  end }

instance : ess_surj (decomposed_to J) :=
{ mem_ess_image := λ j, ⟨⟨_, j, rfl⟩, ⟨iso.refl _⟩⟩ }

instance : is_equivalence (decomposed_to J) :=
equivalence.of_fully_faithfully_ess_surj _

/-- This gives that any category is equivalent to a disjoint union of connected categories. -/
@[simps functor {rhs_md := semireducible}]
def decomposed_equiv : decomposed J ≌ J :=
(decomposed_to J).as_equivalence

end category_theory


import kassel.lemma.right_pivotal_category

open category_theory
open category_theory.monoidal_category

namespace kassel
open right_pivotal_category

namespace FinVect

variables {K: Type*} [field K]

noncomputable instance finite_dimensional.decidable_eq (V) [add_comm_group V] [module K V] [finite_dimensional K V]:
  decidable_eq (basis.of_vector_space_index K V) :=
  equiv.decidable_eq (fintype.equiv_fin (basis.of_vector_space_index K V))

lemma dual_mul {V} [add_comm_monoid V] [module K V] (f: module.dual K V) (x: V) (t: K):
  f x * t = f (t • x) :=
by rw [map_smul, smul_eq_mul, mul_comm]

lemma right_adjoint_mate_eq_dual_linear_map {X Y: FinVect K} (f: X.obj →ₗ[K] Y.obj):
  left_unitor.hom K (module.dual K X.obj) ∘ₗ
  tensor_product.map (evaluation.hom K Y.obj) linear_map.id ∘ₗ
  associator.inv K _ _ _ ∘ₗ
  tensor_product.map linear_map.id (tensor_product.map f linear_map.id) ∘ₗ
  tensor_product.map linear_map.id (coevaluation.hom K X.obj) ∘ₗ
  right_unitor.inv K (module.dual K Y.obj) =
  f.dual_map :=
begin
  ext g x,
  have b := basis.of_vector_space K X.obj,
  simp [
    map_sum, tensor_product.tmul_sum, tensor_product.map_tmul,
    coevaluation_apply_one' b, linear_map.id_apply
  ],
  simp_rw [dual_mul, ←map_sum], congr,
  simp_rw [←map_smul, ←map_sum], congr,
  rw basis.sum_repr,
end

lemma right_adjoint_mate_eq_dual {X Y: FinVect K} (f: X ⟶ Y):
  fᘁ = f.dual_map :=
by apply right_adjoint_mate_eq_dual_linear_map

lemma tensor_iso_dual_tensor_dual_apply {X Y: FinVect K} (f: module.dual K X.obj) (g: module.dual K Y.obj):
  ((δ_ X Y).inv: _ →ₗ[K] _) (g ⊗ₜ[K] f) = ↑(tensor_product.lid K K) ∘ₗ tensor_product.map f g :=
begin
  sorry,
end

lemma module.eval_equiv_to_linear_map' (V) [add_comm_group V] [module K V] [finite_dimensional K V]:
  ⇑(module.eval_equiv K V) = module.dual.eval K V :=
by rw [←module.eval_equiv_to_linear_map, linear_equiv.coe_to_linear_map]

noncomputable def right_pivotor (X: FinVect K): X ≅ Xᘁᘁ := {
  hom := right_pivotor.hom K X.obj,
  inv := right_pivotor.inv K X.obj,
  hom_inv_id' := by ext; simp [←module.eval_equiv_to_linear_map],
  inv_hom_id' := by ext; simp [←module.eval_equiv_to_linear_map]
}

lemma right_pivotor_naturality (X Y: FinVect K) (f: X ⟶ Y):
  f ≫ (right_pivotor Y).hom = (right_pivotor X).hom ≫ fᘁᘁ :=
begin
  unfold_projs at *, dsimp [right_pivotor],
  ext x g, simp [right_adjoint_mate_eq_dual, module.eval_equiv_to_linear_map'],
end

lemma right_pivotor_tensor_naturality (X Y: FinVect K):
  (right_pivotor (X ⊗ Y)).hom = ((right_pivotor X).hom ⊗ (right_pivotor Y).hom) ≫ (δ_ _ _).inv ≫ ((δ_ _ _).hom)ᘁ :=
begin
  ext x y f, unfold_projs, dsimp [right_pivotor],
  simp_rw module.eval_equiv_to_linear_map',
  simp [module.dual.eval_apply, tensor_iso_dual_tensor_dual_apply, right_adjoint_mate_eq_dual],

end

noncomputable instance right_pivotal_category: right_pivotal_category (FinVect K) := {
  right_pivotor := right_pivotor,
  right_pivotor_naturality' := right_pivotor_naturality,
  right_pivotor_tensor_naturality' := right_pivotor_tensor_naturality
}

end FinVect
end kassel


import data.nat.basic data.complex.basic data.rea l.cau_seq .exponential.series
local attribute [instance, priority 0] classical.prop_decidable
noncomputable theory
open nat is_absolute_value

lemma series_series_diag {α : Type*} [add_comm_monoid α] (f : ℕ → ℕ → α) (n : ℕ) : series (λ i,
series (λ k, f k (i - k)) i) n = series (λ i, series (λ k, f i k) (n - i)) n := begin
  have : ∀ m : ℕ, m ≤ n → series (λ (i : ℕ), series (λ k, f k (i - k)) (min m i)) n =
      series (λ i, series (λ k, f i k) (n - i)) m,
    assume m mn, induction m with m' hi,
    simp[series_succ,series_zero,mul_add,max_eq_left (zero_le n)],
    simp only [series_succ _ m'],rw ←hi (le_of_succ_le mn),clear hi,
    induction n with n' hi,
    simp[series_succ],exact absurd mn dec_trivial,cases n' with n₂,
    simp [series_succ],rw [min_eq_left mn,series_succ,min_eq_left (le_of_succ_le mn)],
    rw eq_zero_of_le_zero (le_of_succ_le_succ mn),simp,
    cases lt_or_eq_of_le mn,
    simp [series_succ _ (succ n₂),min_eq_left mn,hi (le_of_lt_succ h)],rw [←add_assoc,←add_assoc],
    suffices : series (f (succ m')) (n₂ - m') + series (λ (k : ℕ), f k (succ (succ n₂) - k)) (succ m')
    = series (f (succ m')) (succ n₂ - m') +
        series (λ (k : ℕ), f k (succ (succ n₂) - k)) (min m' (succ (succ n₂))),
      rw this,rw[min_eq_left (le_of_succ_le mn),series_succ,succ_sub_succ,succ_sub (le_of_succ_le_succ (le_of_lt_succ h)),series_succ],
      rw [add_comm (series (λ (k : ℕ), f k (succ (succ n₂) - k)) m'),add_assoc],
    rw ←h,simp[nat.sub_self],clear hi mn h,simp[series_succ,nat.sub_self],
    suffices : series (λ (i : ℕ), series (λ (k : ℕ), f k (i - k)) (min (succ m') i)) m' = series (λ (i : ℕ), series (λ (k : ℕ), f k (i - k)) (min m' i)) m',
      rw [this,min_eq_left (le_succ _)],clear n₂,
    have h₁ : ∀ i ≤ m', (λ (i : ℕ), series (λ (k : ℕ), f k (i - k)) (min (succ m') i)) i = (λ (i : ℕ), series (λ (k : ℕ), f k (i - k)) (min m' i)) i,
      assume i im,simp, rw [min_eq_right im,min_eq_right (le_succ_of_le im)],
    rw series_congr h₁,
  specialize this n (le_refl _),
  rw ←this,refine series_congr _,assume i ni,rw min_eq_right ni,
end

lemma series_merten {α β : Type*} [discrete_linear_ordered_field α] [ring β] {a b : ℕ → β}
{abv : β → α} [is_absolute_value abv] : is_cau_seq abs (series (λ n, abv (a n))) → is_cau_seq abv (series b) →
∀ ε : α, 0 < ε → ∃ i : ℕ, ∀ j ≥ i, abv (series a j * series b j - series (λ n,
series (λ m, a m * b (n - m)) n) j) < ε := begin
  assume ha hb ε ε0,
  cases seq_bounded_above_of_cau hb with Q hQ,
  cases seq_bounded_above_of_cau ha with P hP,
  have P0 : 0 < P,exact lt_of_le_of_lt (abs_nonneg _) (hP 0),
  have Pε0 := div_pos ε0 (mul_pos (show (2 : α) > 0, from by norm_num) P0),
  cases cau_seq.cauchy₂ ⟨_, hb⟩ Pε0 with N hN,simp at hN,
  have Qε0 := div_pos ε0 (mul_pos (show (4 : α) > 0, from by norm_num) (lt_of_le_of_lt (abv_nonneg _ _) (hQ 0))),
  cases cau_seq.cauchy₂ ⟨_, ha⟩ Qε0 with M hM,simp at hM,
  existsi 2 * (max N M + 1),
  assume K hK,have := diag_swap1 (λ m n, a m * b n) K,simp at this,rw this,clear this,
  have : (λ (i : ℕ), series (λ (k : ℕ), a i * b k) (K - i)) = (λ (i : ℕ), a i * series (λ (k : ℕ), b k) (K - i)),
    {apply funext,assume i,rw series_mul_left},
  rw this,clear this,simp,
  have : series (λ (i : ℕ), a i * series b (K - i)) K = series (λ (i : ℕ), a i * (series b (K - i) - series b K))
  K + series (λ i, a i * series b K) K,
    {rw ←series_add,simp[(mul_add _ _ _).symm]},
  rw this, clear this,
  rw series_mul_series,simp,
  rw abv_neg abv,
  refine lt_of_le_of_lt (abv_series_le_series_abv _) _,
  simp [abv_mul abv],
  suffices : series (λ (i : ℕ), abv (a i) * abv (series b (K - i) + -series b K)) (max N M + 1) +
  (series (λ (i : ℕ), abv (a i) * abv (series b (K - i) + -series b K)) K -series (λ (i : ℕ),
  abv (a i) * abv (series b (K - i) + -series b K)) (max N M + 1)) < ε / (2 * P) * P + ε / (4 * Q) * (2 * Q),
  { simp [(div_div_eq_div_mul _ _ _).symm] at this,
    rwa[div_mul_cancel _ (ne_of_lt P0).symm,(by norm_num : (4 : α) = 2 * 2),←div_div_eq_div_mul,mul_comm (2 : α),←mul_assoc,
    div_mul_cancel _ (ne_of_lt (lt_of_le_of_lt (abv_nonneg _ _) (hQ 0))).symm,div_mul_cancel,add_halves] at this,
    norm_num},
  refine add_lt_add _ _,
  {have : series (λ (i : ℕ), abv (a i) * abv (series b (K - i) + -series b K)) (max N M + 1) ≤ series
  (λ (i : ℕ), abv (a i) * (ε / (2 * P))) (max N M + 1),
    {refine series_le_series _,assume m mJ,refine mul_le_mul_of_nonneg_left _ _,
      {refine le_of_lt (hN (K - m) K _ _),{
      refine nat.le_sub_left_of_add_le (le_trans _ hK),
      rw[succ_mul,one_mul],
      exact add_le_add mJ (le_trans (le_max_left _ _) (le_of_lt (lt_add_one _)))},
      {refine le_trans _ hK,rw ←one_mul N,
      refine mul_le_mul (by norm_num) (by rw one_mul;exact le_trans (le_max_left _ _)
      (le_of_lt (lt_add_one _))) (zero_le _) (zero_le _)}},
      exact abv_nonneg abv _},
  refine lt_of_le_of_lt this _,
  rw [series_mul_right,mul_comm],
  specialize hP (max N M + 1),rwa abs_of_nonneg at hP,
  refine (mul_lt_mul_left Pε0).mpr hP,
  refine series_nonneg _,assume x h,exact abv_nonneg abv _},
  {have hNMK : max N M + 1 < K,
    {refine lt_of_lt_of_le _ hK,
    rw [succ_mul,one_mul,←add_zero (max N M + 1)],
    refine add_lt_add_of_le_of_lt (le_refl _) _,rw add_zero,
    refine add_pos_of_nonneg_of_pos (zero_le _) (by norm_num)},
  rw series_sub_series _ hNMK,
  have : nat.sum (λ (i : ℕ), abv (a i) * abv (series b (K - i) + -series b K)) (max N M + 2) K
  ≤ nat.sum (λ (i : ℕ), abv (a i) * (2 * Q)) (max N M + 2) K,
    {unfold nat.sum,refine series_le_series _,
    assume m hm,
    refine mul_le_mul_of_nonneg_left _ _,
    {refine le_trans (abv_add abv _ _) _,
    rw ←(by ring : Q + Q = 2 * Q),
    refine add_le_add (le_of_lt (hQ _)) _,
    rw abv_neg abv, exact le_of_lt (hQ _)},
    exact abv_nonneg abv _},
  refine lt_of_le_of_lt this _,
  rw [←series_sub_series _ hNMK,series_mul_right,series_mul_right,←sub_mul],
  refine (mul_lt_mul_right (mul_pos (by norm_num) (lt_of_le_of_lt (abv_nonneg abv _) (hQ 0)))).mpr _,
  refine lt_of_le_of_lt (le_abs_self _) _,
  refine hM _ _ _ (le_trans (le_max_right _ _) (le_of_lt (lt_add_one _))),
  refine le_trans _ hK,
  rw [succ_mul,one_mul,←add_zero M],
  exact add_le_add (le_trans (le_max_right _ _) (le_of_lt (lt_add_one _))) (zero_le _)},
end
#print series_merten