/-
Copyright (c) 2019 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Scott Morrison, Markus Himmel
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.category_theory.limits.shapes.equalizers
import Mathlib.category_theory.limits.shapes.pullbacks
import Mathlib.category_theory.limits.shapes.strong_epi
import Mathlib.PostPort

universes v u l

namespace Mathlib

/-!
# Categorical images

We define the categorical image of `f` as a factorisation `f = e ≫ m` through a monomorphism `m`,
so that `m` factors through the `m'` in any other such factorisation.

## Main definitions

* A `mono_factorisation` is a factorisation `f = e ≫ m`, where `m` is a monomorphism
* `is_image F` means that a given mono factorisation `F` has the universal property of the image.
* `has_image f` means that we have chosen an image for the morphism `f : X ⟶ Y`.
  * In this case, `image f` is the image object, `image.ι f : image f ⟶ Y` is the monomorphism `m`
    of the factorisation and `factor_thru_image f : X ⟶ image f` is the morphism `e`.
* `has_images C` means that every morphism in `C` has an image.
* Let `f : X ⟶ Y` and `g : P ⟶ Q` be morphisms in `C`, which we will represent as objects of the
  arrow category `arrow C`. Then `sq : f ⟶ g` is a commutative square in `C`. If `f` and `g` have
  images, then `has_image_map sq` represents the fact that there is a morphism
  `i : image f ⟶ image g` making the diagram

  X ----→ image f ----→ Y
  |         |           |
  |         |           |
  ↓         ↓           ↓
  P ----→ image g ----→ Q

  commute, where the top row is the image factorisation of `f`, the bottom row is the image
  factorisation of `g`, and the outer rectangle is the commutative square `sq`.
* If a category `has_images`, then `has_image_maps` means that every commutative square admits an
  image map.
* If a category `has_images`, then `has_strong_epi_images` means that the morphism to the image is
  always a strong epimorphism.

## Main statements

* When `C` has equalizers, the morphism `e` appearing in an image factorisation is an epimorphism.
* When `C` has strong epi images, then these images admit image maps.

## Future work
* TODO: coimages, and abelian categories.
* TODO: connect this with existing working in the group theory and ring theory libraries.

-/

namespace category_theory.limits

/-- A factorisation of a morphism `f = e ≫ m`, with `m` monic. -/
structure mono_factorisation {C : Type u} [category C] {X : C} {Y : C} (f : X ⟶ Y) where
  I : C
  m : I ⟶ Y
  m_mono : mono m
  e : X ⟶ I
  fac' :
    autoParam (e ≫ m = f)
      (Lean.Syntax.ident Lean.SourceInfo.none (String.toSubstring "Mathlib.obviously")
        (Lean.Name.mkStr (Lean.Name.mkStr Lean.Name.anonymous "Mathlib") "obviously") [])

@[simp] theorem mono_factorisation.fac {C : Type u} [category C] {X : C} {Y : C} {f : X ⟶ Y}
    (c : mono_factorisation f) : mono_factorisation.e c ≫ mono_factorisation.m c = f :=
  sorry

@[simp] theorem mono_factorisation.fac_assoc {C : Type u} [category C] {X : C} {Y : C} {f : X ⟶ Y}
    (c : mono_factorisation f) {X' : C} (f' : Y ⟶ X') :
    mono_factorisation.e c ≫ mono_factorisation.m c ≫ f' = f ≫ f' :=
  sorry

namespace mono_factorisation

/-- The obvious factorisation of a monomorphism through itself. -/
def self {C : Type u} [category C] {X : C} {Y : C} (f : X ⟶ Y) [mono f] : mono_factorisation f :=
  mk X f 𝟙

-- I'm not sure we really need this, but the linter says that an inhabited instance ought to exist...

protected instance inhabited {C : Type u} [category C] {X : C} {Y : C} (f : X ⟶ Y) [mono f] :
    Inhabited (mono_factorisation f) :=
  { default := self f }

/-- The morphism `m` in a factorisation `f = e ≫ m` through a monomorphism is uniquely determined. -/
theorem ext {C : Type u} [category C] {X : C} {Y : C} (f : X ⟶ Y) {F : mono_factorisation f}
    {F' : mono_factorisation f} (hI : I F = I F') (hm : m F = eq_to_hom hI ≫ m F') : F = F' :=
  sorry

end mono_factorisation

/-- Data exhibiting that a given factorisation through a mono is initial. -/
structure is_image {C : Type u} [category C] {X : C} {Y : C} {f : X ⟶ Y} (F : mono_factorisation f)
    where
  lift : (F' : mono_factorisation f) → mono_factorisation.I F ⟶ mono_factorisation.I F'
  lift_fac' :
    autoParam
      (∀ (F' : mono_factorisation f), lift F' ≫ mono_factorisation.m F' = mono_factorisation.m F)
      (Lean.Syntax.ident Lean.SourceInfo.none (String.toSubstring "Mathlib.obviously")
        (Lean.Name.mkStr (Lean.Name.mkStr Lean.Name.anonymous "Mathlib") "obviously") [])

@[simp] theorem is_image.lift_fac {C : Type u} [category C] {X : C} {Y : C} {f : X ⟶ Y}
    {F : mono_factorisation f} (c : is_image F) (F' : mono_factorisation f) :
    is_image.lift c F' ≫ mono_factorisation.m F' = mono_factorisation.m F :=
  sorry

@[simp] theorem is_image.lift_fac_assoc {C : Type u} [category C] {X : C} {Y : C} {f : X ⟶ Y}
    {F : mono_factorisation f} (c : is_image F) (F' : mono_factorisation f) {X' : C} (f' : Y ⟶ X') :
    is_image.lift c F' ≫ mono_factorisation.m F' ≫ f' = mono_factorisation.m F ≫ f' :=
  sorry

@[simp] theorem is_image.fac_lift_assoc {C : Type u} [category C] {X : C} {Y : C} {f : X ⟶ Y}
    {F : mono_factorisation f} (hF : is_image F) (F' : mono_factorisation f) {X' : C}
    (f' : mono_factorisation.I F' ⟶ X') :
    mono_factorisation.e F ≫ is_image.lift hF F' ≫ f' = mono_factorisation.e F' ≫ f' :=
  sorry

namespace is_image

/-- The trivial factorisation of a monomorphism satisfies the universal property. -/
def self {C : Type u} [category C] {X : C} {Y : C} (f : X ⟶ Y) [mono f] :
    is_image (mono_factorisation.self f) :=
  mk fun (F' : mono_factorisation f) => mono_factorisation.e F'

protected instance inhabited {C : Type u} [category C] {X : C} {Y : C} (f : X ⟶ Y) [mono f] :
    Inhabited (is_image (mono_factorisation.self f)) :=
  { default := self f }

/-- Two factorisations through monomorphisms satisfying the universal property
must factor through isomorphic objects. -/
-- TODO this is another good candidate for a future `unique_up_to_canonical_iso`.

@[simp] theorem iso_ext_hom {C : Type u} [category C] {X : C} {Y : C} {f : X ⟶ Y}
    {F : mono_factorisation f} {F' : mono_factorisation f} (hF : is_image F) (hF' : is_image F') :
    iso.hom (iso_ext hF hF') = lift hF F' :=
  Eq.refl (iso.hom (iso_ext hF hF'))

theorem iso_ext_hom_m {C : Type u} [category C] {X : C} {Y : C} {f : X ⟶ Y}
    {F : mono_factorisation f} {F' : mono_factorisation f} (hF : is_image F) (hF' : is_image F') :
    iso.hom (iso_ext hF hF') ≫ mono_factorisation.m F' = mono_factorisation.m F :=
  sorry

theorem iso_ext_inv_m {C : Type u} [category C] {X : C} {Y : C} {f : X ⟶ Y}
    {F : mono_factorisation f} {F' : mono_factorisation f} (hF : is_image F) (hF' : is_image F') :
    iso.inv (iso_ext hF hF') ≫ mono_factorisation.m F = mono_factorisation.m F' :=
  sorry

theorem e_iso_ext_hom {C : Type u} [category C] {X : C} {Y : C} {f : X ⟶ Y}
    {F : mono_factorisation f} {F' : mono_factorisation f} (hF : is_image F) (hF' : is_image F') :
    mono_factorisation.e F ≫ iso.hom (iso_ext hF hF') = mono_factorisation.e F' :=
  sorry

theorem e_iso_ext_inv {C : Type u} [category C] {X : C} {Y : C} {f : X ⟶ Y}
    {F : mono_factorisation f} {F' : mono_factorisation f} (hF : is_image F) (hF' : is_image F') :
    mono_factorisation.e F' ≫ iso.inv (iso_ext hF hF') = mono_factorisation.e F :=
  sorry

end is_image

/-- Data exhibiting that a morphism `f` has an image. -/
structure image_factorisation {C : Type u} [category C] {X : C} {Y : C} (f : X ⟶ Y) where
  F : mono_factorisation f
  is_image : is_image F

protected instance inhabited_image_factorisation {C : Type u} [category C] {X : C} {Y : C}
    (f : X ⟶ Y) [mono f] : Inhabited (image_factorisation f) :=
  { default := image_factorisation.mk (mono_factorisation.self f) (is_image.self f) }

/-- `has_image f` means that there exists an image factorisation of `f`. -/
class has_image {C : Type u} [category C] {X : C} {Y : C} (f : X ⟶ Y) where
  mk' :: (exists_image : Nonempty (image_factorisation f))

theorem has_image.mk {C : Type u} [category C] {X : C} {Y : C} {f : X ⟶ Y}
    (F : image_factorisation f) : has_image f :=
  has_image.mk' (Nonempty.intro F)

/-- The chosen factorisation of `f` through a monomorphism. -/
def image.mono_factorisation {C : Type u} [category C] {X : C} {Y : C} (f : X ⟶ Y) [has_image f] :
    mono_factorisation f :=
  image_factorisation.F (Classical.choice has_image.exists_image)

/-- The witness of the universal property for the chosen factorisation of `f` through a monomorphism. -/
def image.is_image {C : Type u} [category C] {X : C} {Y : C} (f : X ⟶ Y) [has_image f] :
    is_image (image.mono_factorisation f) :=
  image_factorisation.is_image (Classical.choice has_image.exists_image)

/-- The categorical image of a morphism. -/
/-- The inclusion of the image of a morphism into the target. -/
def image {C : Type u} [category C] {X : C} {Y : C} (f : X ⟶ Y) [has_image f] : C :=
  mono_factorisation.I sorry

def image.ι {C : Type u} [category C] {X : C} {Y : C} (f : X ⟶ Y) [has_image f] : image f ⟶ Y :=
  mono_factorisation.m (image.mono_factorisation f)

@[simp] theorem image.as_ι {C : Type u} [category C] {X : C} {Y : C} (f : X ⟶ Y) [has_image f] :
    mono_factorisation.m (image.mono_factorisation f) = image.ι f :=
  rfl

protected instance image.ι.category_theory.mono {C : Type u} [category C] {X : C} {Y : C}
    (f : X ⟶ Y) [has_image f] : mono (image.ι f) :=
  mono_factorisation.m_mono (image.mono_factorisation f)

/-- The map from the source to the image of a morphism. -/
/-- Rewrite in terms of the `factor_thru_image` interface. -/
def factor_thru_image {C : Type u} [category C] {X : C} {Y : C} (f : X ⟶ Y) [has_image f] :
    X ⟶ image f :=
  mono_factorisation.e (image.mono_factorisation f)

@[simp] theorem as_factor_thru_image {C : Type u} [category C] {X : C} {Y : C} (f : X ⟶ Y)
    [has_image f] : mono_factorisation.e (image.mono_factorisation f) = factor_thru_image f :=
  rfl

@[simp] theorem image.fac_assoc {C : Type u} [category C] {X : C} {Y : C} (f : X ⟶ Y) [has_image f]
    {X' : C} (f' : Y ⟶ X') : factor_thru_image f ≫ image.ι f ≫ f' = f ≫ f' :=
  sorry

/-- Any other factorisation of the morphism `f` through a monomorphism receives a map from the image. -/
def image.lift {C : Type u} [category C] {X : C} {Y : C} {f : X ⟶ Y} [has_image f]
    (F' : mono_factorisation f) : image f ⟶ mono_factorisation.I F' :=
  is_image.lift (image.is_image f) F'

@[simp] theorem image.lift_fac {C : Type u} [category C] {X : C} {Y : C} {f : X ⟶ Y} [has_image f]
    (F' : mono_factorisation f) : image.lift F' ≫ mono_factorisation.m F' = image.ι f :=
  is_image.lift_fac' (image.is_image f) F'

@[simp] theorem image.fac_lift {C : Type u} [category C] {X : C} {Y : C} {f : X ⟶ Y} [has_image f]
    (F' : mono_factorisation f) : factor_thru_image f ≫ image.lift F' = mono_factorisation.e F' :=
  is_image.fac_lift (image.is_image f) F'

@[simp] theorem is_image.lift_ι_assoc {C : Type u} [category C] {X : C} {Y : C} {f : X ⟶ Y}
    [has_image f] {F : mono_factorisation f} (hF : is_image F) {X' : C} (f' : Y ⟶ X') :
    is_image.lift hF (image.mono_factorisation f) ≫ image.ι f ≫ f' = mono_factorisation.m F ≫ f' :=
  sorry

-- TODO we could put a category structure on `mono_factorisation f`,

-- with the morphisms being `g : I ⟶ I'` commuting with the `m`s

-- (they then automatically commute with the `e`s)

-- and show that an `image_of f` gives an initial object there

-- (uniqueness of the lift comes for free).

protected instance lift_mono {C : Type u} [category C] {X : C} {Y : C} {f : X ⟶ Y} [has_image f]
    (F' : mono_factorisation f) : mono (image.lift F') :=
  mono_of_mono (image.lift F') (mono_factorisation.m F')

theorem has_image.uniq {C : Type u} [category C] {X : C} {Y : C} {f : X ⟶ Y} [has_image f]
    (F' : mono_factorisation f) (l : image f ⟶ mono_factorisation.I F')
    (w : l ≫ mono_factorisation.m F' = image.ι f) : l = image.lift F' :=
  sorry

/-- `has_images` represents a choice of image for every morphism -/
class has_images (C : Type u) [category C] where
  has_image : ∀ {X Y : C} (f : X ⟶ Y), has_image f

/-- The image of a monomorphism is isomorphic to the source. -/
def image_mono_iso_source {C : Type u} [category C] {X : C} {Y : C} (f : X ⟶ Y) [has_image f]
    [mono f] : image f ≅ X :=
  is_image.iso_ext (image.is_image f) (is_image.self f)

@[simp] theorem image_mono_iso_source_inv_ι {C : Type u} [category C] {X : C} {Y : C} (f : X ⟶ Y)
    [has_image f] [mono f] : iso.inv (image_mono_iso_source f) ≫ image.ι f = f :=
  sorry

@[simp] theorem image_mono_iso_source_hom_self_assoc {C : Type u} [category C] {X : C} {Y : C}
    (f : X ⟶ Y) [has_image f] [mono f] {X' : C} (f' : Y ⟶ X') :
    iso.hom (image_mono_iso_source f) ≫ f ≫ f' = image.ι f ≫ f' :=
  sorry

-- This is the proof that `factor_thru_image f` is an epimorphism

-- from https://en.wikipedia.org/wiki/Image_(category_theory), which is in turn taken from:

-- Mitchell, Barry (1965), Theory of categories, MR 0202787, p.12, Proposition 10.1

theorem image.ext {C : Type u} [category C] {X : C} {Y : C} (f : X ⟶ Y) [has_image f] {W : C}
    {g : image f ⟶ W} {h : image f ⟶ W} [has_limit (parallel_pair g h)]
    (w : factor_thru_image f ≫ g = factor_thru_image f ≫ h) : g = h :=
  sorry

protected instance factor_thru_image.category_theory.epi {C : Type u} [category C] {X : C} {Y : C}
    (f : X ⟶ Y) [has_image f] [∀ {Z : C} (g h : image f ⟶ Z), has_limit (parallel_pair g h)] :
    epi (factor_thru_image f) :=
  epi.mk
    fun (Z : C) (g h : image f ⟶ Z) (w : factor_thru_image f ≫ g = factor_thru_image f ≫ h) =>
      image.ext f w

theorem epi_image_of_epi {C : Type u} [category C] {X : C} {Y : C} (f : X ⟶ Y) [has_image f]
    [E : epi f] : epi (image.ι f) :=
  epi_of_epi (factor_thru_image f) (image.ι f)

theorem epi_of_epi_image {C : Type u} [category C] {X : C} {Y : C} (f : X ⟶ Y) [has_image f]
    [epi (image.ι f)] [epi (factor_thru_image f)] : epi f :=
  eq.mpr (id (Eq._oldrec (Eq.refl (epi f)) (Eq.symm (image.fac f))))
    (epi_comp (factor_thru_image f) (image.ι f))

/--
An equation between morphisms gives a comparison map between the images
(which momentarily we prove is an iso).
-/
def image.eq_to_hom {C : Type u} [category C] {X : C} {Y : C} {f : X ⟶ Y} {f' : X ⟶ Y} [has_image f]
    [has_image f'] (h : f = f') : image f ⟶ image f' :=
  image.lift (mono_factorisation.mk (image f') (image.ι f') (factor_thru_image f'))

protected instance image.eq_to_hom.category_theory.is_iso {C : Type u} [category C] {X : C} {Y : C}
    {f : X ⟶ Y} {f' : X ⟶ Y} [has_image f] [has_image f'] (h : f = f') :
    is_iso (image.eq_to_hom h) :=
  is_iso.mk (image.eq_to_hom sorry)

/-- An equation between morphisms gives an isomorphism between the images. -/
def image.eq_to_iso {C : Type u} [category C] {X : C} {Y : C} {f : X ⟶ Y} {f' : X ⟶ Y} [has_image f]
    [has_image f'] (h : f = f') : image f ≅ image f' :=
  as_iso (image.eq_to_hom h)

/--
As long as the category has equalizers,
the image inclusion maps commute with `image.eq_to_iso`.
-/
theorem image.eq_fac {C : Type u} [category C] {X : C} {Y : C} {f : X ⟶ Y} {f' : X ⟶ Y}
    [has_image f] [has_image f'] [has_equalizers C] (h : f = f') :
    image.ι f = iso.hom (image.eq_to_iso h) ≫ image.ι f' :=
  sorry

/-- The comparison map `image (f ≫ g) ⟶ image g`. -/
def image.pre_comp {C : Type u} [category C] {X : C} {Y : C} (f : X ⟶ Y) {Z : C} (g : Y ⟶ Z)
    [has_image g] [has_image (f ≫ g)] : image (f ≫ g) ⟶ image g :=
  image.lift (mono_factorisation.mk (image g) (image.ι g) (f ≫ factor_thru_image g))

@[simp] theorem image.factor_thru_image_pre_comp {C : Type u} [category C] {X : C} {Y : C}
    (f : X ⟶ Y) {Z : C} (g : Y ⟶ Z) [has_image g] [has_image (f ≫ g)] :
    factor_thru_image (f ≫ g) ≫ image.pre_comp f g = f ≫ factor_thru_image g :=
  sorry

/--
The two step comparison map
  `image (f ≫ (g ≫ h)) ⟶ image (g ≫ h) ⟶ image h`
agrees with the one step comparison map
  `image (f ≫ (g ≫ h)) ≅ image ((f ≫ g) ≫ h) ⟶ image h`.
 -/
theorem image.pre_comp_comp {C : Type u} [category C] {X : C} {Y : C} (f : X ⟶ Y) {Z : C}
    (g : Y ⟶ Z) {W : C} (h : Z ⟶ W) [has_image (g ≫ h)] [has_image (f ≫ g ≫ h)] [has_image h]
    [has_image ((f ≫ g) ≫ h)] :
    image.pre_comp f (g ≫ h) ≫ image.pre_comp g h =
        image.eq_to_hom (Eq.symm (category.assoc f g h)) ≫ image.pre_comp (f ≫ g) h :=
  sorry

/--
`image.pre_comp f g` is an isomorphism when `f` is an isomorphism
(we need `C` to have equalizers to prove this).
-/
protected instance image.is_iso_precomp_iso {C : Type u} [category C] {X : C} {Y : C} {Z : C}
    (g : Y ⟶ Z) [has_equalizers C] (f : X ≅ Y) [has_image g] [has_image (iso.hom f ≫ g)] :
    is_iso (image.pre_comp (iso.hom f) g) :=
  is_iso.mk
    (image.lift
      (mono_factorisation.mk (image (iso.hom f ≫ g)) (image.ι (iso.hom f ≫ g))
        (iso.inv f ≫ factor_thru_image (iso.hom f ≫ g))))

-- Note that in general we don't have the other comparison map you might expect

-- `image f ⟶ image (f ≫ g)`.

/-- Postcomposing by an isomorphism induces an isomorphism on the image. -/
def image.post_comp_is_iso {C : Type u} [category C] {X : C} {Y : C} (f : X ⟶ Y) {Z : C} (g : Y ⟶ Z)
    [has_equalizers C] [is_iso g] [has_image f] [has_image (f ≫ g)] : image f ≅ image (f ≫ g) :=
  iso.mk
    (image.lift
      (mono_factorisation.mk (image (f ≫ g)) (image.ι (f ≫ g) ≫ inv g) (factor_thru_image (f ≫ g))))
    (image.lift (mono_factorisation.mk (image f) (image.ι f ≫ g) (factor_thru_image f)))

@[simp] theorem image.post_comp_is_iso_hom_comp_image_ι_assoc {C : Type u} [category C] {X : C}
    {Y : C} (f : X ⟶ Y) {Z : C} (g : Y ⟶ Z) [has_equalizers C] [is_iso g] [has_image f]
    [has_image (f ≫ g)] {X' : C} (f' : Z ⟶ X') :
    iso.hom (image.post_comp_is_iso f g) ≫ image.ι (f ≫ g) ≫ f' = image.ι f ≫ g ≫ f' :=
  sorry

@[simp] theorem image.post_comp_is_iso_inv_comp_image_ι_assoc {C : Type u} [category C] {X : C}
    {Y : C} (f : X ⟶ Y) {Z : C} (g : Y ⟶ Z) [has_equalizers C] [is_iso g] [has_image f]
    [has_image (f ≫ g)] {X' : C} (f' : Y ⟶ X') :
    iso.inv (image.post_comp_is_iso f g) ≫ image.ι f ≫ f' = image.ι (f ≫ g) ≫ inv g ≫ f' :=
  sorry

end category_theory.limits

namespace category_theory.limits

protected instance hom.has_image {C : Type u} [category C] {X : C} {Y : C} (f : X ⟶ Y)
    [has_image f] : has_image (comma.hom (arrow.mk f)) :=
  (fun (this : has_image f) => this) _inst_2

/-- An image map is a morphism `image f → image g` fitting into a commutative square and satisfying
    the obvious commutativity conditions. -/
structure image_map {C : Type u} [category C] {f : arrow C} {g : arrow C} [has_image (comma.hom f)]
    [has_image (comma.hom g)] (sq : f ⟶ g)
    where
  map : image (comma.hom f) ⟶ image (comma.hom g)
  map_ι' :
    autoParam (map ≫ image.ι (comma.hom g) = image.ι (comma.hom f) ≫ comma_morphism.right sq)
      (Lean.Syntax.ident Lean.SourceInfo.none (String.toSubstring "Mathlib.obviously")
        (Lean.Name.mkStr (Lean.Name.mkStr Lean.Name.anonymous "Mathlib") "obviously") [])

protected instance inhabited_image_map {C : Type u} [category C] {f : arrow C}
    [has_image (comma.hom f)] : Inhabited (image_map 𝟙) :=
  { default := image_map.mk 𝟙 }

@[simp] theorem image_map.map_ι {C : Type u} [category C] {f : arrow C} {g : arrow C}
    [has_image (comma.hom f)] [has_image (comma.hom g)] {sq : f ⟶ g} (c : image_map sq) :
    image_map.map c ≫ image.ι (comma.hom g) = image.ι (comma.hom f) ≫ comma_morphism.right sq :=
  sorry

@[simp] theorem image_map.map_ι_assoc {C : Type u} [category C] {f : arrow C} {g : arrow C}
    [has_image (comma.hom f)] [has_image (comma.hom g)] {sq : f ⟶ g} (c : image_map sq) {X' : C}
    (f' : comma.right g ⟶ X') :
    image_map.map c ≫ image.ι (comma.hom g) ≫ f' =
        image.ι (comma.hom f) ≫ comma_morphism.right sq ≫ f' :=
  sorry

@[simp] theorem image_map.factor_map {C : Type u} [category C] {f : arrow C} {g : arrow C}
    [has_image (comma.hom f)] [has_image (comma.hom g)] (sq : f ⟶ g) (m : image_map sq) :
    factor_thru_image (comma.hom f) ≫ image_map.map m =
        comma_morphism.left sq ≫ factor_thru_image (comma.hom g) :=
  sorry

/-- To give an image map for a commutative square with `f` at the top and `g` at the bottom, it
    suffices to give a map between any mono factorisation of `f` and any image factorisation of
    `g`. -/
def image_map.transport {C : Type u} [category C] {f : arrow C} {g : arrow C}
    [has_image (comma.hom f)] [has_image (comma.hom g)] (sq : f ⟶ g)
    (F : mono_factorisation (comma.hom f)) {F' : mono_factorisation (comma.hom g)}
    (hF' : is_image F') {map : mono_factorisation.I F ⟶ mono_factorisation.I F'}
    (map_ι : map ≫ mono_factorisation.m F' = mono_factorisation.m F ≫ comma_morphism.right sq) :
    image_map sq :=
  image_map.mk (image.lift F ≫ map ≫ is_image.lift hF' (image.mono_factorisation (comma.hom g)))

/-- `has_image_map sq` means that there is an `image_map` for the square `sq`. -/
class has_image_map {C : Type u} [category C] {f : arrow C} {g : arrow C} [has_image (comma.hom f)]
    [has_image (comma.hom g)] (sq : f ⟶ g)
    where
  mk' :: (has_image_map : Nonempty (image_map sq))

theorem has_image_map.mk {C : Type u} [category C] {f : arrow C} {g : arrow C}
    [has_image (comma.hom f)] [has_image (comma.hom g)] {sq : f ⟶ g} (m : image_map sq) :
    has_image_map sq :=
  has_image_map.mk' (Nonempty.intro m)

theorem has_image_map.transport {C : Type u} [category C] {f : arrow C} {g : arrow C}
    [has_image (comma.hom f)] [has_image (comma.hom g)] (sq : f ⟶ g)
    (F : mono_factorisation (comma.hom f)) {F' : mono_factorisation (comma.hom g)}
    (hF' : is_image F') (map : mono_factorisation.I F ⟶ mono_factorisation.I F')
    (map_ι : map ≫ mono_factorisation.m F' = mono_factorisation.m F ≫ comma_morphism.right sq) :
    has_image_map sq :=
  has_image_map.mk (image_map.transport sq F hF' map_ι)

/-- Obtain an `image_map` from a `has_image_map` instance. -/
def has_image_map.image_map {C : Type u} [category C] {f : arrow C} {g : arrow C}
    [has_image (comma.hom f)] [has_image (comma.hom g)] (sq : f ⟶ g) [has_image_map sq] :
    image_map sq :=
  Classical.choice has_image_map.has_image_map

theorem image_map.ext_iff {C : Type u} {_inst_1 : category C} {f : arrow C} {g : arrow C}
    {_inst_2 : has_image (comma.hom f)} {_inst_3 : has_image (comma.hom g)} {sq : f ⟶ g}
    (x : image_map sq) (y : image_map sq) : x = y ↔ image_map.map x = image_map.map y :=
  sorry

protected instance image_map.subsingleton {C : Type u} [category C] {f : arrow C} {g : arrow C}
    [has_image (comma.hom f)] [has_image (comma.hom g)] (sq : f ⟶ g) :
    subsingleton (image_map sq) :=
  subsingleton.intro
    fun (a b : image_map sq) =>
      image_map.ext a b
        (iff.mp (cancel_mono (image.ι (comma.hom g)))
          (eq.mpr
            (id
              ((fun (a a_1 : image (comma.hom f) ⟶ functor.obj 𝟭 (comma.right g)) (e_1 : a = a_1)
                  (ᾰ ᾰ_1 : image (comma.hom f) ⟶ functor.obj 𝟭 (comma.right g)) (e_2 : ᾰ = ᾰ_1) =>
                  congr (congr_arg Eq e_1) e_2)
                (image_map.map a ≫ image.ι (comma.hom g))
                (image.ι (comma.hom f) ≫ comma_morphism.right sq) (image_map.map_ι a)
                (image_map.map b ≫ image.ι (comma.hom g))
                (image.ι (comma.hom f) ≫ comma_morphism.right sq) (image_map.map_ι b)))
            (Eq.refl (image.ι (comma.hom f) ≫ comma_morphism.right sq))))

/-- The map on images induced by a commutative square. -/
def image.map {C : Type u} [category C] {f : arrow C} {g : arrow C} [has_image (comma.hom f)]
    [has_image (comma.hom g)] (sq : f ⟶ g) [has_image_map sq] :
    image (comma.hom f) ⟶ image (comma.hom g) :=
  image_map.map (has_image_map.image_map sq)

theorem image.factor_map {C : Type u} [category C] {f : arrow C} {g : arrow C}
    [has_image (comma.hom f)] [has_image (comma.hom g)] (sq : f ⟶ g) [has_image_map sq] :
    factor_thru_image (comma.hom f) ≫ image.map sq =
        comma_morphism.left sq ≫ factor_thru_image (comma.hom g) :=
  sorry

theorem image.map_ι {C : Type u} [category C] {f : arrow C} {g : arrow C} [has_image (comma.hom f)]
    [has_image (comma.hom g)] (sq : f ⟶ g) [has_image_map sq] :
    image.map sq ≫ image.ι (comma.hom g) = image.ι (comma.hom f) ≫ comma_morphism.right sq :=
  sorry

theorem image.map_hom_mk'_ι {C : Type u} [category C] {X : C} {Y : C} {P : C} {Q : C} {k : X ⟶ Y}
    [has_image k] {l : P ⟶ Q} [has_image l] {m : X ⟶ P} {n : Y ⟶ Q} (w : m ≫ l = k ≫ n)
    [has_image_map (arrow.hom_mk' w)] : image.map (arrow.hom_mk' w) ≫ image.ι l = image.ι k ≫ n :=
  image.map_ι (arrow.hom_mk' w)

/-- Image maps for composable commutative squares induce an image map in the composite square. -/
def image_map_comp {C : Type u} [category C] {f : arrow C} {g : arrow C} [has_image (comma.hom f)]
    [has_image (comma.hom g)] (sq : f ⟶ g) [has_image_map sq] {h : arrow C}
    [has_image (comma.hom h)] (sq' : g ⟶ h) [has_image_map sq'] : image_map (sq ≫ sq') :=
  image_map.mk (image.map sq ≫ image.map sq')

@[simp] theorem image.map_comp {C : Type u} [category C] {f : arrow C} {g : arrow C}
    [has_image (comma.hom f)] [has_image (comma.hom g)] (sq : f ⟶ g) [has_image_map sq]
    {h : arrow C} [has_image (comma.hom h)] (sq' : g ⟶ h) [has_image_map sq']
    [has_image_map (sq ≫ sq')] : image.map (sq ≫ sq') = image.map sq ≫ image.map sq' :=
  sorry

/-- The identity `image f ⟶ image f` fits into the commutative square represented by the identity
    morphism `𝟙 f` in the arrow category. -/
def image_map_id {C : Type u} [category C] (f : arrow C) [has_image (comma.hom f)] : image_map 𝟙 :=
  image_map.mk 𝟙

@[simp] theorem image.map_id {C : Type u} [category C] (f : arrow C) [has_image (comma.hom f)]
    [has_image_map 𝟙] : image.map 𝟙 = 𝟙 :=
  sorry

/-- If a category `has_image_maps`, then all commutative squares induce morphisms on images. -/
class has_image_maps (C : Type u) [category C] [has_images C] where
  has_image_map : ∀ {f g : arrow C} (st : f ⟶ g), has_image_map st

/-- The functor from the arrow category of `C` to `C` itself that maps a morphism to its image
    and a commutative square to the induced morphism on images. -/
@[simp] theorem im_map {C : Type u} [category C] [has_images C] [has_image_maps C] (_x : arrow C) :
    ∀ (_x_1 : arrow C) (st : _x ⟶ _x_1), functor.map im st = image.map st :=
  fun (_x_1 : arrow C) (st : _x ⟶ _x_1) => Eq.refl (functor.map im st)

/-- A strong epi-mono factorisation is a decomposition `f = e ≫ m` with `e` a strong epimorphism
    and `m` a monomorphism. -/
structure strong_epi_mono_factorisation {C : Type u} [category C] {X : C} {Y : C} (f : X ⟶ Y)
    extends mono_factorisation f where
  e_strong_epi : strong_epi (mono_factorisation.e _to_mono_factorisation)

/-- Satisfying the inhabited linter -/
protected instance strong_epi_mono_factorisation_inhabited {C : Type u} [category C] {X : C} {Y : C}
    (f : X ⟶ Y) [strong_epi f] : Inhabited (strong_epi_mono_factorisation f) :=
  { default := strong_epi_mono_factorisation.mk (mono_factorisation.mk Y 𝟙 f) }

/-- A mono factorisation coming from a strong epi-mono factorisation always has the universal
    property of the image. -/
def strong_epi_mono_factorisation.to_mono_is_image {C : Type u} [category C] {X : C} {Y : C}
    {f : X ⟶ Y} (F : strong_epi_mono_factorisation f) :
    is_image (strong_epi_mono_factorisation.to_mono_factorisation F) :=
  is_image.mk fun (G : mono_factorisation f) => arrow.lift (arrow.hom_mk' sorry)

/-- A category has strong epi-mono factorisations if every morphism admits a strong epi-mono
    factorisation. -/
class has_strong_epi_mono_factorisations (C : Type u) [category C] where
  mk' :: (has_fac : ∀ {X Y : C} (f : X ⟶ Y), Nonempty (strong_epi_mono_factorisation f))

theorem has_strong_epi_mono_factorisations.mk {C : Type u} [category C]
    (d : {X Y : C} → (f : X ⟶ Y) → strong_epi_mono_factorisation f) :
    has_strong_epi_mono_factorisations C :=
  has_strong_epi_mono_factorisations.mk' fun (X Y : C) (f : X ⟶ Y) => Nonempty.intro (d f)

protected instance has_images_of_has_strong_epi_mono_factorisations {C : Type u} [category C]
    [has_strong_epi_mono_factorisations C] : has_images C :=
  has_images.mk sorry

/-- A category has strong epi images if it has all images and `factor_thru_image f` is a strong
    epimorphism for all `f`. -/
class has_strong_epi_images (C : Type u) [category C] [has_images C] where
  strong_factor_thru_image : ∀ {X Y : C} (f : X ⟶ Y), strong_epi (factor_thru_image f)

/-- If there is a single strong epi-mono factorisation of `f`, then every image factorisation is a
    strong epi-mono factorisation. -/
theorem strong_epi_of_strong_epi_mono_factorisation {C : Type u} [category C] {X : C} {Y : C}
    {f : X ⟶ Y} (F : strong_epi_mono_factorisation f) {F' : mono_factorisation f}
    (hF' : is_image F') : strong_epi (mono_factorisation.e F') :=
  sorry

theorem strong_epi_factor_thru_image_of_strong_epi_mono_factorisation {C : Type u} [category C]
    {X : C} {Y : C} {f : X ⟶ Y} [has_image f] (F : strong_epi_mono_factorisation f) :
    strong_epi (factor_thru_image f) :=
  strong_epi_of_strong_epi_mono_factorisation F (image.is_image f)

/-- If we constructed our images from strong epi-mono factorisations, then these images are
    strong epi images. -/
protected instance has_strong_epi_images_of_has_strong_epi_mono_factorisations {C : Type u}
    [category C] [has_strong_epi_mono_factorisations C] : has_strong_epi_images C :=
  has_strong_epi_images.mk
    fun (X Y : C) (f : X ⟶ Y) =>
      strong_epi_factor_thru_image_of_strong_epi_mono_factorisation
        (Classical.choice (has_strong_epi_mono_factorisations.has_fac f))

/-- A category with strong epi images has image maps. -/
protected instance has_image_maps_of_has_strong_epi_images {C : Type u} [category C] [has_images C]
    [has_strong_epi_images C] : has_image_maps C :=
  has_image_maps.mk sorry

/-- If a category has images, equalizers and pullbacks, then images are automatically strong epi
    images. -/
protected instance has_strong_epi_images_of_has_pullbacks_of_has_equalizers {C : Type u}
    [category C] [has_images C] [has_pullbacks C] [has_equalizers C] : has_strong_epi_images C :=
  sorry

/--
If `C` has strong epi mono factorisations, then the image is unique up to isomorphism, in that if
`f` factors as a strong epi followed by a mono, this factorisation is essentially the image
factorisation.
-/
def image.iso_strong_epi_mono {C : Type u} [category C] [has_strong_epi_mono_factorisations C]
    {X : C} {Y : C} {f : X ⟶ Y} {I' : C} (e : X ⟶ I') (m : I' ⟶ Y) (comm : e ≫ m = f) [strong_epi e]
    [mono m] : I' ≅ image f :=
  is_image.iso_ext
    (strong_epi_mono_factorisation.to_mono_is_image
      (strong_epi_mono_factorisation.mk (mono_factorisation.mk I' m e)))
    (image.is_image f)

@[simp] theorem image.iso_strong_epi_mono_hom_comp_ι {C : Type u} [category C]
    [has_strong_epi_mono_factorisations C] {X : C} {Y : C} {f : X ⟶ Y} {I' : C} (e : X ⟶ I')
    (m : I' ⟶ Y) (comm : e ≫ m = f) [strong_epi e] [mono m] :
    iso.hom (image.iso_strong_epi_mono e m comm) ≫ image.ι f = m :=
  is_image.lift_fac
    (strong_epi_mono_factorisation.to_mono_is_image
      (strong_epi_mono_factorisation.mk (mono_factorisation.mk I' m e)))
    (image.mono_factorisation f)

@[simp] theorem image.iso_strong_epi_mono_inv_comp_mono {C : Type u} [category C]
    [has_strong_epi_mono_factorisations C] {X : C} {Y : C} {f : X ⟶ Y} {I' : C} (e : X ⟶ I')
    (m : I' ⟶ Y) (comm : e ≫ m = f) [strong_epi e] [mono m] :
    iso.inv (image.iso_strong_epi_mono e m comm) ≫ m = image.ι f :=
  image.lift_fac
    (strong_epi_mono_factorisation.to_mono_factorisation
      (strong_epi_mono_factorisation.mk (mono_factorisation.mk I' m e)))

end Mathlib


import data.list.basic
import data.vector

universes u v w
variables {n : ℕ} {α β γ δ : Type}

notation `v[` v:(foldr `, ` (h t, vector.cons h t) vector.nil `]`) := v

@[simp]
lemma ite_else_ite {c} [decidable c] {b₁ b₂ b₃ :  Sort u} : ite c b₁ (ite c b₂ b₃) = ite c b₁ b₃ := begin
  by_cases c; simp *,
end

lemma lt_zero_one : 0 < 1 := nat.lt.base 0

@[simp]
lemma nat.succ_lt_succ_iff {n m : ℕ} : n + 1 < m + 1 ↔ n < m := nat.lt_succ_iff

lemma eq.mpr.intro {α : Type} (x : α) : eq.mpr rfl x = x := begin
  refl,
end

namespace fin

lemma fin_eq {f f' : fin n} : f ≠ f' → f.val ≠ f'.val := begin
  intro h,
  cases f,
  cases f',
  simp,
  intro h',
  apply h,
  subst h',
end

end fin

namespace list

lemma list_length_neq_zero {α} : ∀{l : list α}, l.length ≠ 0 → ∃ x xs, l = (x :: xs)
| []     h := (h rfl).elim
| (a::l) h := ⟨_, _, rfl⟩

lemma list_length_tail {α β : Type} {x : α} {y : β} {xs ys : list _}
  (h : (x :: xs).length = (y :: ys).length) : xs.length = ys.length :=
by simpa using h

def range_fin_core (dim : ℕ) : Π n : ℕ, n <= dim → list (fin dim) → list (fin dim)
| 0 h l := l
| (nat.succ n) hs l := have h : n < dim := begin apply nat.succ_le_succ_iff.mp, apply nat.lt_succ_iff.mpr hs, end, range_fin_core n (le_of_lt h) (⟨n, h⟩ :: l)

def range_fin (n : ℕ) : list (fin n) :=
range_fin_core n n (by refl) []

-- TODO: we need something like list.range' for fin
--def range_fin' : ℕ → ℕ → list (fin n)

@[simp] lemma length_range_nth : length (range_fin n) = n := begin
  admit
end

def fin_inc : fin n → fin (nat.succ n)
| ⟨val, is_lt⟩ := ⟨val, nat.lt.step is_lt⟩

instance (n : ℕ) : has_coe (list (fin $ n)) (list (fin $ nat.succ n)) := ⟨map fin_inc⟩

lemma range_fin_succ : range_fin (nat.succ n) = ((range_fin n : list (fin n)) : list (fin $ nat.succ n)) ++ [⟨n, sorry⟩] := begin
  unfold range_fin,
  induction n, { refl, },
  {
    rw range_fin_core,
    sorry,
  }
end

lemma foldl_range_fin_succ {α : Type} {n : ℕ} (i : α) (r : α → fin (nat.succ n) → α) : foldl r i (range_fin (n + 1)) = r (foldl r i (range_fin n : list (fin n))) (nat.succ n) := begin
  induction n,
  { refl, },
  {
    rw [range_fin, range_fin_core],
    sorry,
  }
end

#print map₂._main

lemma map₂_map₂ (g : γ → β → δ) (f : α → β → γ) (l : list α) (l' : list β) : map₂ g (map₂ f l l') l' = map₂ (λ a b, g (f a b) b) l l' := begin
  induction l generalizing l',
  case list.nil { cases l'; refl, },
  case list.cons { cases l'; simp [map₂, *], }
end

lemma list_neq_elem {α : Type} {l l' : list α} (n : ℕ) (h : n < l.length) (h' : n < l'.length) : l.nth_le n h ≠ l'.nth_le n h' → l ≠ l' := by sorry

lemma list_nth_vector {α l} {v : vector α l} {n h} : list.nth_le (vector.to_list v) n h = v.nth ⟨n, (by sorry)⟩ := by sorry

lemma list_one_eq {α : Type} {l₁ l₂ : list α} (h : l₁.length = 1) : ([l₁.nth_le 0 (by rw h; exact lt_zero_one)] : list α) = l₂ → l₁ = l₂ := sorry

end list

namespace nat

lemma lt_neq_zeor (n m : ℕ) : n < m → m ≠ 0 := begin
    intro,
    intro b,
    rw b at a,
    cases a,
end

end nat

namespace set

lemma union_no_mem_left {α : Type} {a : α} {b c : set α} (h : a ∉ b ∪ c) : a ∉ b := sorry

end set

namespace vector

protected def mem {α : Type u} {n : ℕ} : α → vector α n → Prop
| a v := a ∈ v.to_list

instance {α : Type u} {n : ℕ} : has_mem α (vector α n) :=
⟨vector.mem⟩

lemma mem_def {α : Type*} {n : ℕ} (a : α) (v : vector α n) : a ∈ v ↔ a ∈ v.to_list :=
iff.rfl

lemma mem_nil {α : Type u} {a : α} : a ∉ (@vector.nil α) := by sorry

lemma nat_le_zero {n : ℕ} : n < 0 → false := by sorry

#check vector.cons

lemma mem_elim_head {α : Type u} {n} {tl : vector α n} {a hd : α} :
  a ∈ tl → a ∈ cons hd tl :=
sorry

lemma contains_nth {α : Type} : ∀{n : ℕ} {v : vector α n} {i : fin n}, (v.nth i) ∈ v
| n ⟨l, rfl⟩ ⟨i, hi⟩ :=
  begin
    dsimp only [vector.nth, vector.has_mem, vector.mem, to_list],
    rw list.mem_iff_nth_le,
    exact ⟨i, hi, rfl⟩
  end

lemma eq_element_wise {α : Type} : ∀{a b : vector α n}, (∀ i, a.nth i = b.nth i) → a = b
:= begin
  -- TODO needs fixing
  intros a b hieq,
  apply vector.eq,
  cases a,
  cases b,
  repeat { rw to_list },
  simp,
  induction a_val generalizing b_val n,
  case list.nil {
    cases b_val,
    { refl },
    {
      rw list.length at a_property b_property,
      rw ← b_property at a_property,
      contradiction,
    }
  },
  case list.cons {
    cases b_val,
    {
      rw list.length at a_property b_property,
      rw ← b_property at a_property,
      contradiction,
    },
    {
      have : _ := hieq ⟨0, sorry⟩,
      rw [vector.nth, list.nth_le, vector.nth, list.nth_le] at this,
      dunfold vector.nth at hieq,
      rw this,
      simp,
      cases a_property,
      apply a_val_ih,
      repeat { sorry },
    }
  }
end
-- | ⟨[], _⟩ ⟨[], ha⟩ _ _ := by refl
-- | ⟨ a :: as , _⟩ ⟨ b :: bs, _⟩ i hieq := begin

-- end

--   intros i hieq,
--   exact match a with
--   | ⟨[], ha⟩ :=
--     begin
--       exact match b with
--       | ⟨[], ha⟩ := sorry
--       |
--       end,
--     end
--   end
-- end

@[simp] lemma vector_0_eq {α : Type} : ∀(v : vector α 0), v = vector.nil
| ⟨l, hl⟩ := subtype.eq $ show l = list.nil, from list.length_eq_zero.1 hl

lemma vector_0_eq' {α : Type} {v v' : vector α 0} : v = v' := sorry

@[simp] lemma map₂_nil {α β γ : Type} {f : α → β → γ} :
  ∀ (v : vector α 0) w, vector.map₂ f v w = vector.nil
| ⟨[], _⟩ ⟨[], _⟩ := by simp [vector.map₂, vector.nil]

@[simp] lemma map₂_nil' {α β γ : Type} {f : α → β → γ} (v : vector α 0) (p) :
  vector.map₂ f v ⟨list.nil, p⟩ = vector.nil := sorry

@[simp] lemma nth_map (f : α -> β) (v : vector α n) (i) : (v.map f).nth i = f (v.nth i) := match v with
| ⟨l, hl⟩ := begin unfold nth map, sorry end
end

@[simp] lemma nth_map₂ (f : α → β → γ) (v : vector α n) (w : vector β n) (i) : nth (map₂ f v w) i = f (v.nth i) (w.nth i) := sorry

lemma map_map (g : β → γ) (f : α → β) (v : vector α n) : map g (map f v) = map (g ∘ f) v := begin
  cases v,
  apply vector.eq,
  simp [to_list, map, list.map_map],
end

lemma map₂_map₂ (g : γ → β → δ) (f : α → β → γ) (v : vector α n) (v' : vector β n) : map₂ g (map₂ f v v') v' = map₂ (λ a b, g (f a b) b) v v' := begin
  cases v,
  cases v',
  apply vector.eq,
  simp [to_list, map, map₂],
  apply list.map₂_map₂,
end

-- example {f a as b bs h h' h''} :
--   vector.map₂ f ⟨ a :: as, h⟩ ⟨b :: bs, h'⟩ = ⟨f a b :: vector.map₂ f as bs, h''⟩ :=
-- sorry

def range (n : ℕ) : vector ℕ n := ⟨list.range n, sorry⟩

lemma range_nth {n : ℕ} {i : fin n} : (range n).nth i = i := sorry

def range_fin (n : ℕ) : vector (fin n) n := ⟨list.range_fin n, sorry⟩

@[simp] lemma length_map {α n} (f : α → β) (l : vector α n) : length (map f l) = length l := sorry

@[simp] lemma length_range_nth : length (range_fin n) = n := sorry

lemma eq_one {α : Type} (v : vector α 1) (v' : vector α 1) : v.nth ⟨0, sorry⟩ = v'.nth ⟨0, by sorry⟩ ↔ (v = v') := sorry

lemma eq_one' {α : Type} (a b : α) : a = b ↔ (v[a] = v[b]) := sorry

lemma length_list {α : Type} {n} {v : vector α n} : list.length (vector.to_list (v)) = vector.length v := begin
  admit,
end

lemma map_single {α β : Type} (f : α → β) (e : α) : vector.map f v[e] = v[f e] := begin
    refl,
end

end vector

namespace bool

lemma eq_tt_coe {b : bool} : b ↔ (b = tt) := begin
  sorry,
end

lemma bnot_bnot {α : Type} {f : α → bool} : (bnot ∘ bnot ∘ f) = f := begin
  sorry,
end

lemma bnot_ff (b : bool) : bnot b = (b = ff) := begin
  by_cases b = ff,
  { rw h, refl, },
  { simp at h, subst h, simp, }
end

end bool


import Mathlib.Data.Finmap

-- TODO: Isn't this tactic part of Mathlib?
syntax "case' " (Lean.binderIdent*),* " => " tacticSeq : tactic
macro_rules
  | `(tactic| case' $[$xs*],* => $tac) => do
    let tacs ← xs.mapM fun xs => `(tactic| case $(xs[0]!) $(xs[1:])* => $tac)
    `(tactic| ($[$tacs]*))

namespace Set

theorem insert_union' (s₁ s₂ : Set α) (a : α) : (insert a s₁) ∪ s₂ = s₁ ∪ (insert a s₂) := by
  rw [Set.insert_union, Set.union_comm, ←Set.insert_union, Set.union_comm]

theorem ssubset_ne {s₁ s₂ : Set α} (h : s₁ ⊂ s₂) : s₁ ≠ s₂ :=
  ssubset_iff_subset_ne.mp h |>.right

end Set

abbrev Partial (α β) := α → Option β

infixr:50 " ⇀ " => Partial

namespace Partial

def empty : α ⇀ β :=
  fun _ => none

instance {α β : Type _} : EmptyCollection (α ⇀ β) where
  emptyCollection := empty

theorem empty_iff {f : α ⇀ β} : (f = ∅) ↔ (∀ i, f i = none) where
  mp h _ := h ▸ rfl
  mpr h := funext h

def Nonempty (f : α ⇀ β) : Prop :=
  f ≠ ∅

def ids (f : α ⇀ β) := { a | ∃ b, f a = some b }

theorem Nonempty.def {f : α ⇀ β} : f.Nonempty ↔ (f ≠ ∅) :=
  sorry

theorem Nonempty.iff_ids_nonempty {f : α ⇀ β} : f.Nonempty ↔ f.ids.Nonempty :=
  sorry

instance : Membership α (α ⇀ β) where
  mem a f := a ∈ f.ids

theorem mem_def {f : α ⇀ β} : (a ∈ f) ↔ (a ∈ f.ids) := by
  rfl

theorem mem_iff {f : α ⇀ β} : (a ∈ f) ↔ (∃ b, f a = some b) := by
  rfl

def attach (f : α ⇀ β) : α ⇀ { b // ∃ a, f a = some b } :=
  fun a =>
    match h : f a with
    | none => none
    | some b => some ⟨b, ⟨_, h⟩⟩

def map (g : β → γ) (f : α ⇀ β) : α ⇀ γ :=
  fun a => g <$> f a

theorem map_val (f : α ⇀ β) (g : β → γ) : (f.map g) a = (f a).map g :=
  rfl

theorem map_map (f : α ⇀ β) (g₁ : β → γ) (g₂ : γ → δ) : (f.map g₁).map g₂ = f.map (g₂ ∘ g₁) := by
  simp [map]

theorem map_inj {f₁ f₂ : α ⇀ β} (hi : g.Injective) (h : f₁.map g = f₂.map g) : f₁ = f₂ := by
  funext a
  replace h : f₁.map g a = f₂.map g a := by simp [h]
  exact Option.map_injective hi h

theorem attach_map_val (f : α ⇀ β) : f.attach.map Subtype.val = f := by
  sorry

def restrict (f : α ⇀ β) (s : Set α) [DecidablePred (· ∈ s)] : α ⇀ β :=
  fun a => if a ∈ s then f a else none

theorem ext_restrict {f g : α ⇀ β} (h : ∀ a ∈ s, f a = g a) [DecidablePred (· ∈ s)] :
    (f.restrict s) = (g.restrict s) :=
  sorry

def filterMap (f : α ⇀ β) (g : β → Option γ) : α ⇀ γ :=
  fun a => f a >>= g

def insert [DecidableEq α] (f : α ⇀ β) (a : α) (b : β) : α ⇀ β :=
  fun a' => if a' = a then b else f a'

theorem insert_same [DecidableEq α] (f : α ⇀ β) : (f.insert a b) a = b := by
  simp [insert]

theorem insert_ne [DecidableEq α] (f : α ⇀ β) (h : a' ≠ a := by assumption) :
    (f.insert a b) a' = f a' := by
  simp [insert, h]

end Partial

namespace Finmap

instance [DecidableEq α] : CoeFun (Finmap fun _ : α => β) (fun _ => α → Option β) where
  coe f := f.lookup

end Finmap


import Lean.Server.Requests
import Lean.Server.Rpc.Basic
import Lean.Server.Rpc.RequestHandling
import Lean.Elab
import Lean.Widget.Basic

import UserWidget.ToHtml.Widget

/-! Demonstrates commutative diagrams.

Category classes copied from mathlib. -/

class quiver (V : Type u) where
  hom : V → V → Sort v

infixr:10 " ⟶ " => quiver.hom -- type as \h

class category_struct (obj : Type u) extends quiver.{u,v+1} obj : Type (max u (v+1)) where
  id   : ∀ X : obj, hom X X
  comp : ∀ {X Y Z : obj}, (X ⟶ Y) → (Y ⟶ Z) → (X ⟶ Z)

-- https://github.com/leanprover/lean4/issues/1367
prefix:max "𝟙 " => category_struct.id -- type as \b1
infixr:80 " ≫ " => category_struct.comp -- type as \gg

class category (obj : Type u) extends category_struct.{u,v} obj : Type (max u (v+1)) where
  id_comp' : ∀ {X Y : obj} (f : hom X Y), 𝟙 X ≫ f = f
  comp_id' : ∀ {X Y : obj} (f : hom X Y), f ≫ 𝟙 Y = f
  assoc'   : ∀ {W X Y Z : obj} (f : hom W X) (g : hom X Y) (h : hom Y Z),
    (f ≫ g) ≫ h = f ≫ (g ≫ h)

instance : category (Type u) where
  hom α β := α → β
  id _ := id
  comp f g := g ∘ f
  id_comp' _ := rfl
  comp_id' _ := rfl
  assoc' _ _ _ := rfl

open Lean.Widget in
@[widget]
def squares : UserWidgetDefinition where
  name := "Commutative diagram"
  javascript := include_str ".." / ".." / "widget" / "dist" / "squares.js"

syntax (name := squaresTacStx) "squares!" : tactic
open Lean Elab Tactic in
@[tactic squaresTacStx]
def squaresTac : Tactic
  | stx@`(tactic| squares!) => do
    if let some _ := stx.getPos? then
      Lean.Widget.saveWidgetInfo "squares" Json.null stx
  | _ => throwUnsupportedSyntax

open Lean Widget Server

@[inline] def Lean.Expr.app7? (e : Expr) (fName : Name) : Option (Expr × Expr × Expr × Expr × Expr × Expr × Expr) :=
  if e.isAppOfArity fName 7 then
    some (
      e.appFn!.appFn!.appFn!.appFn!.appFn!.appFn!.appArg!,
      e.appFn!.appFn!.appFn!.appFn!.appFn!.appArg!,
      e.appFn!.appFn!.appFn!.appFn!.appArg!,
      e.appFn!.appFn!.appFn!.appArg!,
      e.appFn!.appFn!.appArg!,
      e.appFn!.appArg!,
      e.appArg!
    )
  else
    none

/-- Given a hom `f : α ⟶ β`, return `(α, β)`. Otherwise `none`. -/
def homTypesM? (f : Expr) : MetaM (Option (Expr × Expr)) := do
  let fTp ← Meta.inferType f >>= instantiateMVars
  let some (_, _, A, B) := fTp.app4? ``quiver.hom | return none
  return (A, B)

/-- Given composed homs `f ≡ g ≫ h`, return `(g, h)`. Otherwise `none`. -/
def homComp? (f : Expr) : Option (Expr × Expr) :=
  if let some (_, _, _, _, _, f, g) := f.app7? ``category_struct.comp then
    some (f, g)
  else none

inductive DiagramKind | square | triangle
deriving Inhabited, FromJson, ToJson

/--
Square with `homs = [f,g,h,i]` and `objs = [A,B,C,D]`
```
A f B
i   g
D h C
```
Triangle with `homs = [f,g,h]` and `objs = [A,B,C]`
```
A f B
  h g
    C
```
-/
structure DiagramData where
  objs : Array CodeWithInfos
  homs : Array CodeWithInfos
  kind : DiagramKind
  deriving Inhabited, RpcEncoding

/-- Given a commutative square `e ≡ f ≫ g = i ≫ h`, return a square diagram. Otherwise `none`. -/
def homSquareM? (e : Expr) : MetaM (Option DiagramData) := do
  let some (_, lhs, rhs) := e.eq? | return none
  let some (f, g) := homComp? lhs | return none
  let some (i, h) := homComp? rhs | return none
  let some (A, B) ← homTypesM? f | return none
  let some (C, D) ← homTypesM? h | return none
  let pp (e : Expr) := ppExprTagged e
  return some {
    objs := #[← pp A, ← pp B, ← pp C, ← pp D]
    homs := #[← pp f, ← pp g, ← pp h, ← pp i]
    kind := .square
  }

/-- Given a commutative triangle `e ≡ f ≫ g = h` or `e ≡ h = f ≫ g`, return a triangle diagram.
Otherwise `none`. -/
def homTriangleM? (e : Expr) : MetaM (Option DiagramData) := do
  let some (_, lhs, rhs) := e.eq? | return none
  let pp (e : Expr) := ppExprTagged e
  if let some (f, g) := homComp? lhs then
    let some (A, C) ← homTypesM? rhs | return none
    let some (_, B) ← homTypesM? f | return none
    return some {
      objs := #[← pp A, ← pp B, ← pp C]
      homs := #[← pp f, ← pp g, ← pp rhs]
      kind := .triangle
    }
  let some (f, g) := homComp? rhs | return none
  let some (A, C) ← homTypesM? lhs | return none
  let some (_, B) ← homTypesM? f | return none
  return some {
    objs := #[← pp A, ← pp B, ← pp C]
    homs := #[← pp f, ← pp g, ← pp lhs]
    kind := .triangle
  }

open Lean Server RequestM in
@[serverRpcMethod]
def getCommutativeDiagram (args : Lean.Lsp.Position) : RequestM (RequestTask (Option DiagramData)) := do
  let doc ← readDoc
  let pos := doc.meta.text.lspPosToUtf8Pos args
  withWaitFindSnapAtPos args fun snap => do
    let g :: _ := snap.infoTree.goalsAt? doc.meta.text pos | return none
    let { ctxInfo := ci, tacticInfo := ti, useAfter := useAfter, .. } := g
    let ci := if useAfter then { ci with mctx := ti.mctxAfter } else { ci with mctx := ti.mctxBefore }
    let g :: _ := if useAfter then ti.goalsAfter else ti.goalsBefore | return none
    ci.runMetaM {} <| do
      let some mvarDecl := (← getMCtx).findDecl? g
        | throwError "unknown goal {g.name}"
      let lctx := mvarDecl.lctx
      let lctx := lctx.sanitizeNames.run' { options := (← getOptions) }
      Meta.withLCtx lctx mvarDecl.localInstances do
        let type ← g.getType >>= instantiateMVars
        if let some d ← homSquareM? type then
          return some d
        if let some d ← homTriangleM? type then
          return some d
        return none

example {f g : Nat ⟶ Bool}: f = g → (f ≫ 𝟙 Bool) = (g ≫ 𝟙 Bool) := by
  intro h
  squares!
  exact h

example {f g : Nat ⟶ Bool}: f = g → f = (g ≫ 𝟙 Bool) := by
  intro h
  squares!
  exact h


import polyhedral_lattice.basic
import category_theory.concrete_category.bundled_hom
import analysis.normed.group.SemiNormedGroup.kernels
/-!

# The category of polyhedral lattices

-/
universe variables u

open category_theory

/-- The category of polyhedral lattices and bounded group homomorphisms. -/
def PolyhedralLattice : Type (u+1) := bundled polyhedral_lattice

instance : has_coe_to_sort PolyhedralLattice Type* := bundled.has_coe_to_sort

namespace PolyhedralLattice

variables (Λ : PolyhedralLattice)

instance : polyhedral_lattice Λ := Λ.str

def to_SemiNormedGroup : SemiNormedGroup := SemiNormedGroup.of Λ

instance bundled_hom : bundled_hom @polyhedral_lattice_hom :=
⟨@polyhedral_lattice_hom.to_fun,
@polyhedral_lattice_hom.id, @polyhedral_lattice_hom.comp, @polyhedral_lattice_hom.coe_inj⟩

attribute [derive [large_category, concrete_category]] PolyhedralLattice

/-- Construct a bundled `PolyhedralLattice` from the underlying type and typeclass. -/
def of (Λ : Type u) [polyhedral_lattice Λ] : PolyhedralLattice := bundled.of Λ

-- noncomputable
-- instance : has_zero PolyhedralLattice := ⟨of punit⟩

-- noncomputable
-- instance : inhabited PolyhedralLattice := ⟨0⟩

@[simp] lemma coe_of (Λ : Type u) [polyhedral_lattice Λ] :
  (PolyhedralLattice.of Λ : Type u) = Λ := rfl

@[simp] lemma coe_id (Λ : PolyhedralLattice) : ⇑(𝟙 Λ) = id := rfl

instance : limits.has_zero_morphisms.{u (u+1)} PolyhedralLattice :=
{ comp_zero' := by { intros, ext, refl },
  zero_comp' := by { intros _ _ _ f, ext, exact f.map_zero } }

def iso_mk {Λ₁ Λ₂ : PolyhedralLattice.{u}}
  (f : Λ₁ →+ Λ₂) (g : Λ₂ → Λ₁) (hf : ∀ l, ∥f l∥ = ∥l∥) (hfg : g ∘ f = id) (hgf : f ∘ g = id) :
  Λ₁ ≅ Λ₂ :=
{ hom := { strict' := λ l, le_of_eq (hf l), ..f },
  inv :=
  { strict' := λ l,
    calc ∥g l∥ ≤ ∥f (g l)∥ : le_of_eq $ (hf _).symm
    ... = ∥l∥ : congr_arg norm $ congr_fun hgf l,
    .. add_equiv.symm
    { inv_fun := g,
      left_inv := congr_fun hfg,
      right_inv := congr_fun hgf,
      .. f } },
  hom_inv_id' := by { ext x, exact congr_fun hfg x },
  inv_hom_id' := by { ext x, exact congr_fun hgf x } }

end PolyhedralLattice


import normed_free_pfpng.basic
import free_pfpng.basic
import condensed.exact
import condensed.condensify

open_locale nnreal big_operators

variables (p : ℝ≥0) (S : Fintype)
variables [fact (0 < p)] [fact (p ≤ 1)]

lemma nnnorm_int_rpow_le (n : ℤ) : ∥n∥₊ ^ (p : ℝ) ≤ ∥n∥₊ :=
begin
  have h0p : 0 < p := fact.out _,
  have hp1 : p ≤ 1 := fact.out _,
  rcases (eq_or_ne (∥n∥₊) 0) with (h|h),
  { simp only [h, le_zero_iff, nnreal.rpow_eq_zero_iff, eq_self_iff_true,
      ne.def, nnreal.coe_eq_zero, true_and],
    exact h0p.ne' },
  refine (nnreal.rpow_le_rpow_of_exponent_le _ hp1).trans _,
  swap, { rw [nnreal.coe_one, nnreal.rpow_one] },
  rw [← nnreal.coe_nat_abs] at h ⊢,
  norm_cast at h ⊢,
  exact nat.one_le_of_lt (ne.bot_lt h)
end

def free_pfpng_to_normed_free_pfpng :
  free_pfpng_functor ⟶ normed_free_pfpng_functor p :=
{ app := λ S,
  { to_fun := λ f, f,
    map_zero' := rfl,
    map_add' := λ _ _, rfl,
    strict' := begin
      have h0p : 0 < p := fact.out _,
      have hp1 : p ≤ 1 := fact.out _,
      rintro c f (hf : _ ≤ _),
      refine le_trans (finset.sum_le_sum _) hf,
      rintro s -,
      exact nnnorm_int_rpow_le p _,
    end,
    continuous' := λ c, continuous_of_discrete_topology },
  naturality' := by { intros S T f, ext φ t, refl } }
.

open category_theory

noncomputable
def cond_free_pfpng_to_normed_free_pfpng :
  condensify (free_pfpng_functor ⋙ PFPNG₁_to_CHFPNG₁ₑₗ) ⟶
  condensify (normed_free_pfpng_functor p ⋙ PFPNG₁_to_CHFPNG₁ₑₗ) :=
condensify_map $ whisker_right (free_pfpng_to_normed_free_pfpng p) _

open CompHausFiltPseuNormGrp₁

-- move me
lemma condensify_map_zero (F G : Fintype ⥤ CompHausFiltPseuNormGrp₁) :
  condensify_map (0 : F ⟶ G) = 0 :=
begin
  delta condensify_map condensify_nonstrict,
  suffices : nonstrict_extend
    (whisker_right (0 : F ⟶ G) CHFPNG₁_to_CHFPNGₑₗ) 1 _ = 0,
  { rw this, refl, },
  rw [nonstrict_extend_whisker_right_enlarging,
    Profinite.extend_nat_trans_zero],
  refl,
end

instance (S : Profinite) : mono ((cond_free_pfpng_to_normed_free_pfpng p).app S) :=
begin
  simp only [cond_free_pfpng_to_normed_free_pfpng, condensify_map, condensify_nonstrict],
  rw nonstrict_extend_whisker_right_enlarging,
  apply Condensed.mono_to_Condensed_map,
  apply exact_with_constant_extend_zero_left,
  intro S,
  apply_with exact_with_constant_of_mono { instances := ff },
  rw [AddCommGroup.mono_iff_injective, injective_iff_map_eq_zero],
  intros f hf,
  exact hf,
end

instance (S : Profinite) : epi ((cond_free_pfpng_to_normed_free_pfpng p).app S) :=
begin
  simp only [cond_free_pfpng_to_normed_free_pfpng, condensify_map, condensify_nonstrict],
  rw nonstrict_extend_whisker_right_enlarging,
  let κ : ℝ≥0 → ℝ≥0 := λ c, max c (c ^ (p⁻¹ : ℝ)),
  have hκ : id ≤ κ := λ c, le_max_left _ _,
  apply Condensed.epi_to_Condensed_map _ κ,
  apply exact_with_constant_extend_zero_right,
  intro S,
  apply exact_with_constant_of_epi _ _ _ hκ,
  intros c f hf,
  refine ⟨f, _, rfl⟩,
  change ∑ _, _ ≤ _ at hf,
  show ∑ _, _ ≤ _,
  have h0p : 0 < p := fact.out _,
  have hp1 : p ≤ 1 := fact.out _,
  have h0pinv : 0 ≤ p⁻¹, { rw ← nnreal.inv_pos at h0p, exact h0p.le },
  have := (nnreal.rpow_sum_le_sum_rpow _ _ h0p hp1).trans hf,
  replace this := nnreal.rpow_le_rpow this h0pinv,
  rw [← nnreal.rpow_mul, ← nnreal.coe_mul, mul_inv_cancel h0p.ne',
    nnreal.coe_one, nnreal.rpow_one] at this,
  exact this.trans (le_max_right _ _),
end

instance (S : Profinite) : is_iso ((cond_free_pfpng_to_normed_free_pfpng p).app S) :=
is_iso_of_mono_of_epi _


/-
Copyright (c) 2020 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Bhavik Mehta, Scott Morrison
-/
import category_theory.subobject.factor_thru
import category_theory.subobject.well_powered

/-!
# The lattice of subobjects

We provide the `semilattice_inf_top (subobject X)` instance when `[has_pullback C]`,
and the `semilattice_sup (subobject X)` instance when `[has_images C] [has_binary_coproducts C]`.
-/

universes v₁ v₂ u₁ u₂

noncomputable theory

open category_theory category_theory.category category_theory.limits

variables {C : Type u₁} [category.{v₁} C] {X Y Z : C}
variables {D : Type u₂} [category.{v₂} D]

namespace category_theory

namespace mono_over

section has_top

instance {X : C} : has_top (mono_over X) :=
{ top := mk' (𝟙 _) }

instance {X : C} : inhabited (mono_over X) := ⟨⊤⟩

/-- The morphism to the top object in `mono_over X`. -/
def le_top (f : mono_over X) : f ⟶ ⊤ :=
hom_mk f.arrow (comp_id _)

@[simp] lemma top_left (X : C) : ((⊤ : mono_over X) : C) = X := rfl
@[simp] lemma top_arrow (X : C) : (⊤ : mono_over X).arrow = 𝟙 X := rfl

/-- `map f` sends `⊤ : mono_over X` to `⟨X, f⟩ : mono_over Y`. -/
def map_top (f : X ⟶ Y) [mono f] : (map f).obj ⊤ ≅ mk' f :=
iso_of_both_ways (hom_mk (𝟙 _) rfl) (hom_mk (𝟙 _) (by simp [id_comp f]))

section
variable [has_pullbacks C]

/-- The pullback of the top object in `mono_over Y`
is (isomorphic to) the top object in `mono_over X`. -/
def pullback_top (f : X ⟶ Y) : (pullback f).obj ⊤ ≅ ⊤ :=
iso_of_both_ways (le_top _) (hom_mk (pullback.lift f (𝟙 _) (by tidy)) (pullback.lift_snd _ _ _))

/-- There is a morphism from `⊤ : mono_over A` to the pullback of a monomorphism along itself;
as the category is thin this is an isomorphism. -/
def top_le_pullback_self {A B : C} (f : A ⟶ B) [mono f] :
  (⊤ : mono_over A) ⟶ (pullback f).obj (mk' f) :=
hom_mk _ (pullback.lift_snd _ _ rfl)

/-- The pullback of a monomorphism along itself is isomorphic to the top object. -/
def pullback_self {A B : C} (f : A ⟶ B) [mono f] :
  (pullback f).obj (mk' f) ≅ ⊤ :=
iso_of_both_ways (le_top _) (top_le_pullback_self _)

end

end has_top

section has_bot
variables [has_zero_morphisms C] [has_zero_object C]
local attribute [instance] has_zero_object.has_zero

instance {X : C} : has_bot (mono_over X) :=
{ bot := mk' (0 : 0 ⟶ X) }

@[simp] lemma bot_left (X : C) : ((⊥ : mono_over X) : C) = 0 := rfl
@[simp] lemma bot_arrow {X : C} : (⊥ : mono_over X).arrow = 0 :=
by ext

/-- The (unique) morphism from `⊥ : mono_over X` to any other `f : mono_over X`. -/
def bot_le {X : C} (f : mono_over X) : ⊥ ⟶ f :=
hom_mk 0 (by simp)

/-- `map f` sends `⊥ : mono_over X` to `⊥ : mono_over Y`. -/
def map_bot (f : X ⟶ Y) [mono f] : (map f).obj ⊥ ≅ ⊥ :=
iso_of_both_ways (hom_mk 0 (by simp)) (hom_mk (𝟙 _) (by simp [id_comp f]))

end has_bot

section inf
variables [has_pullbacks C]

/--
When `[has_pullbacks C]`, `mono_over A` has "intersections", functorial in both arguments.

As `mono_over A` is only a preorder, this doesn't satisfy the axioms of `semilattice_inf`,
but we reuse all the names from `semilattice_inf` because they will be used to construct
`semilattice_inf (subobject A)` shortly.
-/
@[simps]
def inf {A : C} : mono_over A ⥤ mono_over A ⥤ mono_over A :=
{ obj := λ f, pullback f.arrow ⋙ map f.arrow,
  map := λ f₁ f₂ k,
  { app := λ g,
    begin
      apply hom_mk _ _,
      apply pullback.lift pullback.fst (pullback.snd ≫ k.left) _,
      rw [pullback.condition, assoc, w k],
      dsimp,
      rw [pullback.lift_snd_assoc, assoc, w k],
    end } }.

/-- A morphism from the "infimum" of two objects in `mono_over A` to the first object. -/
def inf_le_left {A : C} (f g : mono_over A) :
  (inf.obj f).obj g ⟶ f :=
hom_mk _ rfl

/-- A morphism from the "infimum" of two objects in `mono_over A` to the second object. -/
def inf_le_right {A : C} (f g : mono_over A) :
  (inf.obj f).obj g ⟶ g :=
hom_mk _ pullback.condition

/-- A morphism version of the `le_inf` axiom. -/
def le_inf {A : C} (f g h : mono_over A) :
  (h ⟶ f) → (h ⟶ g) → (h ⟶ (inf.obj f).obj g) :=
begin
  intros k₁ k₂,
  refine hom_mk (pullback.lift k₂.left k₁.left _) _,
  rw [w k₁, w k₂],
  erw [pullback.lift_snd_assoc, w k₁],
end

end inf

section sup
variables [has_images C] [has_binary_coproducts C]

/-- When `[has_images C] [has_binary_coproducts C]`, `mono_over A` has a `sup` construction,
which is functorial in both arguments,
and which on `subobject A` will induce a `semilattice_sup`. -/
def sup  {A : C} : mono_over A ⥤ mono_over A ⥤ mono_over A :=
curry_obj ((forget A).prod (forget A) ⋙ uncurry.obj over.coprod ⋙ image)

/-- A morphism version of `le_sup_left`. -/
def le_sup_left {A : C} (f g : mono_over A) :
  f ⟶ (sup.obj f).obj g :=
begin
  refine hom_mk (coprod.inl ≫ factor_thru_image _) _,
  erw [category.assoc, image.fac, coprod.inl_desc],
  refl,
end

/-- A morphism version of `le_sup_right`. -/
def le_sup_right {A : C} (f g : mono_over A) :
  g ⟶ (sup.obj f).obj g :=
begin
  refine hom_mk (coprod.inr ≫ factor_thru_image _) _,
  erw [category.assoc, image.fac, coprod.inr_desc],
  refl,
end

/-- A morphism version of `sup_le`. -/
def sup_le {A : C} (f g h : mono_over A) :
  (f ⟶ h) → (g ⟶ h) → ((sup.obj f).obj g ⟶ h) :=
begin
  intros k₁ k₂,
  refine hom_mk _ _,
  apply image.lift ⟨_, h.arrow, coprod.desc k₁.left k₂.left, _⟩,
  { dsimp,
    ext1,
    { simp [w k₁] },
    { simp [w k₂] } },
  { apply image.lift_fac }
end

end sup

end mono_over

namespace subobject

section order_top

instance order_top {X : C} : order_top (subobject X) :=
{ top := quotient.mk' ⊤,
  le_top :=
  begin
    refine quotient.ind' (λ f, _),
    exact ⟨mono_over.le_top f⟩,
  end,
  ..subobject.partial_order X}

instance {X : C} : inhabited (subobject X) := ⟨⊤⟩

lemma top_eq_id (B : C) : (⊤ : subobject B) = subobject.mk (𝟙 B) := rfl

/-- The object underlying `⊤ : subobject B` is (up to isomorphism) `B`. -/
def top_coe_iso_self {B : C} : ((⊤ : subobject B) : C) ≅ B := underlying_iso _

@[simp]
lemma underlying_iso_id_eq_top_coe_iso_self {B : C} : underlying_iso (𝟙 B) = top_coe_iso_self :=
rfl

@[simp, reassoc]
lemma underlying_iso_inv_top_arrow {B : C} :
  top_coe_iso_self.inv ≫ (⊤ : subobject B).arrow = 𝟙 B :=
underlying_iso_arrow _

@[simp]
lemma map_top (f : X ⟶ Y) [mono f] : (map f).obj ⊤ = subobject.mk f :=
quotient.sound' ⟨mono_over.map_top f⟩

lemma top_factors {A B : C} (f : A ⟶ B) : (⊤ : subobject B).factors f :=
⟨f, comp_id _⟩

lemma is_iso_iff_mk_eq_top {X Y : C} (f : X ⟶ Y) [mono f] : is_iso f ↔ mk f = ⊤ :=
⟨λ _, by exactI mk_eq_mk_of_comm _ _ (as_iso f) (category.comp_id _), λ h,
  by { rw [←of_mk_le_mk_comp h.le, category.comp_id], exact is_iso.of_iso (iso_of_mk_eq_mk _ _ h) }⟩

lemma is_iso_arrow_iff_eq_top {Y : C} (P : subobject Y) : is_iso P.arrow ↔ P = ⊤ :=
by rw [is_iso_iff_mk_eq_top, mk_arrow]

instance is_iso_top_arrow {Y : C} : is_iso (⊤ : subobject Y).arrow :=
by rw is_iso_arrow_iff_eq_top

lemma mk_eq_top_of_is_iso {X Y : C} (f : X ⟶ Y) [is_iso f] : mk f = ⊤ :=
(is_iso_iff_mk_eq_top f).mp infer_instance

lemma eq_top_of_is_iso_arrow {Y : C} (P : subobject Y) [is_iso P.arrow] : P = ⊤ :=
(is_iso_arrow_iff_eq_top P).mp infer_instance

section
variables [has_pullbacks C]

lemma pullback_top (f : X ⟶ Y) : (pullback f).obj ⊤ = ⊤ :=
quotient.sound' ⟨mono_over.pullback_top f⟩

lemma pullback_self {A B : C} (f : A ⟶ B) [mono f] :
  (pullback f).obj (mk f) = ⊤ :=
quotient.sound' ⟨mono_over.pullback_self f⟩

end

end order_top

section order_bot
variables [has_zero_morphisms C] [has_zero_object C]
local attribute [instance] has_zero_object.has_zero

instance order_bot {X : C} : order_bot (subobject X) :=
{ bot := quotient.mk' ⊥,
  bot_le :=
  begin
    refine quotient.ind' (λ f, _),
    exact ⟨mono_over.bot_le f⟩,
  end,
  ..subobject.partial_order X }

lemma bot_eq_zero {B : C} : (⊥ : subobject B) = subobject.mk (0 : 0 ⟶ B) := rfl

/-- The object underlying `⊥ : subobject B` is (up to isomorphism) the zero object. -/
def bot_coe_iso_zero {B : C} : ((⊥ : subobject B) : C) ≅ 0 := underlying_iso _

@[simp] lemma bot_arrow {B : C} : (⊥ : subobject B).arrow = 0 :=
zero_of_source_iso_zero _ bot_coe_iso_zero

lemma map_bot (f : X ⟶ Y) [mono f] : (map f).obj ⊥ = ⊥ :=
quotient.sound' ⟨mono_over.map_bot f⟩

lemma bot_factors_iff_zero {A B : C} (f : A ⟶ B) : (⊥ : subobject B).factors f ↔ f = 0 :=
⟨by { rintro ⟨h, w⟩, simp at w, exact w.symm, }, by { rintro rfl, exact ⟨0, by simp⟩, }⟩

end order_bot

section functor
variable (C)

/-- Sending `X : C` to `subobject X` is a contravariant functor `Cᵒᵖ ⥤ Type`. -/
@[simps]
def functor [has_pullbacks C] : Cᵒᵖ ⥤ Type (max u₁ v₁) :=
{ obj := λ X, subobject X.unop,
  map := λ X Y f, (pullback f.unop).obj,
  map_id' := λ X, funext pullback_id,
  map_comp' := λ X Y Z f g, funext (pullback_comp _ _) }

end functor

section semilattice_inf_top
variables [has_pullbacks C]

/-- The functorial infimum on `mono_over A` descends to an infimum on `subobject A`. -/
def inf {A : C} : subobject A ⥤ subobject A ⥤ subobject A :=
thin_skeleton.map₂ mono_over.inf

lemma inf_le_left  {A : C} (f g : subobject A) :
  (inf.obj f).obj g ≤ f :=
quotient.induction_on₂' f g (λ a b, ⟨mono_over.inf_le_left _ _⟩)

lemma inf_le_right {A : C} (f g : subobject A) :
  (inf.obj f).obj g ≤ g :=
quotient.induction_on₂' f g (λ a b, ⟨mono_over.inf_le_right _ _⟩)

lemma le_inf {A : C} (h f g : subobject A) :
  h ≤ f → h ≤ g → h ≤ (inf.obj f).obj g :=
quotient.induction_on₃' h f g
begin
  rintros f g h ⟨k⟩ ⟨l⟩,
  exact ⟨mono_over.le_inf _ _ _ k l⟩,
end

instance {B : C} : semilattice_inf_top (subobject B) :=
{ inf := λ m n, (inf.obj m).obj n,
  inf_le_left := inf_le_left,
  inf_le_right := inf_le_right,
  le_inf := le_inf,
  ..subobject.order_top }

lemma factors_left_of_inf_factors {A B : C} {X Y : subobject B} {f : A ⟶ B}
  (h : (X ⊓ Y).factors f) : X.factors f :=
factors_of_le _ (inf_le_left _ _) h

lemma factors_right_of_inf_factors {A B : C} {X Y : subobject B} {f : A ⟶ B}
  (h : (X ⊓ Y).factors f) : Y.factors f :=
factors_of_le _ (inf_le_right _ _) h

@[simp]
lemma inf_factors {A B : C} {X Y : subobject B} (f : A ⟶ B) :
  (X ⊓ Y).factors f ↔ X.factors f ∧ Y.factors f :=
⟨λ h, ⟨factors_left_of_inf_factors h, factors_right_of_inf_factors h⟩,
  begin
    revert X Y,
    refine quotient.ind₂' _,
    rintro X Y ⟨⟨g₁, rfl⟩, ⟨g₂, hg₂⟩⟩,
    exact ⟨_, pullback.lift_snd_assoc _ _ hg₂ _⟩,
  end⟩

lemma inf_arrow_factors_left {B : C} (X Y : subobject B) : X.factors (X ⊓ Y).arrow :=
(factors_iff _ _).mpr ⟨of_le (X ⊓ Y) X (inf_le_left X Y), by simp⟩

@[simp]
lemma finset_inf_factors {I : Type*} {A B : C} {s : finset I} {P : I → subobject B}
  (f : A ⟶ B) :
  (s.inf P).factors f ↔ ∀ i ∈ s, (P i).factors f :=
begin
  classical,
  apply finset.induction_on s,
  { simp [top_factors] },
  { intros i s nm ih, simp [ih] },
end

-- `i` is explicit here because often we'd like to defer a proof of `m`
lemma finset_inf_arrow_factors {I : Type*} {B : C} (s : finset I) (P : I → subobject B)
  (i : I) (m : i ∈ s) : (P i).factors (s.inf P).arrow :=
begin
  revert i m,
  classical,
  apply finset.induction_on s,
  { rintro _ ⟨⟩, },
  { intros i s nm ih j m,
    rw [finset.inf_insert],
    simp only [finset.mem_insert] at m, rcases m with (rfl|m),
    { rw ←factor_thru_arrow _ _ (inf_arrow_factors_left _ _),
      exact factors_comp_arrow _, },
    { rw ←factor_thru_arrow _ _ (inf_arrow_factors_right _ _),
      apply factors_of_factors_right,
      exact ih _ m, } },
end

lemma inf_eq_map_pullback' {A : C} (f₁ : mono_over A) (f₂ : subobject A) :
  (subobject.inf.obj (quotient.mk' f₁)).obj f₂ =
    (subobject.map f₁.arrow).obj ((subobject.pullback f₁.arrow).obj f₂) :=
begin
  apply quotient.induction_on' f₂,
  intro f₂,
  refl,
end

lemma inf_eq_map_pullback {A : C} (f₁ : mono_over A) (f₂ : subobject A) :
  (quotient.mk' f₁ ⊓ f₂ : subobject A) = (map f₁.arrow).obj ((pullback f₁.arrow).obj f₂) :=
inf_eq_map_pullback' f₁ f₂

lemma prod_eq_inf {A : C} {f₁ f₂ : subobject A} [has_binary_product f₁ f₂] :
  (f₁ ⨯ f₂) = f₁ ⊓ f₂ :=
le_antisymm
  (_root_.le_inf
    (le_of_hom limits.prod.fst)
    (le_of_hom limits.prod.snd))
  (le_of_hom
    (prod.lift
      (hom_of_le _root_.inf_le_left)
      (hom_of_le _root_.inf_le_right)))

lemma inf_def {B : C} (m m' : subobject B) :
  m ⊓ m' = (inf.obj m).obj m' := rfl

/-- `⊓` commutes with pullback. -/
lemma inf_pullback {X Y : C} (g : X ⟶ Y) (f₁ f₂) :
  (pullback g).obj (f₁ ⊓ f₂) = (pullback g).obj f₁ ⊓ (pullback g).obj f₂ :=
begin
  revert f₁,
  apply quotient.ind',
  intro f₁,
  erw [inf_def, inf_def, inf_eq_map_pullback', inf_eq_map_pullback', ← pullback_comp,
       ← map_pullback pullback.condition (pullback_is_pullback f₁.arrow g),
       ← pullback_comp, pullback.condition],
  refl,
end

/-- `⊓` commutes with map. -/
lemma inf_map {X Y : C} (g : Y ⟶ X) [mono g] (f₁ f₂) :
  (map g).obj (f₁ ⊓ f₂) = (map g).obj f₁ ⊓ (map g).obj f₂ :=
begin
  revert f₁,
  apply quotient.ind',
  intro f₁,
  erw [inf_def, inf_def, inf_eq_map_pullback',
       inf_eq_map_pullback', ← map_comp],
  dsimp,
  rw [pullback_comp, pullback_map_self],
end

end semilattice_inf_top

section semilattice_sup
variables [has_images C] [has_binary_coproducts C]

/-- The functorial supremum on `mono_over A` descends to an supremum on `subobject A`. -/
def sup {A : C} : subobject A ⥤ subobject A ⥤ subobject A :=
thin_skeleton.map₂ mono_over.sup

instance {B : C} : semilattice_sup (subobject B) :=
{ sup := λ m n, (sup.obj m).obj n,
  le_sup_left := λ m n, quotient.induction_on₂' m n (λ a b, ⟨mono_over.le_sup_left _ _⟩),
  le_sup_right := λ m n, quotient.induction_on₂' m n (λ a b, ⟨mono_over.le_sup_right _ _⟩),
  sup_le := λ m n k, quotient.induction_on₃' m n k (λ a b c ⟨i⟩ ⟨j⟩, ⟨mono_over.sup_le _ _ _ i j⟩),
  ..subobject.partial_order B }

lemma sup_factors_of_factors_left {A B : C} {X Y : subobject B} {f : A ⟶ B} (P : X.factors f) :
  (X ⊔ Y).factors f :=
factors_of_le f le_sup_left P

lemma sup_factors_of_factors_right {A B : C} {X Y : subobject B} {f : A ⟶ B} (P : Y.factors f) :
  (X ⊔ Y).factors f :=
factors_of_le f le_sup_right P

/-!
Unfortunately, there are two different ways we may obtain a `semilattice_sup_bot (subobject B)`,
either as here, by assuming `[has_zero_morphisms C] [has_zero_object C]`,
or if `C` is cartesian closed.

These will be definitionally different, and at the very least we will need two different versions
of `finset_sup_factors`. So far I don't see how to handle this through generalization.
-/
section
variables [has_zero_morphisms C] [has_zero_object C]

instance {B : C} : semilattice_sup_bot (subobject B) :=
{ ..subobject.order_bot,
  ..subobject.semilattice_sup }

lemma finset_sup_factors {I : Type*} {A B : C} {s : finset I} {P : I → subobject B}
  {f : A ⟶ B} (h : ∃ i ∈ s, (P i).factors f) :
  (s.sup P).factors f :=
begin
  classical,
  revert h,
  apply finset.induction_on s,
  { rintro ⟨_, ⟨⟨⟩, _⟩⟩, },
  { rintros i s nm ih ⟨j, ⟨m, h⟩⟩,
    simp only [finset.sup_insert],
    simp at m, rcases m with (rfl|m),
    { exact sup_factors_of_factors_left h, },
    { exact sup_factors_of_factors_right (ih ⟨j, ⟨m, h⟩⟩), }, },
end

end

end semilattice_sup

section lattice
variables [has_pullbacks C] [has_images C] [has_binary_coproducts C]

instance {B : C} : lattice (subobject B) :=
{ ..subobject.semilattice_inf_top,
  ..subobject.semilattice_sup }

variables [has_zero_morphisms C] [has_zero_object C]

instance {B : C} : bounded_lattice (subobject B) :=
{ ..subobject.semilattice_inf_top,
  ..subobject.semilattice_sup_bot }

end lattice

section Inf

variables [well_powered C]

/--
The "wide cospan" diagram, with a small indexing type, constructed from a set of subobjects.
(This is just the diagram of all the subobjects pasted together, but using `well_powered C`
to make the diagram small.)
-/
def wide_cospan {A : C} (s : set (subobject A)) :
  wide_pullback_shape (equiv_shrink _ '' s) ⥤ C :=
wide_pullback_shape.wide_cospan A
  (λ j : equiv_shrink _ '' s, (((equiv_shrink (subobject A)).symm j) : C))
  (λ j, ((equiv_shrink (subobject A)).symm j).arrow)

@[simp] lemma wide_cospan_map_term {A : C} (s : set (subobject A)) (j) :
  (wide_cospan s).map (wide_pullback_shape.hom.term j) =
    ((equiv_shrink (subobject A)).symm j).arrow :=
rfl

/-- Auxilliary construction of a cone for `le_Inf`. -/
def le_Inf_cone {A : C} (s : set (subobject A)) (f : subobject A) (k : Π (g ∈ s), f ≤ g) :
  cone (wide_cospan s) :=
wide_pullback_shape.mk_cone f.arrow
  (λ j, underlying.map (hom_of_le (k _ (by { rcases j with ⟨-, ⟨g, ⟨m, rfl⟩⟩⟩, simpa using m, }))))
  (by tidy)

@[simp] lemma le_Inf_cone_π_app_none
  {A : C} (s : set (subobject A)) (f : subobject A) (k : Π (g ∈ s), f ≤ g) :
  (le_Inf_cone s f k).π.app none = f.arrow :=
rfl

variables [has_wide_pullbacks C]

/--
The limit of `wide_cospan s`. (This will be the supremum of the set of subobjects.)
-/
def wide_pullback {A : C} (s : set (subobject A)) : C :=
limits.limit (wide_cospan s)

/--
The inclusion map from `wide_pullback s` to `A`
-/
def wide_pullback_ι {A : C} (s : set (subobject A)) :
  wide_pullback s ⟶ A :=
limits.limit.π (wide_cospan s) none

instance wide_pullback_ι_mono {A : C} (s : set (subobject A)) :
  mono (wide_pullback_ι s) :=
⟨λ W u v h, limit.hom_ext (λ j, begin
  cases j,
  { exact h, },
  { apply (cancel_mono ((equiv_shrink (subobject A)).symm j).arrow).1,
    rw [assoc, assoc],
    erw limit.w (wide_cospan s) (wide_pullback_shape.hom.term j),
    exact h, },
end)⟩

/--
When `[well_powered C]` and `[has_wide_pullbacks C]`, `subobject A` has arbitrary infimums.
-/
def Inf {A : C} (s : set (subobject A)) : subobject A :=
subobject.mk (wide_pullback_ι s)

lemma Inf_le {A : C} (s : set (subobject A)) (f ∈ s) :
  Inf s ≤ f :=
begin
  fapply le_of_comm,
  { refine (underlying_iso _).hom ≫
      (limits.limit.π
        (wide_cospan s)
        (some ⟨equiv_shrink _ f, set.mem_image_of_mem (equiv_shrink (subobject A)) H⟩)) ≫ _,
    apply eq_to_hom,
    apply (congr_arg (λ X : subobject A, (X : C))),
    exact (equiv.symm_apply_apply _ _), },
  { dsimp [Inf],
    simp only [category.comp_id, category.assoc, ←underlying_iso_hom_comp_eq_mk,
      subobject.arrow_congr, congr_arg_mpr_hom_left, iso.cancel_iso_hom_left],
    convert limit.w (wide_cospan s) (wide_pullback_shape.hom.term _), },
end.

lemma le_Inf {A : C} (s : set (subobject A)) (f : subobject A) (k : Π (g ∈ s), f ≤ g) :
  f ≤ Inf s :=
begin
  fapply le_of_comm,
  { exact limits.limit.lift _ (le_Inf_cone s f k) ≫ (underlying_iso _).inv, },
  { dsimp [Inf, wide_pullback_ι],
    simp, },
end

instance {B : C} : complete_semilattice_Inf (subobject B) :=
{ Inf := Inf,
  Inf_le := Inf_le,
  le_Inf := le_Inf,
  ..subobject.partial_order B }

end Inf

section Sup

variables [well_powered C] [has_coproducts C]

/--
The univesal morphism out of the coproduct of a set of subobjects,
after using `[well_powered C]` to reindex by a small type.
-/
def small_coproduct_desc {A : C} (s : set (subobject A)) : _ ⟶ A :=
limits.sigma.desc (λ j : equiv_shrink _ '' s, ((equiv_shrink (subobject A)).symm j).arrow)

variables [has_images C]

/-- When `[well_powered C] [has_images C] [has_coproducts C]`,
`subobject A` has arbitrary supremums. -/
def Sup {A : C} (s : set (subobject A)) : subobject A :=
subobject.mk (image.ι (small_coproduct_desc s))

lemma le_Sup {A : C} (s : set (subobject A)) (f ∈ s)  :
  f ≤ Sup s :=
begin
  fapply le_of_comm,
  { dsimp [Sup],
    refine _ ≫ factor_thru_image _ ≫ (underlying_iso _).inv,
    refine _ ≫ sigma.ι _ ⟨equiv_shrink _ f, (by simpa [set.mem_image] using H)⟩,
    exact eq_to_hom (congr_arg (λ X : subobject A, (X : C)) (equiv.symm_apply_apply _ _).symm), },
  { dsimp [Sup, small_coproduct_desc],
    simp, dsimp, simp, },
end

lemma symm_apply_mem_iff_mem_image {α β : Type*} (e : α ≃ β) (s : set α) (x : β) :
  e.symm x ∈ s ↔ x ∈ e '' s :=
⟨λ h, ⟨e.symm x, h, by simp⟩, by { rintro ⟨a, m, rfl⟩, simpa using m, }⟩

lemma Sup_le {A : C} (s : set (subobject A)) (f : subobject A) (k : Π (g ∈ s), g ≤ f) :
  Sup s ≤ f :=
begin
  fapply le_of_comm,
  { dsimp [Sup],
    refine (underlying_iso _).hom ≫ image.lift ⟨_, f.arrow, _, _⟩,
    { refine sigma.desc _,
      rintro ⟨g, m⟩,
      refine underlying.map (hom_of_le (k _ _)),
      simpa [symm_apply_mem_iff_mem_image] using m, },
    { ext j, rcases j with ⟨j, m⟩, dsimp [small_coproduct_desc], simp, dsimp, simp, }, },
  { dsimp [Sup],
    simp, },
end

instance {B : C} : complete_semilattice_Sup (subobject B) :=
{ Sup := Sup,
  le_Sup := le_Sup,
  Sup_le := Sup_le,
  ..subobject.partial_order B }

end Sup

section complete_lattice
variables [well_powered C] [has_wide_pullbacks C] [has_images C] [has_coproducts C]
  [has_zero_morphisms C] [has_zero_object C]

instance {B : C} : complete_lattice (subobject B) :=
{ ..subobject.semilattice_inf_top,
  ..subobject.semilattice_sup_bot,
  ..subobject.complete_semilattice_Inf,
  ..subobject.complete_semilattice_Sup, }

end complete_lattice

end subobject

end category_theory


/-
Copyright (c) 2022 Yuma Mizuno. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Yuma Mizuno
-/
import category_theory.bicategory.functor

/-!
# Oplax natural transformations

Just as there are natural transformations between functors, there are oplax natural transformations
between oplax functors. The equality in the naturality of natural transformations is replaced by a
specified 2-morphism `F.map f ≫ app b ⟶ app a ≫ G.map f` in the case of oplax natural
transformations.

## Main definitions

* `oplax_nat_trans F G` : oplax natural transformations between oplax functors `F` and `G`
* `oplax_nat_trans.vcomp η θ` : the vertical composition of oplax natural transformations `η`
  and `θ`
* `oplax_nat_trans.category F G` : the category structure on the oplax natural transformations
  between `F` and `G`
-/

namespace category_theory

open category bicategory
open_locale bicategory

universes w₁ w₂ v₁ v₂ u₁ u₂

variables {B : Type u₁} [bicategory.{w₁ v₁} B] {C : Type u₂} [bicategory.{w₂ v₂} C]

/--
If `η` is an oplax natural transformation between `F` and `G`, we have a 1-morphism
`η.app a : F.obj a ⟶ G.obj a` for each object `a : B`. We also have a 2-morphism
`η.naturality f : F.map f ≫ app b ⟶ app a ≫ G.map f` for each 1-morphism `f : a ⟶ b`.
These 2-morphisms satisfies the naturality condition, and preserve the identities and
the compositions modulo some adjustments of domains and codomains of 2-morphisms.
-/
structure oplax_nat_trans (F G : oplax_functor B C) :=
(app (a : B) : F.obj a ⟶ G.obj a)
(naturality {a b : B} (f : a ⟶ b) : F.map f ≫ app b ⟶ app a ≫ G.map f)
(naturality_naturality' : ∀ {a b : B} {f g : a ⟶ b} (η : f ⟶ g),
  (F.map₂ η ▷ app b) ≫ naturality g = naturality f ≫ (app a ◁ G.map₂ η) . obviously)
(naturality_id' : ∀ a : B,
  naturality (𝟙 a) ≫ (app a ◁ G.map_id a) =
    (F.map_id a ▷ app a) ≫ (λ_ (app a)).hom ≫ (ρ_ (app a)).inv . obviously)
(naturality_comp' : ∀ {a b c : B} (f : a ⟶ b) (g : b ⟶ c),
  naturality (f ≫ g) ≫ (app a ◁ G.map_comp f g) =
    (F.map_comp f g ▷ app c) ≫ (α_ _ _ _).hom ≫
      (F.map f ◁ naturality g) ≫ (α_ _ _ _).inv ≫
        (naturality f ▷ G.map g) ≫ (α_ _ _ _).hom . obviously)

restate_axiom oplax_nat_trans.naturality_naturality'
restate_axiom oplax_nat_trans.naturality_id'
restate_axiom oplax_nat_trans.naturality_comp'
attribute [simp, reassoc] oplax_nat_trans.naturality_naturality
  oplax_nat_trans.naturality_id oplax_nat_trans.naturality_comp

namespace oplax_nat_trans

section
variables (F : oplax_functor B C)

/-- The identity oplax natural transformation. -/
@[simps]
def id : oplax_nat_trans F F :=
{ app := λ a, 𝟙 (F.obj a),
  naturality := λ a b f, (ρ_ (F.map f)).hom ≫ (λ_ (F.map f)).inv,
  naturality_naturality' := λ a b f f' η, by
  { rw [assoc, ←left_unitor_inv_naturality, ←right_unitor_naturality_assoc] },
  naturality_comp' := λ a b c f g, by
  { rw [assoc, ←left_unitor_inv_naturality, ←right_unitor_naturality_assoc],
    simp only [triangle_assoc_comp_right_assoc, right_unitor_comp, left_unitor_comp_inv,
      whisker_right_comp, inv_hom_whisker_left_assoc, assoc, whisker_left_comp] },
  naturality_id' := λ a, by
  { rw [assoc, ←left_unitor_inv_naturality, ←right_unitor_naturality_assoc,
      unitors_equal, unitors_inv_equal] } }

instance : inhabited (oplax_nat_trans F F) := ⟨id F⟩

variables {F} {G H : oplax_functor B C} (η : oplax_nat_trans F G) (θ : oplax_nat_trans G H)

section
variables {a b c : B} {a' : C}

@[simp, reassoc]
lemma whisker_left_naturality_naturality (f : a' ⟶ G.obj a) {g h : a ⟶ b} (β : g ⟶ h) :
  (f ◁ (G.map₂ β ▷ θ.app b)) ≫ (f ◁ θ.naturality h) =
    (f ◁ θ.naturality g) ≫ (f ◁ (θ.app a ◁ H.map₂ β)) :=
by simp only [←whisker_left_comp, naturality_naturality]

@[simp, reassoc]
lemma whisker_right_naturality_naturality {f g : a ⟶ b} (β : f ⟶ g) (h : G.obj b ⟶ a') :
  ((F.map₂ β ▷ η.app b) ▷ h) ≫ (η.naturality g ▷ h) =
    (η.naturality f ▷ h) ≫ ((η.app a ◁ G.map₂ β) ▷ h) :=
by simp only [←whisker_right_comp, naturality_naturality]

@[simp, reassoc]
lemma whisker_left_naturality_comp (f : a' ⟶ G.obj a) (g : a ⟶ b) (h : b ⟶ c) :
  (f ◁ θ.naturality (g ≫ h)) ≫ (f ◁ (θ.app a ◁ H.map_comp g h)) =
    (f ◁ (G.map_comp g h ▷ θ.app c)) ≫ (f ◁ (α_ _ _ _).hom) ≫
      (f ◁ (G.map g ◁ θ.naturality h)) ≫ (f ◁ (α_ _ _ _).inv) ≫
        (f ◁ (θ.naturality g ▷ H.map h)) ≫ (f ◁ (α_ _ _ _).hom) :=
by simp only [←whisker_left_comp, naturality_comp]

@[simp, reassoc]
lemma whisker_right_naturality_comp (f : a ⟶ b) (g : b ⟶ c) (h : G.obj c ⟶ a') :
  (η.naturality (f ≫ g) ▷ h) ≫ ((η.app a ◁ G.map_comp f g) ▷ h) =
    ((F.map_comp f g ▷ η.app c) ▷ h) ≫ ((α_ _ _ _).hom ▷ h) ≫
      ((F.map f ◁ η.naturality g) ▷ h) ≫ ((α_ _ _ _).inv ▷ h) ≫
        ((η.naturality f ▷ G.map g) ▷ h) ≫ ((α_ _ _ _).hom ▷ h) :=
by simp only [←whisker_right_comp, naturality_comp]

@[simp, reassoc]
lemma whisker_left_naturality_id (f : a' ⟶ G.obj a) :
  (f ◁ θ.naturality (𝟙 a)) ≫ (f ◁ (θ.app a ◁ H.map_id a)) =
    (f ◁ (G.map_id a ▷ θ.app a)) ≫ (f ◁ (λ_ (θ.app a)).hom) ≫ (f ◁ (ρ_ (θ.app a)).inv) :=
by simp only [←whisker_left_comp, naturality_id]

@[simp, reassoc]
lemma whisker_right_naturality_id (f : G.obj a ⟶ a') :
  (η.naturality (𝟙 a) ▷ f) ≫ ((η.app a ◁ G.map_id a) ▷ f) =
    ((F.map_id a ▷ η.app a) ▷ f) ≫ ((λ_ (η.app a)).hom ▷ f) ≫ ((ρ_ (η.app a)).inv ▷ f) :=
by simp only [←whisker_right_comp, naturality_id]

end

/-- Vertical composition of oplax natural transformations. -/
@[simps]
def vcomp (η : oplax_nat_trans F G) (θ : oplax_nat_trans G H) : oplax_nat_trans F H :=
{ app := λ a, η.app a ≫ θ.app a,
  naturality := λ a b f,
    (α_ _ _ _).inv ≫ (η.naturality f ▷ θ.app b) ≫ (α_ _ _ _).hom ≫
      (η.app a ◁ θ.naturality f) ≫ (α_ _ _ _).inv,
  naturality_naturality' := λ a b f g ι, by
  { simp only [whisker_right_comp, assoc, whisker_left_comp],
    rw [←associator_inv_naturality_right, ←whisker_left_naturality_naturality_assoc,
        ←associator_naturality_middle_assoc, ←whisker_right_naturality_naturality_assoc,
        ←associator_inv_naturality_left_assoc] },
  naturality_comp' := λ a b c f g, by
  { simp only [whisker_right_comp, assoc, whisker_left_comp],
    rw [←associator_inv_naturality_right, whisker_left_naturality_comp_assoc,
        ←associator_naturality_middle_assoc, whisker_right_naturality_comp_assoc,
        ←associator_inv_naturality_left_assoc],
    rw [←pentagon_hom_hom_inv_inv_hom, associator_naturality_middle_assoc,
        ←pentagon_inv_hom_hom_hom_inv_assoc, ←associator_naturality_middle_assoc],
    slice_rhs 5 13
    { rw [←pentagon_inv_hom_hom_hom_hom_assoc, ←pentagon_hom_hom_inv_hom_hom,
          associator_naturality_left_assoc, ←associator_naturality_right_assoc,
          pentagon_inv_inv_hom_hom_inv_assoc, inv_hom_whisker_left_assoc, iso.hom_inv_id_assoc,
          whisker_exchange_assoc, associator_naturality_right_assoc,
          ←associator_naturality_left_assoc, ←pentagon_assoc] },
    simp only [assoc] },
  naturality_id' := λ a, by
  { simp only [whisker_right_comp, assoc, whisker_left_comp],
    rw [←associator_inv_naturality_right, whisker_left_naturality_id_assoc,
        ←associator_naturality_middle_assoc, whisker_right_naturality_id_assoc,
        ←associator_inv_naturality_left_assoc],
    simp only [left_unitor_comp, triangle_assoc, inv_hom_whisker_right_assoc, assoc,
      right_unitor_comp_inv] } }

variables (B C)

@[simps]
instance : category_struct (oplax_functor B C) :=
{ hom := λ F G, oplax_nat_trans F G,
  id := oplax_nat_trans.id,
  comp := λ F G H, oplax_nat_trans.vcomp }

end

section
variables {F G : oplax_functor B C}

/--
A modification `Γ` between oplax natural transformations `η` and `θ` consists of a family of
2-morphisms `Γ.app a : η.app a ⟶ θ.app a`, which satisfies the equation
`(F.map f ◁ app b) ≫ θ.naturality f = η.naturality f ≫ (app a ▷ G.map f)`
for each 1-morphism `f : a ⟶ b`.
-/
@[ext]
structure modification (η θ : F ⟶ G) :=
(app (a : B) : η.app a ⟶ θ.app a)
(naturality' : ∀ {a b : B} (f : a ⟶ b),
  (F.map f ◁ app b) ≫ θ.naturality f = η.naturality f ≫ (app a ▷ G.map f) . obviously)

restate_axiom modification.naturality'
attribute [simp, reassoc] modification.naturality

variables {η θ ι : F ⟶ G}

namespace modification

variables (η)

/-- The identity modification. -/
@[simps]
def id : modification η η := { app := λ a, 𝟙 (η.app a) }

instance : inhabited (modification η η) := ⟨modification.id η⟩

variables {η}

section
variables (Γ : modification η θ) {a b c : B} {a' : C}

@[reassoc]
lemma whisker_left_naturality (f : a' ⟶ F.obj b) (g : b ⟶ c) :
  (f ◁ (F.map g ◁ Γ.app c)) ≫ (f ◁ θ.naturality g) =
    (f ◁ η.naturality g) ≫ (f ◁ (Γ.app b ▷ G.map g)) :=
by simp only [←bicategory.whisker_left_comp, naturality]

@[reassoc]
lemma whisker_right_naturality (f : a ⟶ b) (g : G.obj b ⟶ a') :
  ((F.map f ◁ Γ.app b) ▷ g) ≫ (θ.naturality f ▷ g) =
    (η.naturality f ▷ g) ≫ ((Γ.app a ▷ G.map f) ▷ g) :=
by simp only [←bicategory.whisker_right_comp, naturality]

end

/-- Vertical composition of modifications. -/
@[simps]
def vcomp (Γ : modification η θ) (Δ : modification θ ι) : modification η ι :=
{ app := λ a, Γ.app a ≫ Δ.app a }

end modification

/-- Category structure on the oplax natural transformations between oplax_functors. -/
@[simps]
instance category (F G : oplax_functor B C) : category (F ⟶ G) :=
{ hom  := modification,
  id   := modification.id,
  comp := λ η θ ι, modification.vcomp }

/--
Construct a modification isomorphism between oplax natural transformations
by giving object level isomorphisms, and checking naturality only in the forward direction.
-/
@[simps]
def modification_iso.of_components
  (app : ∀ a, η.app a ≅ θ.app a)
  (naturality : ∀ {a b} (f : a ⟶ b),
    (F.map f ◁ (app b).hom) ≫ θ.naturality f = η.naturality f ≫ ((app a).hom ▷ G.map f)) :
  η ≅ θ :=
{ hom := { app := λ a, (app a).hom },
  inv :=
  { app := λ a, (app a).inv,
    naturality' := λ a b f, by simpa using
      congr_arg (λ f, (_ ◁ (app b).inv) ≫ f ≫ ((app a).inv ▷ _)) (naturality f).symm } }

end

end oplax_nat_trans

end category_theory