/-
Copyright (c) 2019 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Scott Morrison, Bhavik Mehta
-/
import category_theory.monad.adjunction
import category_theory.adjunction.limits
import category_theory.limits.preserves.shapes.terminal

/-!
# Limits and colimits in the category of algebras

This file shows that the forgetful functor `forget T : algebra T ⥤ C` for a monad `T : C ⥤ C`
creates limits and creates any colimits which `T` preserves.
This is used to show that `algebra T` has any limits which `C` has, and any colimits which `C` has
and `T` preserves.
This is generalised to the case of a monadic functor `D ⥤ C`.

## TODO

Dualise for the category of coalgebras and comonadic left adjoints.
-/

namespace category_theory
open category
open category_theory.limits

universes v u v₁ v₂ u₁ u₂
-- morphism levels before object levels. See note [category_theory universes].

namespace monad

variables {C : Type u₁} [category.{v₁} C]
variables {T : monad C}

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

namespace forget_creates_limits

variables (D : J ⥤ algebra T) (c : cone (D ⋙ T.forget)) (t : is_limit c)

/-- (Impl) The natural transformation used to define the new cone -/
@[simps] def γ : (D ⋙ T.forget ⋙ ↑T) ⟶ D ⋙ T.forget := { app := λ j, (D.obj j).a }

/-- (Impl) This new cone is used to construct the algebra structure -/
@[simps π_app] def new_cone : cone (D ⋙ forget T) :=
{ X := T.obj c.X,
  π := (functor.const_comp _ _ ↑T).inv ≫ whisker_right c.π T ≫ γ D }

/-- The algebra structure which will be the apex of the new limit cone for `D`. -/
@[simps] def cone_point : algebra T :=
{ A := c.X,
  a := t.lift (new_cone D c),
  unit' := t.hom_ext $ λ j,
  begin
    rw [category.assoc, t.fac, new_cone_π_app, ←T.η.naturality_assoc, functor.id_map,
      (D.obj j).unit],
    dsimp, simp -- See library note [dsimp, simp]
  end,
  assoc' := t.hom_ext $ λ j,
  begin
    rw [category.assoc, category.assoc, t.fac (new_cone D c), new_cone_π_app,
      ←functor.map_comp_assoc, t.fac (new_cone D c), new_cone_π_app, ←T.μ.naturality_assoc,
      (D.obj j).assoc, functor.map_comp, category.assoc],
    refl,
  end }

/-- (Impl) Construct the lifted cone in `algebra T` which will be limiting. -/
@[simps] def lifted_cone : cone D :=
{ X := cone_point D c t,
  π := { app := λ j, { f := c.π.app j },
         naturality' := λ X Y f, by { ext1, dsimp, erw c.w f, simp } } }

/-- (Impl) Prove that the lifted cone is limiting. -/
@[simps]
def lifted_cone_is_limit : is_limit (lifted_cone D c t) :=
{ lift := λ s,
  { f := t.lift ((forget T).map_cone s),
    h' := t.hom_ext $ λ j,
    begin
      dsimp,
      rw [category.assoc, category.assoc, t.fac, new_cone_π_app, ←functor.map_comp_assoc, t.fac,
        functor.map_cone_π_app],
      apply (s.π.app j).h,
    end },
  uniq' := λ s m J,
  begin
    ext1,
    apply t.hom_ext,
    intro j,
    simpa [t.fac ((forget T).map_cone s) j] using congr_arg algebra.hom.f (J j),
  end }

end forget_creates_limits

-- Theorem 5.6.5 from [Riehl][riehl2017]
/-- The forgetful functor from the Eilenberg-Moore category creates limits. -/
noncomputable
instance forget_creates_limits : creates_limits_of_size (forget T) :=
{ creates_limits_of_shape := λ J 𝒥, by exactI
  { creates_limit := λ D,
    creates_limit_of_reflects_iso (λ c t,
    { lifted_cone := forget_creates_limits.lifted_cone D c t,
      valid_lift := cones.ext (iso.refl _) (λ j, (id_comp _).symm),
      makes_limit := forget_creates_limits.lifted_cone_is_limit _ _ _ } ) } }

/-- `D ⋙ forget T` has a limit, then `D` has a limit. -/
lemma has_limit_of_comp_forget_has_limit (D : J ⥤ algebra T) [has_limit (D ⋙ forget T)] :
  has_limit D :=
has_limit_of_created D (forget T)

namespace forget_creates_colimits

-- Let's hide the implementation details in a namespace
variables {D : J ⥤ algebra T} (c : cocone (D ⋙ forget T)) (t : is_colimit c)

-- We have a diagram D of shape J in the category of algebras, and we assume that we are given a
-- colimit for its image D ⋙ forget T under the forgetful functor, say its apex is L.

-- We'll construct a colimiting coalgebra for D, whose carrier will also be L.
-- To do this, we must find a map TL ⟶ L. Since T preserves colimits, TL is also a colimit.
-- In particular, it is a colimit for the diagram `(D ⋙ forget T) ⋙ T`
-- so to construct a map TL ⟶ L it suffices to show that L is the apex of a cocone for this diagram.
-- In other words, we need a natural transformation from const L to `(D ⋙ forget T) ⋙ T`.
-- But we already know that L is the apex of a cocone for the diagram `D ⋙ forget T`, so it
-- suffices to give a natural transformation `((D ⋙ forget T) ⋙ T) ⟶ (D ⋙ forget T)`:

/--
(Impl)
The natural transformation given by the algebra structure maps, used to construct a cocone `c` with
apex `colimit (D ⋙ forget T)`.
 -/
@[simps] def γ : ((D ⋙ forget T) ⋙ ↑T) ⟶ (D ⋙ forget T) := { app := λ j, (D.obj j).a }

/--
(Impl)
A cocone for the diagram `(D ⋙ forget T) ⋙ T` found by composing the natural transformation `γ`
with the colimiting cocone for `D ⋙ forget T`.
-/
@[simps]
def new_cocone : cocone ((D ⋙ forget T) ⋙ ↑T) :=
{ X := c.X,
  ι := γ ≫ c.ι }

variables [preserves_colimit (D ⋙ forget T) (T : C ⥤ C)]

/--
(Impl)
Define the map `λ : TL ⟶ L`, which will serve as the structure of the coalgebra on `L`, and
we will show is the colimiting object. We use the cocone constructed by `c` and the fact that
`T` preserves colimits to produce this morphism.
-/
@[reducible]
def lambda : ((T : C ⥤ C).map_cocone c).X ⟶ c.X :=
(is_colimit_of_preserves _ t).desc (new_cocone c)

/-- (Impl) The key property defining the map `λ : TL ⟶ L`. -/
lemma commuting (j : J) :
(T : C ⥤ C).map (c.ι.app j) ≫ lambda c t = (D.obj j).a ≫ c.ι.app j :=
(is_colimit_of_preserves _ t).fac (new_cocone c) j

variables [preserves_colimit ((D ⋙ forget T) ⋙ ↑T) (T : C ⥤ C)]

/--
(Impl)
Construct the colimiting algebra from the map `λ : TL ⟶ L` given by `lambda`. We are required to
show it satisfies the two algebra laws, which follow from the algebra laws for the image of `D` and
our `commuting` lemma.
-/
@[simps] def cocone_point :
algebra T :=
{ A := c.X,
  a := lambda c t,
  unit' :=
  begin
    apply t.hom_ext,
    intro j,
    rw [(show c.ι.app j ≫ T.η.app c.X ≫ _ = T.η.app (D.obj j).A ≫ _ ≫ _,
                  from T.η.naturality_assoc _ _), commuting, algebra.unit_assoc (D.obj j)],
    dsimp, simp -- See library note [dsimp, simp]
  end,
  assoc' :=
  begin
    refine (is_colimit_of_preserves _ (is_colimit_of_preserves _ t)).hom_ext (λ j, _),
    rw [functor.map_cocone_ι_app, functor.map_cocone_ι_app,
      (show (T : C ⥤ C).map ((T : C ⥤ C).map _) ≫ _ ≫ _ = _, from T.μ.naturality_assoc _ _),
      ←functor.map_comp_assoc, commuting, functor.map_comp, category.assoc, commuting],
    apply (D.obj j).assoc_assoc _,
  end }

/-- (Impl) Construct the lifted cocone in `algebra T` which will be colimiting. -/
@[simps] def lifted_cocone : cocone D :=
{ X := cocone_point c t,
  ι := { app := λ j, { f := c.ι.app j, h' := commuting _ _ _ },
         naturality' := λ A B f, by { ext1, dsimp, rw [comp_id], apply c.w } } }

/-- (Impl) Prove that the lifted cocone is colimiting. -/
@[simps]
def lifted_cocone_is_colimit : is_colimit (lifted_cocone c t) :=
{ desc := λ s,
  { f := t.desc ((forget T).map_cocone s),
    h' := (is_colimit_of_preserves (T : C ⥤ C) t).hom_ext $ λ j,
    begin
      dsimp,
      rw [←functor.map_comp_assoc, ←category.assoc, t.fac, commuting, category.assoc, t.fac],
      apply algebra.hom.h,
    end },
  uniq' := λ s m J,
  by { ext1, apply t.hom_ext, intro j, simpa using congr_arg algebra.hom.f (J j) } }

end forget_creates_colimits

open forget_creates_colimits

-- TODO: the converse of this is true as well
/--
The forgetful functor from the Eilenberg-Moore category for a monad creates any colimit
which the monad itself preserves.
-/
noncomputable
instance forget_creates_colimit (D : J ⥤ algebra T)
  [preserves_colimit (D ⋙ forget T) (T : C ⥤ C)]
  [preserves_colimit ((D ⋙ forget T) ⋙ ↑T) (T : C ⥤ C)] :
  creates_colimit D (forget T) :=
creates_colimit_of_reflects_iso $ λ c t,
{ lifted_cocone :=
  { X := cocone_point c t,
    ι :=
    { app := λ j, { f := c.ι.app j, h' := commuting _ _ _ },
      naturality' := λ A B f, by { ext1, dsimp, erw [comp_id, c.w] } } },
  valid_lift := cocones.ext (iso.refl _) (by tidy),
  makes_colimit := lifted_cocone_is_colimit _ _ }

noncomputable
instance forget_creates_colimits_of_shape
  [preserves_colimits_of_shape J (T : C ⥤ C)] :
  creates_colimits_of_shape J (forget T) :=
{ creates_colimit := λ K, by apply_instance }

noncomputable
instance forget_creates_colimits
  [preserves_colimits_of_size.{v u} (T : C ⥤ C)] :
  creates_colimits_of_size.{v u} (forget T) :=
{ creates_colimits_of_shape := λ J 𝒥₁, by apply_instance }

/--
For `D : J ⥤ algebra T`, `D ⋙ forget T` has a colimit, then `D` has a colimit provided colimits
of shape `J` are preserved by `T`.
-/
lemma forget_creates_colimits_of_monad_preserves
  [preserves_colimits_of_shape J (T : C ⥤ C)] (D : J ⥤ algebra T) [has_colimit (D ⋙ forget T)] :
has_colimit D :=
has_colimit_of_created D (forget T)

end monad

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

instance comp_comparison_forget_has_limit
  (F : J ⥤ D) (R : D ⥤ C) [monadic_right_adjoint R] [has_limit (F ⋙ R)] :
  has_limit ((F ⋙ monad.comparison (adjunction.of_right_adjoint R)) ⋙ monad.forget _) :=
@has_limit_of_iso _ _ _ _ (F ⋙ R) _ _
  (iso_whisker_left F (monad.comparison_forget (adjunction.of_right_adjoint R)).symm)

instance comp_comparison_has_limit
  (F : J ⥤ D) (R : D ⥤ C) [monadic_right_adjoint R] [has_limit (F ⋙ R)] :
  has_limit (F ⋙ monad.comparison (adjunction.of_right_adjoint R)) :=
monad.has_limit_of_comp_forget_has_limit (F ⋙ monad.comparison (adjunction.of_right_adjoint R))

/-- Any monadic functor creates limits. -/
noncomputable
def monadic_creates_limits (R : D ⥤ C) [monadic_right_adjoint R] :
  creates_limits_of_size.{v u} R :=
creates_limits_of_nat_iso (monad.comparison_forget (adjunction.of_right_adjoint R))

/--
The forgetful functor from the Eilenberg-Moore category for a monad creates any colimit
which the monad itself preserves.
-/
noncomputable
def monadic_creates_colimit_of_preserves_colimit (R : D ⥤ C) (K : J ⥤ D)
  [monadic_right_adjoint R]
  [preserves_colimit (K ⋙ R) (left_adjoint R ⋙ R)]
  [preserves_colimit ((K ⋙ R) ⋙ left_adjoint R ⋙ R) (left_adjoint R ⋙ R)] :
  creates_colimit K R :=
begin
  apply creates_colimit_of_nat_iso (monad.comparison_forget (adjunction.of_right_adjoint R)),
  apply category_theory.comp_creates_colimit _ _,
  apply_instance,
  let i : ((K ⋙ monad.comparison (adjunction.of_right_adjoint R)) ⋙ monad.forget _) ≅ K ⋙ R :=
    functor.associator _ _ _ ≪≫
      iso_whisker_left K (monad.comparison_forget (adjunction.of_right_adjoint R)),
  apply category_theory.monad.forget_creates_colimit _,
  { dsimp,
    refine preserves_colimit_of_iso_diagram _ i.symm },
  { dsimp,
    refine preserves_colimit_of_iso_diagram _ (iso_whisker_right i (left_adjoint R ⋙ R)).symm },
end

/-- A monadic functor creates any colimits of shapes it preserves. -/
noncomputable
def monadic_creates_colimits_of_shape_of_preserves_colimits_of_shape (R : D ⥤ C)
  [monadic_right_adjoint R] [preserves_colimits_of_shape J R] : creates_colimits_of_shape J R :=
begin
  have : preserves_colimits_of_shape J (left_adjoint R ⋙ R),
  { apply category_theory.limits.comp_preserves_colimits_of_shape _ _,
    apply (adjunction.left_adjoint_preserves_colimits (adjunction.of_right_adjoint R)).1,
    apply_instance },
  exactI ⟨λ K, monadic_creates_colimit_of_preserves_colimit _ _⟩,
end

/-- A monadic functor creates colimits if it preserves colimits. -/
noncomputable
def monadic_creates_colimits_of_preserves_colimits (R : D ⥤ C) [monadic_right_adjoint R]
  [preserves_colimits_of_size.{v u} R] : creates_colimits_of_size.{v u} R :=
{ creates_colimits_of_shape := λ J 𝒥₁,
    by exactI monadic_creates_colimits_of_shape_of_preserves_colimits_of_shape _ }

section

lemma has_limit_of_reflective (F : J ⥤ D) (R : D ⥤ C) [has_limit (F ⋙ R)] [reflective R] :
  has_limit F :=
by { haveI := monadic_creates_limits.{v u} R, exact has_limit_of_created F R }

/-- If `C` has limits of shape `J` then any reflective subcategory has limits of shape `J`. -/
lemma has_limits_of_shape_of_reflective [has_limits_of_shape J C] (R : D ⥤ C) [reflective R] :
  has_limits_of_shape J D :=
{ has_limit := λ F, has_limit_of_reflective F R }

/-- If `C` has limits then any reflective subcategory has limits. -/
lemma has_limits_of_reflective (R : D ⥤ C) [has_limits_of_size.{v u} C] [reflective R] :
  has_limits_of_size.{v u} D :=
{ has_limits_of_shape := λ J 𝒥₁, by exactI has_limits_of_shape_of_reflective R }

/-- If `C` has colimits of shape `J` then any reflective subcategory has colimits of shape `J`. -/
lemma has_colimits_of_shape_of_reflective (R : D ⥤ C)
  [reflective R] [has_colimits_of_shape J C] : has_colimits_of_shape J D :=
{ has_colimit := λ F,
begin
  let c := (left_adjoint R).map_cocone (colimit.cocone (F ⋙ R)),
  let h := (adjunction.of_right_adjoint R).left_adjoint_preserves_colimits.1,
  letI := @h J _,
  let t : is_colimit c := is_colimit_of_preserves (left_adjoint R) (colimit.is_colimit _),
  apply has_colimit.mk ⟨_, (is_colimit.precompose_inv_equiv _ _).symm t⟩,
  apply (iso_whisker_left F (as_iso (adjunction.of_right_adjoint R).counit) : _) ≪≫ F.right_unitor,
end }

/-- If `C` has colimits then any reflective subcategory has colimits. -/
lemma has_colimits_of_reflective (R : D ⥤ C) [reflective R] [has_colimits_of_size.{v u} C] :
  has_colimits_of_size.{v u} D :=
{ has_colimits_of_shape := λ J 𝒥, by exactI has_colimits_of_shape_of_reflective R }

/--
The reflector always preserves terminal objects. Note this in general doesn't apply to any other
limit.
-/
noncomputable def left_adjoint_preserves_terminal_of_reflective (R : D ⥤ C) [reflective R] :
  preserves_limits_of_shape (discrete.{v} pempty) (left_adjoint R) :=
{ preserves_limit := λ K, let F := functor.empty.{v} D in
  begin
    apply preserves_limit_of_iso_diagram _ (functor.empty_ext (F ⋙ R) _),
    fsplit, intros c h, haveI : has_limit (F ⋙ R) := ⟨⟨⟨c,h⟩⟩⟩,
    haveI : has_limit F := has_limit_of_reflective F R,
    apply is_limit_change_empty_cone D (limit.is_limit F),
    apply (as_iso ((adjunction.of_right_adjoint R).counit.app _)).symm.trans,
    { apply (left_adjoint R).map_iso, letI := monadic_creates_limits.{v v} R,
      let := (category_theory.preserves_limit_of_creates_limit_and_has_limit F R).preserves,
      apply (this (limit.is_limit F)).cone_point_unique_up_to_iso h },
    apply_instance,
  end }

end
end category_theory


/-
Copyright (c) 2018 Simon Hudon. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Author: Simon Hudon
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.control.bifunctor
import Mathlib.control.traversable.basic
import Mathlib.PostPort

universes u l u_1 l_1

namespace Mathlib

/-!
# Bitraversable type class

Type class for traversing bifunctors. The concepts and laws are taken from
<https://hackage.haskell.org/package/base-4.12.0.0/docs/Data-Bitraversable.html>

Simple examples of `bitraversable` are `prod` and `sum`. A more elaborate example is
to define an a-list as:

```
def alist (key val : Type) := list (key × val)
```

Then we can use `f : key → io key'` and `g : val → io val'` to manipulate the `alist`'s key
and value respectively with `bitraverse f g : alist key val → io (alist key' val')`

## Main definitions
  * bitraversable - exposes the `bitraverse` function
  * is_lawful_bitraversable - laws similar to is_lawful_traversable

## Tags

traversable bitraversable iterator functor bifunctor applicative

-/

class bitraversable (t : Type u → Type u → Type u)
extends bifunctor t
where
  bitraverse : {m : Type u → Type u} → [_inst_1 : Applicative m] → {α α' β β' : Type u} → (α → m α') → (β → m β') → t α β → m (t α' β')

def bisequence {t : Type u_1 → Type u_1 → Type u_1} {m : Type u_1 → Type u_1} [bitraversable t] [Applicative m] {α : Type u_1} {β : Type u_1} : t (m α) (m β) → m (t α β) :=
  bitraverse id id

class is_lawful_bitraversable (t : Type u → Type u → Type u) [bitraversable t]
extends is_lawful_bifunctor t
where
  id_bitraverse : ∀ {α β : Type u} (x : t α β), bitraverse id.mk id.mk x = id.mk x
  comp_bitraverse : ∀ {F G : Type u → Type u} [_inst_1_1 : Applicative F] [_inst_2 : Applicative G] [_inst_3 : is_lawful_applicative F]
  [_inst_4 : is_lawful_applicative G] {α α' β β' γ γ' : Type u} (f : β → F γ) (f' : β' → F γ') (g : α → G β)
  (g' : α' → G β') (x : t α α'),
  bitraverse (functor.comp.mk ∘ Functor.map f ∘ g) (functor.comp.mk ∘ Functor.map f' ∘ g') x =
    functor.comp.mk (bitraverse f f' <$> bitraverse g g' x)
  bitraverse_eq_bimap_id : ∀ {α α' β β' : Type u} (f : α → β) (f' : α' → β') (x : t α α'),
  bitraverse (id.mk ∘ f) (id.mk ∘ f') x = id.mk (bimap f f' x)
  binaturality : ∀ {F G : Type u → Type u} [_inst_1_1 : Applicative F] [_inst_2 : Applicative G] [_inst_3 : is_lawful_applicative F]
  [_inst_4 : is_lawful_applicative G] (η : applicative_transformation F G) {α α' β β' : Type u} (f : α → F β)
  (f' : α' → F β') (x : t α α'),
  coe_fn η (t β β') (bitraverse f f' x) = bitraverse (coe_fn η β ∘ f) (coe_fn η β' ∘ f') x

theorem is_lawful_bitraversable.bitraverse_id_id {t : Type l_1 → Type l_1 → Type l_1} [bitraversable t] [c : is_lawful_bitraversable t] {α : Type l_1} {β : Type l_1} : bitraverse id.mk id.mk = id.mk :=
  funext fun (x : t α β) => id_bitraverse x

theorem is_lawful_bitraversable.bitraverse_comp {t : Type l_1 → Type l_1 → Type l_1} [bitraversable t] [c : is_lawful_bitraversable t] {F : Type l_1 → Type l_1} {G : Type l_1 → Type l_1} : ∀ [_inst_1_1 : Applicative F] [_inst_2 : Applicative G] [_inst_3 : is_lawful_applicative F]
  [_inst_4 : is_lawful_applicative G] {α α' β β' γ γ' : Type l_1} (f : β → F γ) (f' : β' → F γ') (g : α → G β)
  (g' : α' → G β'),
  bitraverse (functor.comp.mk ∘ Functor.map f ∘ g) (functor.comp.mk ∘ Functor.map f' ∘ g') =
    functor.comp.mk ∘ Functor.map (bitraverse f f') ∘ bitraverse g g' :=
  fun (_inst_1_1 : Applicative F) (_inst_2 : Applicative G) (_inst_3 : is_lawful_applicative F)
    (_inst_4 : is_lawful_applicative G) (α α' β β' γ γ' : Type l_1) (f : β → F γ) (f' : β' → F γ') (g : α → G β)
    (g' : α' → G β') => funext fun (x : t α α') => comp_bitraverse f f' g g' x

theorem is_lawful_bitraversable.bitraverse_eq_bimap_id' {t : Type l_1 → Type l_1 → Type l_1} [bitraversable t] [c : is_lawful_bitraversable t] {α : Type l_1} {α' : Type l_1} {β : Type l_1} {β' : Type l_1} (f : α → β) (f' : α' → β') : bitraverse (id.mk ∘ f) (id.mk ∘ f') = id.mk ∘ bimap f f' :=
  funext fun (x : t α α') => bitraverse_eq_bimap_id f f' x


/-
Copyright (c) 2023 Devon Tuma. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Devon Tuma
-/
import computational_monads.coercions.sub_spec

/-!
# Sub-Spec Instances for Common Sets of Oracles

This file defines `is_sub_spec` instances for common coercions.
The first is a coercion from `empty_spec` to any other `oracle_spec` (since there are no queries).
Another is a simple coercion from `coin_spec` to `uniform_selecting`,
by selecting the coin result from a uniform selection between `0` and `1`.

We also define a number of coercions involving append.
These instances allow an `oracle_spec` of the form `spec₁ ++ ... ++ spec₂`
to coerce to one of the form `spec'₁ ++ ... ++ spec'₂`, assuming that
the set of oracles in the first is a sub-sequence of the oracles in the second.
We also include associativity instances, so parenthisization of the sequence is irrelevant.

Note that this requires the ordering of oracles in each to match,
and so we generally adopt a standard ordering of `oracle_spec` for computations
in order to make this apply as often as possible. We specifically adopt the following convention:
  `{coin_oracle} ++ {uniform_selecting} ++ {random oracle} ++ {adversary oracles} ++ ...`,
where any of the individual parts may be ommited. The adversary oracles are for
things like a signing oracle in unforgeability experiments of a signature scheme.

The typelcasses are applied in an order defined by specific priorities:
1. Try applying the associativity instance to remove parenthesization.
2. If both the subspec and superspec are an append, try to independently coerce both sides.
3. Try to coerce the subspec to the left side of the superspec append.
4. Try to coerce the subspec to the right side of the superspec append.
5. Try appending a single oracle to the left side of the subspec.
6. Try appending a single oracle to the right side of the subspec.
7. Try coercing the subspec to itself.
This ordering is chosen to both give a generally applicable instance tree,
and avoid an infinite typeclass search whether or not an instance exists.
-/

variables {α β γ : Type}

namespace oracle_spec

open oracle_comp

section empty_spec

/-- Coerce a computation with no oracles to one with any potential set of oracles. -/
@[priority std.priority.default+101]
instance is_sub_spec_empty_spec (spec : oracle_spec) : is_sub_spec []ₒ spec :=
{ to_fun := λ i, empty.elim i,
  eval_dist_to_fun' := λ i, empty.elim i }

@[simp] lemma is_sub_spec_empty_spec_apply (spec : oracle_spec) (i : empty) (t : unit) :
  (oracle_spec.is_sub_spec_empty_spec spec).to_fun i t = return default := i.elim

end empty_spec

section coin_spec_uniform_selecting

/-- Coerce a coin flip into a uniform random selection of a `bool`.
Use uniform selection from the vector `[tt, ff]` to get constructiveness. -/
@[priority std.priority.default+100]
instance is_sub_spec_coin_spec_uniform_selecting : is_sub_spec coin_spec uniform_selecting :=
{ to_fun := λ i t, $ᵛ (tt ::ᵥ ff ::ᵥ vector.nil),
  eval_dist_to_fun' := λ i t, pmf.ext (λ x, by cases x;
    simp_rw [eval_dist_uniform_select_vector_apply, vector.to_list_cons,
      vector.to_list_nil, list.count_cons, list.count_nil, eq_self_iff_true, if_true, if_false,
      eval_dist_query_apply, card_range_coin_spec, nat.cast_one]) }

@[simp] lemma is_sub_spec_coin_uniform_selecting_apply (i t : unit) :
  (oracle_spec.is_sub_spec_coin_spec_uniform_selecting).to_fun i t =
    $ᵛ (tt ::ᵥ ff ::ᵥ vector.nil) := rfl

end coin_spec_uniform_selecting

/-- Coerce a computation to one with access to another oracle on the left,
forwarding the old queries to the left side of the combined set of oracles. -/
@[priority std.priority.default]
instance is_sub_spec_append_left (spec spec' : oracle_spec) : spec ⊂ₒ (spec' ++ spec) :=
{ to_fun := λ i t, @query (spec' ++ spec) (sum.inr i) t,
  eval_dist_to_fun' := λ i t, trans (eval_dist_query (sum.inr i) t) (eval_dist_query i t).symm }

/-- Coerce a computation to one with access to another oracle on the right,
forwarding the old queries to the left side of the combined set of oracles. -/
@[priority std.priority.default+1]
instance is_sub_spec_append_right (spec spec' : oracle_spec) : spec ⊂ₒ (spec ++ spec') :=
{ to_fun := λ i t, @query (spec ++ spec') (sum.inl i) t,
  eval_dist_to_fun' := λ i t, trans (eval_dist_query (sum.inl i) t) (eval_dist_query i t).symm }

lemma is_sub_spec_append_right_apply {spec spec' : oracle_spec} (i : spec.ι) (t : spec.domain i) :
  (oracle_spec.is_sub_spec_append_right spec spec').to_fun i t =
    @query (spec ++ spec') (sum.inl i) t := rfl

/-- Coerce an oracle and then append to the left. Already sort of exists,
  but the instance priorities don't work without explicitly having this. -/
@[priority std.priority.default+10]
instance is_sub_spec_append_left_of_is_sub_spec (spec sub_spec super_spec : oracle_spec)
  [h : is_sub_spec sub_spec super_spec] : is_sub_spec sub_spec (spec ++ super_spec) :=
{ to_fun := λ i t, ↑(h.to_fun i t),
  eval_dist_to_fun' := λ i t,by rw [eval_dist_coe_sub_spec, is_sub_spec.eval_dist_to_fun'] }

/-- Coerce an oracle and then append to the right. Already sort of exists,
  but the instance priorities don't work without explicitly having this. -/
@[priority std.priority.default+11]
instance is_sub_spec_append_right_of_is_sub_spec (spec sub_spec super_spec : oracle_spec)
  [h : is_sub_spec sub_spec super_spec] : is_sub_spec sub_spec (super_spec ++ spec) :=
{ to_fun := λ i t, ↑(h.to_fun i t),
  eval_dist_to_fun' := λ i t,by rw [eval_dist_coe_sub_spec, is_sub_spec.eval_dist_to_fun'] }

/-- Coerce the oracle on the right side of an existing set of appended oracles. -/
@[priority std.priority.default+20]
instance is_sub_spec_left_side_append (spec sub_spec super_spec : oracle_spec)
  [h : is_sub_spec sub_spec super_spec] : is_sub_spec (sub_spec ++ spec) (super_spec ++ spec) :=
{ to_fun := λ i, match i with
  | (sum.inl i) := λ t, (append.range_inl sub_spec spec i).symm.rec (h.to_fun i t)
  | (sum.inr i) := λ t, @query (super_spec ++ _) (sum.inr i) t
  end,
  eval_dist_to_fun' := λ i, match i with
  | (sum.inl i) := λ t, (eval_dist_coe_sub_spec _ _ (h.to_fun i t)).trans
      ((h.eval_dist_to_fun' i t).trans rfl)
  | (sum.inr i) := λ t, rfl
  end }

/-- Coerce the oracle on the right side of an existing set of appended oracles. -/
@[priority std.priority.default+21]
instance is_sub_spec_right_side_append (spec sub_spec super_spec : oracle_spec)
  [h : is_sub_spec sub_spec super_spec] : is_sub_spec (spec ++ sub_spec) (spec ++ super_spec) :=
{ to_fun := λ i, match i with
  | (sum.inl i) := λ t, @query (_ ++ super_spec) (sum.inl i) t
  | (sum.inr i) := λ t, (append.range_inr spec sub_spec i).symm.rec (h.to_fun i t)
  end,
  eval_dist_to_fun' := λ i, match i with
  | (sum.inl i) := λ t, rfl
  | (sum.inr i) := λ t, (eval_dist_coe_sub_spec _ _ (h.to_fun i t)).trans
      ((h.eval_dist_to_fun' i t).trans rfl)
  end }

/-- Coerce towards a standardized append ordering (matching the `infixl` declaration for `++`) -/
@[priority std.priority.default+30]
instance is_sub_spec_assoc (spec spec' spec'' : oracle_spec) :
  is_sub_spec (spec ++ (spec' ++ spec'')) (spec ++ spec' ++ spec'') :=
{ to_fun := λ i, match i with
  | (sum.inl i) := λ t, @query (spec ++ spec' ++ spec'') (sum.inl (sum.inl i)) t
  | (sum.inr (sum.inl i)) := λ t, @query (spec ++ spec' ++ spec'') (sum.inl (sum.inr i)) t
  | (sum.inr (sum.inr i)) := λ t, @query (spec ++ spec' ++ spec'') (sum.inr i) t
  end,
  eval_dist_to_fun' := λ i, match i with
  | (sum.inl i) := λ t, rfl
  | (sum.inr (sum.inl i)) := λ t, rfl
  | (sum.inr (sum.inr i)) := λ t, rfl
  end }

end oracle_spec

namespace oracle_spec

open oracle_comp

section examples

-- This set of examples serves as sort of a "unit test" for the coercions above
variables (spec spec' spec'' spec''' : oracle_spec) (coe_spec coe_spec' : oracle_spec)
  [coe_spec ⊂ₒ coe_spec']

-- coerce a single `coin_spec` and then append extra oracles
example (oa : oracle_comp coe_spec α) :
  oracle_comp (coe_spec' ++ spec' ++ spec'') α := ↑oa
example (oa : oracle_comp coe_spec α) :
  oracle_comp (spec ++ coe_spec' ++ spec') α := ↑oa
example (oa : oracle_comp coe_spec α) :
  oracle_comp (spec ++ spec' ++ coe_spec') α := ↑oa

-- coerce left side of append and then append on additional oracles
example (oa : oracle_comp (coe_spec ++ spec) α) :
  oracle_comp (coe_spec' ++ spec ++ spec') α := ↑oa
example (oa : oracle_comp (coe_spec ++ spec) α) :
  oracle_comp (coe_spec' ++ spec' ++ spec) α := ↑oa
example (oa : oracle_comp (coe_spec ++ spec) α) :
  oracle_comp (spec' ++ coe_spec' ++ spec) α := ↑oa

-- coerce right side of append and then append on additional oracles
example (oa : oracle_comp (spec ++ coe_spec) α) :
  oracle_comp (spec ++ coe_spec' ++ spec') α := ↑oa
example (oa : oracle_comp (spec ++ coe_spec) α) :
  oracle_comp (spec ++ spec' ++ coe_spec') α := ↑oa
example (oa : oracle_comp (spec ++ coe_spec) α) :
  oracle_comp (spec' ++ spec ++ coe_spec') α := ↑oa

-- coerce an inside part while also applying associativity
example (oa : oracle_comp (spec ++ (spec' ++ coe_spec)) α) :
  oracle_comp (spec ++ spec' ++ coe_spec') α := ↑oa
example (oa : oracle_comp (spec ++ (coe_spec ++ spec')) α) :
  oracle_comp (spec ++ coe_spec' ++ spec') α := ↑oa
example (oa : oracle_comp (coe_spec ++ (spec ++ spec')) α) :
  oracle_comp (coe_spec' ++ spec ++ spec') α := ↑oa

-- coerce two oracles up to four oracles
example (oa : oracle_comp (spec ++ spec') α) :
  oracle_comp (spec ++ spec' ++ spec'' ++ spec''') α := ↑oa
example (oa : oracle_comp (spec ++ spec'') α) :
  oracle_comp (spec ++ spec' ++ spec'' ++ spec''') α := ↑oa
example (oa : oracle_comp (spec ++ spec''') α) :
  oracle_comp (spec ++ spec' ++ spec'' ++ spec''') α := ↑oa
example (oa : oracle_comp (spec' ++ spec'') α) :
  oracle_comp (spec ++ spec' ++ spec'' ++ spec''') α := ↑oa
example (oa : oracle_comp (spec' ++ spec''') α) :
  oracle_comp (spec ++ spec' ++ spec'' ++ spec''') α := ↑oa
example (oa : oracle_comp (spec'' ++ spec''') α) :
  oracle_comp (spec ++ spec' ++ spec'' ++ spec''') α := ↑oa

-- coerce threee oracles up to four oracles
example (oa : oracle_comp (spec ++ spec' ++ spec'') α) :
  oracle_comp (spec ++ spec' ++ spec'' ++ spec''') α := ↑oa
example (oa : oracle_comp (spec ++ spec' ++ spec''') α) :
  oracle_comp (spec ++ spec' ++ spec'' ++ spec''') α := ↑oa
example (oa : oracle_comp (spec ++ spec'' ++ spec''') α) :
  oracle_comp (spec ++ spec' ++ spec'' ++ spec''') α := ↑oa
example (oa : oracle_comp (spec' ++ spec'' ++ spec''') α) :
  oracle_comp (spec ++ spec' ++ spec'' ++ spec''') α := ↑oa

-- four oracles with associativity and internal coercion
example (oa : oracle_comp ((coe_spec ++ spec') ++ (spec'' ++ spec''')) α) :
  oracle_comp (coe_spec' ++ spec' ++ spec'' ++ spec''') α := ↑oa
example (oa : oracle_comp ((spec ++ spec') ++ (coe_spec ++ spec''')) α) :
  oracle_comp (spec ++ spec' ++ coe_spec' ++ spec''') α := ↑oa
example (oa : oracle_comp ((spec ++ coe_spec) ++ (spec'' ++ spec''')) α) :
  oracle_comp (spec ++ coe_spec' ++ spec'' ++ spec''') α := ↑oa
example (oa : oracle_comp ((spec ++ spec') ++ (spec'' ++ coe_spec')) α) :
  oracle_comp (spec ++ spec' ++ spec'' ++ coe_spec') α := ↑oa

/-- coercion makes it possible to mix computations on individual oracles -/
example {spec : oracle_spec} : oracle_comp (uniform_selecting ++ spec) bool :=
do { n ←$[0..3141], b ← coin, if n ≤ 1618 ∧ b = tt then return ff else coin }

end examples

end oracle_spec


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

import algebraic_topology.simplicial_object
import category_theory.limits.shapes.images
import for_mathlib.simplex_category.factorisations
import category_theory.limits.shapes.finite_products
import algebraic_topology.simplicial_set
import category_theory.limits.preserves.shapes.products
import algebraic_topology.split_simplicial_object
import for_mathlib.inclusions_mono

noncomputable theory

open category_theory
open category_theory.category
open category_theory.limits
open opposite
open simplex_category
open_locale simplicial

universe u

variables {C : Type*} [category C]

class preserves_finite_coproducts {D : Type*} [category D] (F : C ⥤ D) :=
(preserves_colimits_of_shape :
  ∀ (J : Type) [fintype J], preserves_colimits_of_shape (discrete J) F)

class preserves_finite_products {D : Type*} [category D] (F : C ⥤ D) :=
(preserves_limits_of_shape :
  ∀ (J : Type) [fintype J], preserves_limits_of_shape (discrete J) F)

attribute [instance] preserves_finite_coproducts.preserves_colimits_of_shape
  preserves_finite_products.preserves_limits_of_shape

namespace simplicial_object

namespace splitting

def mk' (X : simplicial_object C) (N : Π (n : ℕ), C) (ι' : Π (n : ℕ), N n ⟶ X _[n])
  (h : ∀ (Δ : simplex_categoryᵒᵖ), is_colimit (cofan.mk (X.obj Δ) (λ (A : index_set Δ),
    ι' A.1.unop.len ≫ X.map A.e.op)))
  [has_finite_coproducts C] :
  splitting X :=
{ N := N,
  ι := ι',
  map_is_iso' := λ Δ,
    is_iso.of_iso (is_colimit.cocone_point_unique_up_to_iso (colimit.is_colimit _) (h Δ)), }

/-
/-- The index set which appears in the definition of split simplicial objects. -/
def index_set (Δ : simplex_categoryᵒᵖ) :=
Σ (Δ' : simplex_categoryᵒᵖ), { α : Δ.unop ⟶ Δ'.unop // epi α }
-/
namespace index_set
/--/
/-- The element in `splitting.index_set Δ` attached to an epimorphism `f : Δ ⟶ Δ'`. -/
@[simps]
def mk {Δ Δ' : simplex_category} (f : Δ ⟶ Δ') [epi f] : index_set (op Δ) :=
⟨op Δ', f, infer_instance⟩

variables {Δ' Δ : simplex_categoryᵒᵖ} (A : index_set Δ)

/-- The epimorphism in `simplex_category` associated to `A : splitting.index_set Δ` -/
def e := A.2.1

instance : epi A.e := A.2.2

lemma ext' : A = ⟨A.1, ⟨A.e, A.2.2⟩⟩ := by tidy

lemma ext (A₁ A₂ : index_set Δ) (h₁ : A₁.1 = A₂.1)
  (h₂ : A₁.e ≫ eq_to_hom (by rw h₁) = A₂.e) : A₁ = A₂ :=
begin
  rcases A₁ with ⟨Δ₁, ⟨α₁, hα₁⟩⟩,
  rcases A₂ with ⟨Δ₂, ⟨α₂, hα₂⟩⟩,
  simp only at h₁,
  subst h₁,
  simp only [eq_to_hom_refl, comp_id, index_set.e] at h₂,
  simp only [h₂],
end

instance : fintype (index_set Δ) :=
fintype.of_injective
  ((λ A, ⟨⟨A.1.unop.len, nat.lt_succ_iff.mpr
    (simplex_category.len_le_of_epi (infer_instance : epi A.e))⟩, A.e.to_order_hom⟩) :
    index_set Δ → (sigma (λ (k : fin (Δ.unop.len+1)), (fin (Δ.unop.len+1) → fin (k+1)))))
begin
  rintros ⟨Δ₁, α₁⟩ ⟨Δ₂, α₂⟩ h₁,
  induction Δ₁ using opposite.rec,
  induction Δ₂ using opposite.rec,
  simp only at h₁,
  have h₂ : Δ₁ = Δ₂ := by { ext1, simpa only [subtype.mk_eq_mk] using h₁.1, },
  subst h₂,
  refine ext _ _ rfl _,
  ext : 2,
  exact eq_of_heq h₁.2,
end
variable (Δ)

/-- The distinguished element in `splitting.index_set Δ` which corresponds to the
identity of `Δ`. -/
def id : index_set Δ := ⟨Δ, ⟨𝟙 _, by apply_instance,⟩⟩

instance : inhabited (index_set Δ) := ⟨id Δ⟩
-/

variables {Δ : simplex_categoryᵒᵖ} (A : index_set Δ)
/-
/-- The condition that an element `splitting.index_set Δ` is the distinguished
element `splitting.index_set.id Δ`. -/
@[simp]
def eq_id : Prop := A = id _

lemma eq_id_iff_eq : A.eq_id ↔ A.1 = Δ :=
begin
  split,
  { intro h,
    dsimp at h,
    rw h,
    refl, },
  { intro h,
    rcases A with ⟨Δ', ⟨f, hf⟩⟩,
    simp only at h,
    subst h,
    refine ext _ _ rfl _,
    { haveI := hf,
      simp only [eq_to_hom_refl, comp_id],
      exact simplex_category.eq_id_of_epi f, }, },
end

lemma eq_id_iff_len_eq : A.eq_id ↔ A.1.unop.len = Δ.unop.len :=
begin
  rw eq_id_iff_eq,
  split,
  { intro h,
    rw h, },
  { intro h,
    rw ← unop_inj_iff,
    ext,
    exact h, },
end

lemma eq_id_iff_len_le : A.eq_id ↔ Δ.unop.len ≤ A.1.unop.len :=
begin
  split,
  { intro h,
    rw eq_id_iff_len_eq at h,
    rw h, },
  { intro h,
    rw eq_id_iff_len_eq,
    refine le_antisymm (len_le_of_epi (infer_instance : epi A.e)) h, },
end

lemma eq_id_iff_mono : A.eq_id ↔ mono A.e :=
begin
  split,
  { intro h,
    dsimp at h,
    subst h,
    dsimp only [id, e],
    apply_instance, },
  { intro h,
    rw eq_id_iff_len_le,
    exact len_le_of_mono h, }
end-/

/-@[simps]
def epi_comp {Δ₁ Δ₂ : simplex_categoryᵒᵖ} (A : index_set Δ₁) (p : Δ₁ ⟶ Δ₂) [epi p.unop] :
  index_set Δ₂ := ⟨A.1, ⟨p.unop ≫ A.e, epi_comp _ _⟩⟩-/

end index_set

variables (N : ℕ → C) (Δ : simplex_categoryᵒᵖ)
  (X : simplicial_object C) (φ : Π n, N n ⟶ X _[n])

open simplex_category
/-
/-- Given a sequences of objects `N : ℕ → C` in a category `C`, this is
a family of objects indexed by the elements `A : splitting.index_set Δ`.
The `Δ`-simplices of a split simplicial objects shall identify to the
direct sum of objects in such a family. -/
@[simp, nolint unused_arguments]
def summand (A : index_set Δ) : C := N A.1.unop.len

variable [has_finite_coproducts C]

/-- The direct sum of the family `summand N Δ` -/
@[simp]
def sum := sigma_obj (summand N Δ)

variable {Δ}

/-- The inclusion of a summand in the direct sum. -/
@[simp]
def ι_sum (A : index_set Δ) : N A.1.unop.len ⟶ sum N Δ := sigma.ι _ A

variables {N}

/-- The canonical morphism `sum N Δ ⟶ X.obj Δ` attached to a sequence
of objects `N` and a sequence of morphisms `N n ⟶ X _[n]`. -/
@[simp]
def map (Δ : simplex_categoryᵒᵖ) : sum N Δ ⟶ X.obj Δ :=
sigma.desc (λ A, φ A.1.unop.len ≫ X.map A.e.op)
-/
end splitting

variable [has_finite_coproducts C]
/-
/-- A splitting of a simplicial object `X` consists of the datum of a sequence
of objects `N`, a sequence of morphisms `ι : N n ⟶ X _[n]` such that
for all `Δ : simplex_categoryhᵒᵖ`, the canonical map `splitting.map X ι Δ`
is an isomorphism. -/
@[nolint has_nonempty_instance]
structure splitting (X : simplicial_object C) :=
(N : ℕ → C) (ι : Π n, N n ⟶ X _[n])
(map_is_iso' : ∀ (Δ : simplex_categoryᵒᵖ), is_iso (splitting.map X ι Δ))

namespace splitting

variables {X Y : simplicial_object C} (s : splitting X)

instance map_is_iso (Δ : simplex_categoryᵒᵖ) : is_iso (splitting.map X s.ι Δ) :=
s.map_is_iso' Δ

/-- The isomorphism on simplices given by the axiom `splitting.map_is_iso'` -/
@[simps]
def iso (Δ : simplex_categoryᵒᵖ) : sum s.N Δ ≅ X.obj Δ :=
as_iso (splitting.map X s.ι Δ)

/-- Via the isomorphism `s.iso Δ`, this is the inclusion of a summand
in the direct sum decomposition given by the splitting `s : splitting X`. -/
def ι_summand {Δ : simplex_categoryᵒᵖ} (A : index_set Δ) :
  s.N A.1.unop.len ⟶ X.obj Δ :=
splitting.ι_sum s.N A ≫ (s.iso Δ).hom

@[reassoc]
lemma ι_summand_eq {Δ : simplex_categoryᵒᵖ} (A : index_set Δ) :
  s.ι_summand A = s.ι A.1.unop.len ≫ X.map A.e.op :=
begin
  dsimp only [ι_summand, iso.hom],
  erw [colimit.ι_desc, cofan.mk_ι_app],
end

lemma ι_summand_id (n : ℕ) : s.ι_summand (index_set.id (op [n])) = s.ι n :=
by { erw [ι_summand_eq, X.map_id, comp_id], refl, }

/-- As it is stated in `splitting.hom_ext`, a morphism `f : X ⟶ Y` from a split
simplicial object to any simplicial object is determined by its restrictions
`s.φ f n : s.N n ⟶ Y _[n]` to the distinguished summands in each degree `n`. -/
@[simp]
def φ (f : X ⟶ Y) (n : ℕ) : s.N n ⟶ Y _[n] := s.ι n ≫ f.app (op [n])

@[simp, reassoc]
lemma ι_summand_comp_app (f : X ⟶ Y) {Δ : simplex_categoryᵒᵖ} (A : index_set Δ) :
  s.ι_summand A ≫ f.app Δ = s.φ f A.1.unop.len ≫ Y.map A.e.op :=
by simp only [ι_summand_eq_assoc, φ, nat_trans.naturality, assoc]

lemma hom_ext' {Z : C} {Δ : simplex_categoryᵒᵖ} (f g : X.obj Δ ⟶ Z)
  (h : ∀ (A : index_set Δ), s.ι_summand A ≫ f = s.ι_summand A ≫ g) :
    f = g :=
begin
  rw ← cancel_epi (s.iso Δ).hom,
  ext A,
  discrete_cases,
  simpa only [ι_summand_eq, iso_hom, colimit.ι_desc_assoc, cofan.mk_ι_app, assoc] using h A,
end

lemma hom_ext (f g : X ⟶ Y) (h : ∀ n : ℕ, s.φ f n = s.φ g n) : f = g :=
begin
  ext Δ,
  apply s.hom_ext',
  intro A,
  induction Δ using opposite.rec,
  induction Δ using simplex_category.rec with n,
  dsimp,
  simp only [s.ι_summand_comp_app, h],
end

/-- The map `X.obj Δ ⟶ Z` obtained by providing a family of morphisms on all the
terms of decomposition given by a splitting `s : splitting X`  -/
def desc {Z : C} (Δ : simplex_categoryᵒᵖ)
  (F : Π (A : index_set Δ), s.N A.1.unop.len ⟶ Z) : X.obj Δ ⟶ Z :=
(s.iso Δ).inv ≫ sigma.desc F

@[simp, reassoc]
lemma ι_desc {Z : C} (Δ : simplex_categoryᵒᵖ)
  (F : Π (A : index_set Δ), s.N A.1.unop.len ⟶ Z) (A : index_set Δ) :
  s.ι_summand A ≫ s.desc Δ F = F A :=
begin
  dsimp only [ι_summand, desc],
  simp only [assoc, iso.hom_inv_id_assoc, ι_sum],
  erw [colimit.ι_desc, cofan.mk_ι_app],
end-/

namespace splitting

variables {X X' : simplicial_object C} (s : splitting X)

instance [mono_coprod C] {Δ : simplex_categoryᵒᵖ} (A : index_set Δ) : mono (s.ι_summand A) :=
by { dsimp only [ι_summand, ι_coprod], apply mono_comp, }

/-@[reassoc]
lemma ι_summand_epi_naturality {Δ₁ Δ₂ : simplex_categoryᵒᵖ} (A : index_set Δ₁)
  (p : Δ₁ ⟶ Δ₂) [epi p.unop] :
  s.ι_summand A ≫ X.map p = s.ι_summand (A.epi_comp p) :=
begin
  dsimp [ι_summand],
  erw [colimit.ι_desc, colimit.ι_desc, cofan.mk_ι_app, cofan.mk_ι_app],
  dsimp only [index_set.epi_comp, index_set.e],
  rw [op_comp, X.map_comp, assoc, quiver.hom.op_unop],
end-/

@[simps]
def whiskering {D : Type*} [category D] [has_finite_coproducts D]
  {X : simplicial_object C} (s : splitting X)
  (F : C ⥤ D) [preserves_finite_coproducts F] :
  splitting (((simplicial_object.whiskering _ _).obj F).obj X) :=
{ N := λ n, F.obj (s.N n),
  ι := λ n, F.map (s.ι n),
  map_is_iso' := λ Δ, begin
    let e := preserves_coproduct.iso F (splitting.summand s.N Δ),
    convert (infer_instance : is_iso (e.inv ≫ F.map (splitting.map X s.ι Δ))),
    simp only [map, simplicial_object.whiskering_obj_obj_map, preserves_coproduct.inv_hom,
      sigma_comparison_map_desc, functor.map_comp],
  end, }
/-
@[simps]
def of_iso (e : X ≅ X') :
  splitting X' :=
{ N := s.N,
  ι := λ n, s.ι n ≫ e.hom.app (op [n]),
  map_is_iso' := λ Δ, begin
    convert (infer_instance : is_iso ((s.iso Δ).hom ≫ e.hom.app Δ)),
    tidy,
  end, } .-/

end splitting

variable (C)

/-@[ext]
structure split := (X : simplicial_object C) (s : splitting X)-/

namespace split

variable {C}

/-@[simps]
def mk' {X : simplicial_object C} (s : splitting X) : split C := ⟨X, s⟩

structure hom (S₁ S₂ : split C) :=
(F : S₁.X ⟶ S₂.X)
(f : Π (n : ℕ), S₁.s.N n ⟶ S₂.s.N n)
(comm' : ∀ (n : ℕ), S₁.s.ι n ≫ F.app (op [n]) = f n ≫ S₂.s.ι n)

@[ext]
lemma hom.ext {S₁ S₂ : split C} (Φ₁ Φ₂ : hom S₁ S₂) (h : ∀ (n : ℕ), Φ₁.f n = Φ₂.f n) :
  Φ₁ = Φ₂ :=
begin
  rcases Φ₁ with ⟨F₁, f₁, c₁⟩,
  rcases Φ₂ with ⟨F₂, f₂, c₂⟩,
  have h : f₁ = f₂ := by { ext, apply h, },
  subst h,
  simp only [eq_self_iff_true, and_true],
  apply S₁.s.hom_ext,
  intro n,
  dsimp,
  rw [c₁, c₂],
end

restate_axiom hom.comm'
attribute [simp, reassoc] hom.comm-/

end split

/-instance : category (split C) :=
{ hom      := split.hom,
  id       := λ S, { F := 𝟙 _, f := λ n, 𝟙 _, comm' := by tidy, },
  comp     := λ S₁ S₂ S₃ Φ₁₂ Φ₂₃,
    { F := Φ₁₂.F ≫ Φ₂₃.F, f := λ n, Φ₁₂.f n ≫ Φ₂₃.f n, comm' := by tidy, }, }-/

variable {C}

namespace split

/-lemma congr_F {S₁ S₂ : split C} {Φ₁ Φ₂ : S₁ ⟶ S₂} (h : Φ₁ = Φ₂) : Φ₁.F = Φ₂.F := by rw h
lemma congr_f {S₁ S₂ : split C} {Φ₁ Φ₂ : S₁ ⟶ S₂} (h : Φ₁ = Φ₂) (n : ℕ) :
  Φ₁.f n = Φ₂.f n := by rw h

@[simp]
lemma id_F (S : split C) : (𝟙 S : S ⟶ S).F = 𝟙 (S.X) := rfl

@[simp]
lemma id_f (S : split C) (n : ℕ) : (𝟙 S : S ⟶ S).f n = 𝟙 (S.s.N n) := rfl

@[simp]
lemma comp_F {S₁ S₂ S₃ : split C} (Φ₁₂ : S₁ ⟶ S₂) (Φ₂₃ : S₂ ⟶ S₃) :
  (Φ₁₂ ≫ Φ₂₃).F = Φ₁₂.F ≫ Φ₂₃.F := rfl

@[simp]
lemma comp_f {S₁ S₂ S₃ : split C} (Φ₁₂ : S₁ ⟶ S₂) (Φ₂₃ : S₂ ⟶ S₃) (n : ℕ) :
  (Φ₁₂ ≫ Φ₂₃).f n = Φ₁₂.f n ≫ Φ₂₃.f n := rfl

@[simp, reassoc]
lemma ι_summand_naturality_symm {S₁ S₂ : split C} (Φ : S₁ ⟶ S₂)
  {Δ : simplex_categoryᵒᵖ} (A : splitting.index_set Δ) :
  S₁.s.ι_summand A ≫ Φ.F.app Δ = Φ.f A.1.unop.len ≫ S₂.s.ι_summand A :=
by rw [S₁.s.ι_summand_eq, S₂.s.ι_summand_eq, assoc, Φ.F.naturality, ← Φ.comm_assoc]
-/
@[simps]
def whiskering {D : Type*} [category D] [has_finite_coproducts D] (F : C ⥤ D)
  [preserves_finite_coproducts F] : split C ⥤ split D :=
{ obj := λ S, split.mk' (S.s.whiskering F),
  map := λ S₁ S₂ Φ,
  { F := ((simplicial_object.whiskering _ _).obj F).map Φ.F,
    f := λ n, F.map (Φ.f n),
    comm' := λ n, by { dsimp, simp only [← F.map_comp, Φ.comm], }, }, }

lemma hom.ext' {S₁ S₂ : split C} [mono_coprod C] (Φ₁ Φ₂ : S₁ ⟶ S₂) (h : Φ₁.F = Φ₂.F) :
  Φ₁ = Φ₂ :=
begin
  ext,
  rw [← cancel_mono (S₂.s.ι_summand (splitting.index_set.id (op [n]))), splitting.ι_summand_id,
    ← Φ₁.comm, ← Φ₂.comm, h],
end

variable (C)

/-@[simps]
def forget : split C ⥤ simplicial_object C :=
{ obj := λ S, S.X,
  map := λ S₁ S₂ Φ, Φ.F, }

instance [mono_in C] : faithful (forget C) := ⟨λ S₁ S₂ Φ₁ Φ₂, split.hom.ext' Φ₁ Φ₂⟩

@[simps]
def eval_N (n : ℕ) : split C ⥤ C :=
{ obj := λ S, S.s.N n,
  map := λ S₁ S₂ Φ, Φ.f n, }

@[simps]
def nat_trans_ι_summand {Δ : simplex_categoryᵒᵖ} (A : splitting.index_set Δ) :
  eval_N C A.1.unop.len ⟶ forget C ⋙ (evaluation simplex_categoryᵒᵖ C).obj Δ :=
{ app := λ S, S.s.ι_summand A,
  naturality' := λ S₁ S₂ Φ, (ι_summand_naturality_symm Φ A).symm, }-/

variable {C}

instance is_iso_f_of_is_iso {S₁ S₂ : split C} (Φ : S₁ ⟶ S₂) [is_iso Φ] (n : ℕ) : is_iso (Φ.f n) :=
by { change is_iso ((eval_N C n).map Φ), apply_instance, }

instance is_iso_F_of_is_iso {S₁ S₂ : split C} (Φ : S₁ ⟶ S₂) [is_iso Φ] : is_iso Φ.F :=
by { change is_iso ((forget C).map Φ), apply_instance, }

lemma is_iso_F_of_is_iso_f {S₁ S₂ : split C} (Φ : S₁ ⟶ S₂) [∀ (n : ℕ), is_iso (Φ.f n)] :
  is_iso Φ.F :=
begin
  haveI : ∀ (Δ : simplex_categoryᵒᵖ), is_iso (Φ.F.app Δ) := λ Δ,
    ⟨⟨S₂.s.desc Δ (λ A, inv (Φ.f A.1.unop.len) ≫ S₁.s.ι_summand A),
      ⟨S₁.s.hom_ext' _ _ (by tidy), S₂.s.hom_ext' _ _ (by tidy)⟩⟩⟩,
  apply nat_iso.is_iso_of_is_iso_app,
end

lemma is_iso_of_is_iso_f {S₁ S₂ : split C} (Φ : S₁ ⟶ S₂) [∀ (n : ℕ), is_iso (Φ.f n)] :
  is_iso Φ :=
⟨begin
  haveI : is_iso Φ.F := is_iso_F_of_is_iso_f Φ,
  let Ψ : S₂ ⟶ S₁ :=
  { F := inv Φ.F,
    f := λ n, inv (Φ.f n),
    comm' := λ n, by simp only [← cancel_epi (Φ.f n), ← Φ.comm_assoc,
      nat_iso.is_iso_inv_app, is_iso.hom_inv_id, comp_id, is_iso.hom_inv_id_assoc], },
  exact ⟨Ψ, by tidy⟩,
end⟩

lemma epi_F_of_epi_f {S₁ S₂ : split C} (Φ : S₁ ⟶ S₂) [∀ (n : ℕ), epi (Φ.f n)] :
  epi Φ.F :=
⟨λ Z g₁ g₂ h, begin
  apply S₂.s.hom_ext,
  intro n,
  dsimp,
  rw [← splitting.ι_summand_id, ← cancel_epi (Φ.f n)],
  erw [← ι_summand_naturality_symm_assoc Φ (splitting.index_set.id (op [n])),
    ← ι_summand_naturality_symm_assoc Φ (splitting.index_set.id (op [n]))],
  congr' 1,
  exact congr_app h (op [n]),
end⟩

lemma epi_of_epi_f {S₁ S₂ : split C} (Φ : S₁ ⟶ S₂) [∀ (n : ℕ), epi (Φ.f n)] :
  epi Φ :=
⟨λ S₃ G₁ G₂ h, by { ext n, simpa only [← cancel_epi (Φ.f n)] using congr_f h n, }⟩

/-lemma mono_F_of_mono_f {S₁ S₂ : split C} (Φ : S₁ ⟶ S₂) [∀ (n : ℕ), mono (Φ.f n)] :
  mono Φ.F := sorry

need that a finite coproduct of mono is mono
-/

end split

end simplicial_object

namespace sSet

class degreewise_finite (X : sSet.{u}) :=
(finite' : ∀ (Δ : simplex_categoryᵒᵖ), fintype (X.obj Δ))

restate_axiom degreewise_finite.finite'
attribute [instance] degreewise_finite.finite

@[simps]
def tensor (X : sSet.{u}) (Y : C)
  [∀ (Δ : simplex_categoryᵒᵖ), has_coproduct (λ (x : X.obj Δ), Y)] : simplicial_object C :=
{ obj := λ Δ, sigma_obj (λ (x : X.obj Δ), Y),
  map := λ Δ₁ Δ₂ θ, sigma.desc (λ x, sigma.ι (λ (y : X.obj Δ₂), Y) (X.map θ x)),
  map_id' := λ Δ, begin
    ext,
    discrete_cases,
    erw [colimit.ι_desc, cofan.mk_ι_app, comp_id, X.map_id],
    refl,
  end,
  map_comp' := λ Δ₁ Δ₂ Δ₃ θ θ', begin
    ext,
    discrete_cases,
    simp only [colimit.ι_desc, cofan.mk_ι_app, colimit.ι_desc_assoc],
    congr,
    rw [X.map_comp],
    refl,
  end, }

@[simp]
def tensor_ι {X : sSet.{u}} {Δ : simplex_categoryᵒᵖ} (x : X.obj Δ) (Y : C)
  [∀ (Δ : simplex_categoryᵒᵖ), has_coproduct (λ (x : X.obj Δ), Y)] :
  Y ⟶ (X.tensor Y).obj Δ :=
sigma.ι _ x

@[simp, reassoc]
lemma tensor_ι_comp_map {X : sSet.{u}} {Δ Δ' : simplex_categoryᵒᵖ} (x : X.obj Δ) (Y : C)
  [∀ (Δ : simplex_categoryᵒᵖ), has_coproduct (λ (x : X.obj Δ), Y)]
  (θ : Δ ⟶ Δ') :
  tensor_ι x Y ≫ (X.tensor Y).map θ = tensor_ι (X.map θ x) Y :=
begin
  dsimp,
  simp only [colimit.ι_desc, cofan.mk_ι_app],
end

lemma simplex_category.hom.fintype (Δ₁ Δ₂ : simplex_category) : fintype (Δ₁ ⟶ Δ₂) :=
begin
  refine fintype.of_injective (λ f, f.to_order_hom.to_fun) _,
  intros f₁ f₂ eq,
  ext : 2,
  exact eq,
end

instance (n : ℕ) : degreewise_finite Δ[n] := ⟨λ Δ, simplex_category.hom.fintype _ _⟩
instance (n : ℕ) : degreewise_finite ∂Δ[n] := ⟨λ Δ, by { dsimp [boundary], apply_instance, }⟩

instance has_coproduct_of_degreewise_finite
  (X : sSet.{u}) [degreewise_finite X] (Δ : simplex_categoryᵒᵖ) [has_finite_coproducts C]
  (Y : C) : has_coproduct (λ (x : X.obj Δ), Y) := infer_instance

def tensor_yoneda_adjunction [has_finite_coproducts C]
  (n : ℕ) (Y : C) (X : simplicial_object C) :
  (Δ[n].tensor Y ⟶ X) ≃ (Y ⟶ X.obj (op [n])) :=
{ to_fun := λ f, tensor_ι (by exact 𝟙 [n]) Y ≫ f.app (op [n]),
  inv_fun := λ g,
  { app := λ Δ, sigma.desc (λ s, g ≫ X.map (quiver.hom.op s)),
    naturality' := λ Δ₁ Δ₂ θ, begin
      ext s,
      discrete_cases,
      simpa only [tensor_map, colimit.ι_desc_assoc, cofan.mk_ι_app, colimit.ι_desc, assoc,
        ← X.map_comp],
  end, },
  left_inv := λ g, begin
    ext Δ s,
    discrete_cases,
    simp only [cofan.mk_ι_app, colimit.ι_desc, assoc,
      ← g.naturality, tensor_ι_comp_map_assoc],
    dsimp only [standard_simplex],
    simpa only [simplex_category.hom.comp, simplex_category.hom.id,
      simplex_category.small_category_id, yoneda_obj_map,
      quiver.hom.unop_op, simplex_category.small_category_comp,
      simplex_category.hom.to_order_hom_mk, order_hom.id_comp,
      simplex_category.hom.mk_to_order_hom],
  end,
  right_inv := λ f, begin
    dsimp only [tensor_ι],
    simp only [colimit.ι_desc, cofan.mk_ι_app],
    erw [op_id, X.map_id, comp_id],
  end, }

@[simps]
def tensor_map₁ {X₁ X₂ : sSet.{u}} (f : X₁ ⟶ X₂) (Y : C)
  [∀ (Δ : simplex_categoryᵒᵖ), has_coproduct (λ (x : X₁.obj Δ), Y)]
  [∀ (Δ : simplex_categoryᵒᵖ), has_coproduct (λ (x : X₂.obj Δ), Y)] :
  X₁.tensor Y ⟶ X₂.tensor Y :=
{ app := λ Δ, limits.sigma.desc (λ x, tensor_ι (f.app Δ x) Y),
  naturality' := λ Δ₁ Δ₂ φ, begin
    ext x,
    dsimp,
    simp only [colimit.ι_desc_assoc, cofan.mk_ι_app, colimit.ι_desc],
    congr,
    exact congr_fun (f.naturality φ) x.as,
  end}

end sSet


namespace Utils

def curry {α β γ : Type u} (f : α × β -> γ) : α -> β -> γ :=
  λ x y => f (x, y)

def uncurry {α β γ : Type u} (f : α -> β -> γ) : α × β -> γ :=
  λ (x, y) => f x y

/-- `lines path` returns a list of lines from the file `path`. -/
def lines (path : String) : IO (List String) := do
  let text <- IO.FS.readFile path
  let lines := String.split text (· = '\n')
  pure $ lines.filter (· ≠ "")

def windows (n : Nat) (l : List α) : List (List α) :=
  l |> List.enum
    |> List.map (λ (i, x) => (i / n, x))
    |> List.groupBy (λ (i, _) (j, _) => i = j)
    |> List.map (List.map Prod.snd)

def finCastUp {n : Nat} (f : Fin n) (m : Nat) (lt : n <= m) : Fin m :=
  Fin.mk
    (f.val)
    (by simp_arith exact Nat.le_trans f.isLt lt)

def enumFinAx {α : Type u} (l : List α) : List (Fin l.length × α) :=
  match l with
  | [] => []
  | hd :: tl => let tl' := enumFinAx tl
                let n := (hd :: tl).length
                let f : Fin n := Fin.ofNat tl'.length
                let fix : List (Fin n × α) :=
                  (List.map
                    (λ (x : Fin tl.length × α) =>
                      let p : tl.length <= n := by simp_arith
                      (finCastUp x.fst n p, x.snd))
                    tl')
                (f, hd) :: fix

def enumFin {α : Type u} (l : List α) : List (Fin l.length × α) :=
  -- l |> List.reverse |> enumFinAx |> List.reverse
  let l' := l.reverse |> enumFinAx

  -- cast the list to the right type
  let l'' : List (Fin l.length × α) := by
    have eq : l.length = l.reverse.length := by induction l <;> simp
    rw [eq]
    exact l'

  -- reverse the list again to get the right order
  l'' |> List.reverse

def List.mkLength {α} (default : α) (n : Nat) : List α :=
  match n with
  | 0 => []
  | n+1 => default :: (mkLength default n)

theorem List.mkLengthCorrect {α} {default : α} {n : Nat}
        : (List.mkLength default n).length = n := by
  induction n with
  | zero => simp [mkLength]
  | succ n IH => simp [mkLength] exact IH

-- example (α : Type u) (hd : α) (tl : List α)
--   : enumFin (hd :: tl) = (0, hd) :: enumFin tl := by simp

-- theorem enumFin_keeps_elems {α : Type u} (l : List α)
--         : List.map Prod.snd (enumFin l) = l := by
--   induction l with
--   | nil => simp [List.map]
--   | cons hd tl IH =>
--          simp [enumFin]
--          match (Eq.symm IH) with
--          | Eq.refl tl =>
--            rw [<- IH]
--            simp [List.reverse, enumFin, enumFinAx, List.reverseAux, List.map, *]

-- theorem enumFin_succ {α : Type u} (hd : α) (tl : List α)
--         : (enumFin (hd :: tl)).length = 1 + (enumFin tl).length := by
--   simp [enumFin]
--   rw [List.reverse_cons]

theorem enumFin_preserves_length {α : Type u} (l : List α) : l.length = (enumFin l).length := by
  induction l with
  | nil => simp [enumFin, List.length]
  | cons hd tl H =>
    simp
    sorry

def allGood? {α : Type u} : List (Option α) -> Option (List α)
  | [] => some []
  | some hd :: tl => (allGood? tl).map (λ tl => hd :: tl)
  | none :: _ => none

def transpose {α : Type u} (l : List (List α)) :=
  let hd' := allGood? $ l.map List.head?
  let tl' := allGood? $ l.map List.tail?
  match hd', tl' with
  | some hd, some tl =>
    have h : tl.length < l.length := by sorry
    hd :: (transpose tl)
  | _, _ => []
termination_by transpose l => l.length

end Utils


import algebra.camera.basic

universe u

@[simp] lemma option.none_eq_at {α : Type u} [ofe α] {n : ℕ} {a : option α} :
  none =[n] a ↔ a = none :=
begin
  split,
  { intro h,
    cases h,
    refl, },
  { rintro rfl,
    refl, },
end

@[simp] lemma option.eq_at_none {α : Type u} [ofe α] {n : ℕ} {a : option α} :
  a =[n] none ↔ a = none :=
begin
  rw ← option.none_eq_at,
  symmetry,
end

lemma option.some_eq_at {α : Type u} [ofe α] {n : ℕ} {a : α} {b : option α} :
  some a =[n] b → ∃ b', b = some b' :=
begin
  intro h,
  cases b,
  cases h,
  exact ⟨b, rfl⟩,
end

lemma option.eq_at_some {α : Type u} [ofe α] {n : ℕ} {a : option α} {b : α} :
  a =[n] some b → ∃ a', a = some a' :=
begin
  intro h,
  symmetry' at h,
  exact option.some_eq_at h,
end

@[simp] lemma option.some_eq_at_some {α : Type u} [ofe α] {n : ℕ} {a b : α} :
  some a =[n] some b ↔ a =[n] b :=
begin
  split,
  intro h, cases h, assumption,
  intro h, exact option.eq_at_prop.some h,
end

@[simp] lemma option.some_eq_at_some_mul_some {α : Type u} [camera α]
  {n : ℕ} {a b c : α} : some a =[n] some b * some c ↔ a =[n] b * c :=
by rw [some_mul_some, option.some_eq_at_some]

@[simp] lemma option.some_eq_at_some_mul_none {α : Type u} [camera α]
  {n : ℕ} {a b : α} : some a =[n] some b * none ↔ a =[n] b :=
by rw [mul_none, option.some_eq_at_some]

@[simp] lemma option.some_eq_at_none_mul_some {α : Type u} [camera α]
  {n : ℕ} {a b : α} : some a =[n] none * some b ↔ a =[n] b :=
by rw [none_mul, option.some_eq_at_some]

lemma option.map_nonexpansive {α β : Type u} [ofe α] [ofe β] (f : α → β) (hf : is_nonexpansive f) :
  is_nonexpansive (option.map f) :=
begin
  intros n a b h,
  cases h,
  { refine option.eq_at_prop.some _,
    refine hf _, assumption, },
  { refl, },
end

lemma option.map_eq_at_map {α β γ : Type u} [ofe α] [ofe β] [ofe γ] {n : ℕ}
  {f : α → β} {a b : option α} :
  is_nonexpansive f → a =[n] b → f <$> a =[n] f <$> b:=
begin
  intros hf hac,
  cases a,
  simpa only [option.map_eq_map, option.map_none', option.none_eq_at, option.map_eq_none'] using hac,
  cases b,
  cases hac,
  simp only [option.map_eq_map, option.map_some', option.some_eq_at_some] at hac ⊢,
  exact hf hac,
end

lemma option.seq_eq_at_seq {α β γ : Type u} [ofe α] [ofe β] [ofe γ] {n : ℕ}
  {f : α → β → γ} {a b : option α} {c d : option β} :
  is_nonexpansive (function.uncurry f) →
  a =[n] b → c =[n] d → f <$> a <*> c =[n] f <$> b <*> d :=
begin
  intros hf hac hbd,
  cases a,
  { rw option.none_eq_at at hac,
    rw hac,
    refl, },
  cases b,
  { cases hac, },
  cases c,
  { rw option.none_eq_at at hbd,
    rw hbd,
    refl, },
  cases d,
  { cases hbd, },
  simp only [option.map_eq_map, option.map_some', option.seq_some, option.some_eq_at_some],
  rw option.some_eq_at_some at hac hbd,
  exact hf.uncurry_apply_eq_at hac hbd,
end

@[simp] lemma option.not_none_is_some {α : Type*} : (none : option α).is_some ↔ false :=
by finish

@[simp] lemma option.some_is_some {α : Type*} {a : α} : (some a).is_some :=
by solve_by_elim

@[simp] lemma option.not_some_seq_none_is_some {α β : Type*} {f : α → β} :
  (some f <*> none).is_some ↔ false :=
by finish

@[simp] lemma option.not_none_seq_some_is_some {α β : Type*} {a : α} :
  ((none : option (α → β)) <*> some a).is_some ↔ false :=
by finish

@[simp] lemma option.not_none_seq_none_is_some {α β : Type*} :
  ((none : option (α → β)) <*> none).is_some ↔ false :=
by finish

@[simp] lemma option.map_is_some_iff {α β : Type*} {f : α → β} {a : option α} :
  (f <$> a).is_some ↔ a.is_some :=
by cases a; refl

@[simp] lemma option.seq_is_some_iff {α β : Type*} {f : option (α → β)} {a : option α} :
  (f <*> a).is_some ↔ f.is_some ∧ a.is_some :=
begin
  cases f; cases a;
  simp only [option.not_none_is_some, option.some_is_some, option.seq_some,
    option.not_some_seq_none_is_some, option.not_none_seq_some_is_some,
    option.not_none_seq_none_is_some, and_self, false_and, and_false],
end

def option.extend {α : Type u} [camera α] (n : ℕ) :
  Π {a b₁ b₂ : option α} (h₁ : ∀ a', a = some a' → ✓[n] a')
    (h₂ : a =[n] (b₁ * b₂)), option α × option α
| (some a) (some b₁) (some b₂) h₁ h₂ :=
    (some (extend (h₁ a rfl) (option.some_eq_at_some_mul_some.mp h₂)).1,
     some (extend (h₁ a rfl) (option.some_eq_at_some_mul_some.mp h₂)).2)
| (some a) (some b₁) none h₁ h₂ := (some a, none)
| (some a) none (some b₂) h₁ h₂ := (none, some a)
| _ _ _ _ _ := (none, none)

private lemma option.camera.mul_is_nonexpansive {α : Type u} [camera α] :
  is_nonexpansive (function.uncurry ((*) : option α → option α → option α)) :=
begin
  rintros n ⟨a₁, a₂⟩ ⟨b₁, b₂⟩ ⟨h₁, h₂⟩,
  cases h₁,
  { cases h₂,
    { simp only [function.uncurry_apply_pair, some_mul_some,
        option.some_eq_at_some],
      refine camera.mul_eq_at _ _; assumption, },
    simp only [function.uncurry_apply_pair, mul_none,
      option.some_eq_at_some],
    assumption, },
  { cases h₂,
    { simp only [function.uncurry_apply_pair, none_mul,
        option.some_eq_at_some],
      assumption, },
    { refl, }, },
end

private lemma option.camera.core_mul_self {α : Type u} [camera α]
  (a : option α) {ca : option α} : some (option.elim none (λ a, core a) a) = some ca →
    ca * a = a :=
begin
  intro h,
  rw option.some_inj at h,
  rw ← h,
  cases a,
  { refl, },
  { simp only [option.elim],
    have := camera.core_mul_self a,
    revert this,
    induction core a,
    { intro h, refl, },
    { intro h,
      rw some_mul_some,
      rw h rfl, }, },
end

private lemma option.camera.core_core {α : Type u} [camera α]
  (a : option α) {ca : option α} : some (option.elim none (λ a, core a) a) = some ca →
    some (option.elim none (λ a, core a) ca) = some ca :=
begin
  intro h,
  rw option.some_inj at h ⊢,
  cases a,
  { cases h,
    refl, },
  cases ca,
  { simp only [option.elim] at h,
    simp_rw h,
    refl, },
  simp only [option.elim] at h ⊢,
  exact camera.core_core a h,
end

private lemma option.camera.core_mono_some {α : Type u} [camera α]
  (a b : option α) {ca : option α} : some (option.elim none (λ a, core a) a) = some ca → a ≼ b →
    ∃ cb : option α, some (option.elim none (λ a, core a) b) = some cb :=
begin
  intros h₁ h₂,
  simp_rw exists_eq',
end

private lemma option.camera.core_mono {α : Type u} [camera α]
  (a b : option α) {ca : option α} : some (option.elim none (λ a, core a) a) = some ca →
    a ≼ b → some (option.elim none (λ a, core a) a) ≼ some (option.elim none (λ a, core a) b) :=
begin
  intros h₁ h₁,
  cases a,
  { refine ⟨some (option.elim none (λ a, core a) b), _⟩,
    simp only [option.elim, some_mul_some, none_mul], },
  obtain ⟨c, hc⟩ := h₁,
  rw ← hc,
  cases c,
  { rw mul_none at hc,
    refine ⟨none, _⟩,
    rw [mul_none, mul_none], },
  simp only [option.elim] at h₁,
  cases ca,
  { simp only [option.elim, some_mul_some],
    rw h₁,
    refine ⟨some (core (a * c)), _⟩,
    simp only [some_mul_some, none_mul], },
  obtain ⟨d, hd⟩ := camera.core_mono a (a * c) h₁ ⟨c, rfl⟩,
  refine ⟨some d, _⟩,
  simp only [option.elim, some_mul_some],
  exact hd,
end

private lemma option.camera.extend_mul_eq {α : Type u} [camera α] (n : ℕ)
  (a b₁ b₂ : option α) (ha : ∀ b, a = some b → ✓[n] b) (hb : a =[n] b₁ * b₂) :
  a = (option.extend n ha hb).1 * (option.extend n ha hb).2 :=
begin
  cases a,
  { simp only [option.none_eq_at] at hb,
    cases b₁,
    { rw none_mul at hb,
      cases hb,
      unfold option.extend,
      refl, },
    { cases b₂; cases hb, }, },
  cases b₁,
  { rw none_mul at hb,
    obtain ⟨b₂, rfl⟩ := option.some_eq_at hb,
    unfold option.extend,
    rw none_mul, },
  cases b₂,
  { rw mul_none at hb,
    unfold option.extend,
    rw mul_none, },
  unfold option.extend,
  rw some_mul_some,
  simp only [some_mul_some, option.some_eq_at_some] at hb,
  rw ← camera.extend_mul_eq (ha a rfl) hb,
end

private lemma option.camera.extend_eq_at_left {α : Type u} [camera α] (n : ℕ)
  (a b₁ b₂ : option α) (ha : ∀ b, a = some b → ✓[n] b) (hb : a =[n] b₁ * b₂) :
  (option.extend n ha hb).1 =[n] b₁ :=
begin
  cases b₁,
  { rw none_mul at hb,
    cases b₂,
    { rw option.eq_at_none at hb,
      cases hb,
      refl, },
    obtain ⟨a, rfl⟩ := option.some_eq_at (ofe.eq_at_symmetric n hb),
    refl, },
  cases b₂,
  { rw mul_none at hb,
    obtain ⟨a, rfl⟩ := option.some_eq_at (ofe.eq_at_symmetric n hb),
    exact hb, },
  rw [some_mul_some, eq_at_symm_iff] at hb,
  obtain ⟨a, rfl⟩ := option.some_eq_at hb,
  unfold option.extend,
  rw option.some_eq_at_some,
  exact camera.extend_eq_at_left _ _,
end

private lemma option.camera.extend_eq_at_right {α : Type u} [camera α] (n : ℕ)
  (a b₁ b₂ : option α) (ha : ∀ b, a = some b → ✓[n] b) (hb : a =[n] b₁ * b₂) :
  (option.extend n ha hb).2 =[n] b₂ :=
begin
  cases b₁,
  { rw none_mul at hb,
    cases b₂,
    { rw option.eq_at_none at hb,
      cases hb,
      refl, },
    obtain ⟨a, rfl⟩ := option.some_eq_at (ofe.eq_at_symmetric n hb),
    exact hb, },
  cases b₂,
  { rw mul_none at hb,
    obtain ⟨a, rfl⟩ := option.some_eq_at (ofe.eq_at_symmetric n hb),
    refl, },
  rw [some_mul_some, eq_at_symm_iff] at hb,
  obtain ⟨a, rfl⟩ := option.some_eq_at hb,
  unfold option.extend,
  rw option.some_eq_at_some,
  exact camera.extend_eq_at_right _ _,
end

instance option.camera {α : Type u} [camera α] : camera (option α) := {
  validn := ⟨λ a, ⟨λ n, ∀ b, a = some b → ✓[n] b,
    λ m n hmn h b hb, (camera.validn b).mono hmn (h b hb)⟩,
    begin
      intros n a b h m hmn,
      simp only [option.mem_def, sprop.coe_fn_mk],
      split; rintros ha c rfl,
      { obtain ⟨d, rfl⟩ := option.eq_at_some h,
        rw option.some_eq_at_some at h,
        exact camera.validn_of_eq_at (eq_at_mono hmn h) (ha d rfl), },
      { obtain ⟨d, rfl⟩ := option.some_eq_at h,
        rw option.some_eq_at_some at h,
        exact camera.validn_of_eq_at
          (eq_at_mono hmn (eq_at_symmetric n h)) (ha d rfl), },
    end⟩,
  core := ⟨λ a, some (option.elim none (λ a, core a) a), begin
    intros n a b hab,
    cases hab,
    { simp only [option.elim, option.some_eq_at_some],
      refine nonexpansive core _,
      assumption, },
    { refl, },
  end⟩,
  extend := option.extend,
  mul_is_nonexpansive := option.camera.mul_is_nonexpansive,
  core_mul_self := option.camera.core_mul_self,
  core_core := option.camera.core_core,
  core_mono_some := option.camera.core_mono_some,
  core_mono := option.camera.core_mono,
  validn_mul := begin
    intros a b n h,
    cases a,
    { simp only [is_empty.forall_iff, implies_true_iff, nonexpansive_fun.coe_fn_mk], },
    cases b,
    { simpa only [sprop.coe_fn_mk, forall_eq', mul_none, nonexpansive_fun.coe_fn_mk] using h, },
    simp only [sprop.coe_fn_mk, forall_eq', nonexpansive_fun.coe_fn_mk, some_mul_some] at h ⊢,
    exact camera.validn_mul a b n h,
  end,
  extend_mul_eq := option.camera.extend_mul_eq,
  extend_eq_at_left := option.camera.extend_eq_at_left,
  extend_eq_at_right := option.camera.extend_eq_at_right,
  ..option.ofe,
  ..option.comm_semigroup,
}


import Structure.Generic.Axioms

import mathlib4_experiments.CoreExt
import mathlib4_experiments.Data.Equiv.Basic

open GeneralizedRelation

set_option autoBoundImplicitLocal false
--set_option pp.universes true

universes u v w

instance unitHasInstances : HasInstances Unit := ⟨λ _ => True⟩

def unit : Universe.{0} := ⟨Unit⟩

namespace unit

  instance hasExternalFunctors (U : Universe.{u}) : HasExternalFunctors U unit := ⟨λ _ => PUnit.{u}⟩

  @[reducible] def unitFunctor {U : Universe.{u}} (α : U) (β : unit) : α ⟶' β :=
  ⟨Function.const ⌈α⌉ trivial, ⟨⟩⟩

  @[simp] theorem unitFunctorIsUnique {U : Universe.{u}} {α : U} {β : unit} (F : α ⟶' β) :
    F = unitFunctor α β := match F with
  | ⟨_, _⟩ => by simp

  def funEquiv (α β : unit) : True ≃ (α ⟶' β) :=
  { toFun    := λ _ => unitFunctor α β,
    invFun   := λ _ => trivial,
    leftInv  := λ _ => by simp,
    rightInv := λ _ => by simp }

  instance hasInternalFunctors : HasInternalFunctors unit :=
  { Fun      := λ _ _ => ⟨⟩,
    funEquiv := funEquiv }

  instance hasIdFun : HasIdFun unit := ⟨λ _ => ⟨⟩⟩
  instance hasConstFun (U : Universe.{u}) : HasConstFun U unit := ⟨λ _ _ _ => ⟨⟩⟩
  instance hasCompFun (U : Universe.{u}) (V : Universe.{v}) [HasExternalFunctors U V] : HasCompFun U V unit :=
  ⟨λ _ _ => ⟨⟩⟩

  instance hasLinearFunOp : HasLinearFunOp unit :=
  { appIsFun        := λ _ _   => ⟨⟩,
    appFunIsFun     := λ _ _   => ⟨⟩,
    compFunIsFun    := λ _ _   => ⟨⟩,
    compFunFunIsFun := λ _ _ _ => ⟨⟩ }

  instance hasAffineFunOp : HasAffineFunOp unit :=
  { constFunIsFun := λ _ _ => ⟨⟩ }

  instance hasFullFunOp : HasFullFunOp unit :=
  { dupIsFun    := λ _   => ⟨⟩,
    dupFunIsFun := λ _ _ => ⟨⟩ }

  instance hasFunOp : HasFunOp unit := ⟨⟩

  instance hasExternalEquivalences : HasExternalEquivalences unit unit := ⟨λ _ _ => True⟩

  @[reducible] def unitEquivalence (α : unit) (β : unit) : α ⟷' β :=
  ⟨unitFunctor α β, unitFunctor β α, trivial⟩

  @[simp] theorem unitEquivalenceIsUnique {α : unit} {β : unit} (E : α ⟷' β) :
    E = unitEquivalence α β := match E with
  | ⟨_, _, _⟩ => by simp; exact HEq.rfl

  def equivEquiv (α β : unit) : True ≃ (α ⟷' β) :=
  { toFun    := λ _ => unitEquivalence α β,
    invFun   := λ _ => trivial,
    leftInv  := λ _ => by simp,
    rightInv := λ _ => by simp }

  instance hasInternalEquivalences : HasInternalEquivalences unit :=
  { Equiv                := λ _ _ => ⟨⟩,
    equivEquiv           := equivEquiv,
    equivElimToFunIsFun  := λ _ _ => ⟨⟩,
    equivElimInvFunIsFun := λ _ _ => ⟨⟩ }

  instance hasIdEquiv   : HasIdEquiv   unit           := ⟨λ _   => trivial⟩
  instance hasCompEquiv : HasCompEquiv unit unit unit := ⟨λ _ _ => trivial⟩
  instance hasInvEquiv  : HasInvEquiv  unit unit      := ⟨λ _   => trivial⟩

  instance hasEquivOp : HasEquivOp unit :=
  { compEquivIsFun    := λ _ _   => ⟨⟩,
    compEquivFunIsFun := λ _ _ _ => ⟨⟩,
    invEquivIsFun     := λ _ _   => ⟨⟩,
    invEquivIsEquiv   := λ _ _   => trivial }

  @[reducible] def unitProduct (α : unit) (β : unit) : α ⊓' β :=
  ⟨⟨⟩, ⟨⟩⟩

  @[simp] theorem unitProductIsUnique {α : unit} {β : unit} (P : α ⊓' β) :
    P = unitProduct α β := match P with
  | ⟨_, _⟩ => rfl

  def prodEquiv (α β : unit) : True ≃ (α ⊓' β) :=
  { toFun    := λ _ => unitProduct α β,
    invFun   := λ _ => ⟨⟩,
    leftInv  := λ _ => by simp,
    rightInv := λ _ => by simp }

  instance hasInternalProducts : HasInternalProducts unit :=
  { Prod             := λ _ _ => ⟨⟩,
    prodEquiv        := prodEquiv,
    prodIntroIsFun   := λ _ _ => ⟨⟩,
    prodElimFstIsFun := λ _ _ => ⟨⟩,
    prodElimSndIsFun := λ _ _ => ⟨⟩ }

  instance hasUnitType : HasUnitType unit :=
  { Unit           := ⟨⟩,
    unit           := trivial,
    unitIntroIsFun := λ _ => ⟨⟩ }

  def Rel (α : Sort u) : GeneralizedRelation α unit := λ _ _ => ⟨⟩

  instance Rel.isEquivalence (α : Sort u) : IsEquivalence (Rel α) :=
  { refl  := λ _ => trivial,
    trans := trivial,
    symm  := trivial }

  class HasUnitEquivalences (U : Universe.{u}) where
  (Equiv (α : U)              : GeneralizedRelation ⌈α⌉ unit)
  [equivIsEquivalence (α : U) : IsEquivalence (Equiv α)]

  instance hasUnitInstanceEquivalences (U : Universe.{u}) [HasUnitEquivalences U] :
    HasInstanceEquivalences U :=
  ⟨unit, λ α => unit.Rel ⌈α⌉⟩

  instance hasUnitEquivalence : HasUnitEquivalences unit := ⟨λ _ => unit.Rel True⟩

  instance hasEquivCongr : HasEquivCongr unit :=
  { equivCongrArg := λ _ => unitFunctor (U := unit) ⟨⟩ ⟨⟩,
    equivCongrFun := λ _ => unitFunctor (U := unit) ⟨⟩ ⟨⟩ }

  instance hasNaturalEquivalences : HasNaturalEquivalences unit :=
  { equivHasInstEquivs := hasUnitInstanceEquivalences unit,
    isNat              := λ _ _ _ _ => trivial }

  section Morphisms

    variable {α : Sort u} {V : Universe.{v}} [HasInternalFunctors V] [HasUnitEquivalences V] (R : GeneralizedRelation α V)

    variable [HasLinearFunOp V] [HasTrans R]

    instance isCompositionRelation : IsCompositionRelation R :=
    { assoc := trivial }

    variable [HasRefl R]

    instance isMorphismRelation [IsPreorder R] : IsMorphismRelation R :=
    { leftId  := trivial,
      rightId := trivial }

    variable [HasSubLinearFunOp V] [HasNonLinearFunOp V] [HasInternalEquivalences V] [HasSymm R]

    instance isIsomorphismRelation [IsEquivalence R] : IsIsomorphismRelation R :=
    { leftInv  := trivial,
      rightInv := trivial }

  end Morphisms

  section Functors

    variable {α : Sort u} {V : Universe.{v}} {W : Universe.{w}}
             [HasInternalFunctors V] [HasInternalEquivalences V] [HasInternalFunctors W] [HasInternalEquivalences W]
             [HasUnitEquivalences W] [HasExternalFunctors V W]
             (R : GeneralizedRelation α V) (S : GeneralizedRelation α W)
             [IsEquivalence R] [IsEquivalence S]
             (F : BaseFunctor R S)

    instance isReflFunctor  : IsReflFunctor  R S F := ⟨λ _   => trivial⟩
    instance isSymmFunctor  : IsSymmFunctor  R S F := ⟨λ _   => trivial⟩
    instance isTransFunctor : IsTransFunctor R S F := ⟨λ _ _ => trivial⟩

    instance isPreorderFunctor    : IsPreorderFunctor    R S F := ⟨⟩
    instance isEquivalenceFunctor : IsEquivalenceFunctor R S F := ⟨⟩

  end Functors

end unit

def sort : Universe.{u} := ⟨Sort u⟩
@[reducible] def prop := sort.{0}
@[reducible] def type := sort.{1}

namespace sort

  instance hasExternalFunctors (U : Universe.{u}) : HasExternalFunctors U sort.{v} := ⟨λ _ => PUnit.{max u v}⟩

  @[reducible] def toBundledFunctor {U : Universe.{u}} {α : U} {β : sort.{v}} (f : α → β) : α ⟶' β := ⟨f, ⟨⟩⟩

  theorem toFromBundledFunctor {U : Universe.{u}} {α : U} {β : sort.{v}} (F : α ⟶' β) :
    toBundledFunctor F.f = F := match F with
  | ⟨_, _⟩ => by simp

  def funEquiv (α β : sort.{u}) : (α → β) ≃ (α ⟶' β) :=
  { toFun    := λ f => toBundledFunctor f,
    invFun   := λ F => F.f,
    leftInv  := λ f => rfl,
    rightInv := λ F => toFromBundledFunctor F }

  instance hasInternalFunctors : HasInternalFunctors sort.{u} :=
  { Fun      := λ α β => α → β,
    funEquiv := funEquiv }

  instance hasIdFun : HasIdFun sort.{u} := ⟨λ _ => ⟨⟩⟩
  instance hasConstFun (U : Universe.{u}) : HasConstFun U sort.{v} := ⟨λ _ _ _ => ⟨⟩⟩
  instance hasCompFun (U : Universe.{u}) (V : Universe.{v}) [HasExternalFunctors U V] : HasCompFun U V sort.{w} :=
  ⟨λ _ _ => ⟨⟩⟩

  instance hasLinearFunOp : HasLinearFunOp sort.{u} :=
  { appIsFun        := λ _ _   => ⟨⟩,
    appFunIsFun     := λ _ _   => ⟨⟩,
    compFunIsFun    := λ _ _   => ⟨⟩,
    compFunFunIsFun := λ _ _ _ => ⟨⟩ }

  instance hasAffineFunOp : HasAffineFunOp sort.{u} :=
  { constFunIsFun := λ _ _ => ⟨⟩ }

  instance hasFullFunOp : HasFullFunOp sort.{u} :=
  { dupIsFun    := λ _   => ⟨⟩,
    dupFunIsFun := λ _ _ => ⟨⟩ }

  instance hasFunOp : HasFunOp sort.{u} := ⟨⟩

end sort

namespace prop

  instance hasExternalEquivalences : HasExternalEquivalences prop prop := ⟨λ _ _ => PUnit.{0}⟩

  @[reducible] def toBundledEquivalence {p q : prop} (h : p ↔ q) : p ⟷' q :=
  ⟨sort.toBundledFunctor h.mp, sort.toBundledFunctor h.mpr, ⟨⟩⟩

  @[reducible] def fromBundledEquivalence {p q : prop} (E : p ⟷' q) : p ↔ q :=
  ⟨E.toFun.f, E.invFun.f⟩

  theorem fromToBundledEquivalence {p q : prop} (h : p ↔ q) :
    fromBundledEquivalence (toBundledEquivalence h) = h :=
  rfl

  theorem toFromBundledEquivalence {p q : prop} (E : p ⟷' q) :
    toBundledEquivalence (fromBundledEquivalence E) = E := match E with
  | ⟨toFun, invFun, _⟩ => by simp; exact ⟨sort.toFromBundledFunctor toFun, sort.toFromBundledFunctor invFun, HEq.rfl⟩

  def equivEquiv (p q : prop) : (p ↔ q) ≃ (p ⟷' q) :=
  { toFun    := toBundledEquivalence,
    invFun   := fromBundledEquivalence,
    leftInv  := fromToBundledEquivalence,
    rightInv := toFromBundledEquivalence }

  instance hasInternalEquivalences : HasInternalEquivalences prop :=
  { Equiv                := Iff,
    equivEquiv           := equivEquiv,
    equivElimToFunIsFun  := λ _ _ => ⟨⟩,
    equivElimInvFunIsFun := λ _ _ => ⟨⟩ }

  instance hasIdEquiv   : HasIdEquiv   prop           := ⟨λ _   => ⟨⟩⟩
  instance hasCompEquiv : HasCompEquiv prop prop prop := ⟨λ _ _ => ⟨⟩⟩
  instance hasInvEquiv  : HasInvEquiv  prop prop      := ⟨λ _   => ⟨⟩⟩

  instance hasEquivOp : HasEquivOp prop :=
  { compEquivIsFun    := λ _ _   => ⟨⟩,
    compEquivFunIsFun := λ _ _ _ => ⟨⟩,
    invEquivIsFun     := λ _ _   => ⟨⟩,
    invEquivIsEquiv   := λ _ _   => ⟨⟩ }

  def prodEquiv (p q : prop) : (p ∧ q) ≃ (p ⊓' q) :=
  { toFun    := λ h => ⟨h.left, h.right⟩,
    invFun   := λ P => ⟨P.fst, P.snd⟩,
    leftInv  := λ _ => rfl,
    rightInv := λ ⟨_, _⟩ => rfl }

  instance hasInternalProducts : HasInternalProducts prop :=
  { Prod             := And,
    prodEquiv        := prodEquiv,
    prodIntroIsFun   := λ _ _ => ⟨⟩,
    prodElimFstIsFun := λ _ _ => ⟨⟩,
    prodElimSndIsFun := λ _ _ => ⟨⟩ }

  instance hasEmptyType : HasEmptyType prop :=
  { Empty          := False,
    emptyIsEmpty   := id,
    emptyElimIsFun := λ _ => ⟨⟩ }

  instance hasClassicalLogic : HasClassicalLogic prop :=
  { byContradiction := @Classical.byContradiction }

  instance hasUnitType : HasUnitType prop :=
  { Unit           := True,
    unit           := trivial,
    unitIntroIsFun := λ _ => ⟨⟩ }

  -- Every equivalence relation can trivially be converted to an instance of `IsEquivalence`.
  instance relEquiv {α : Sort u} {R : GeneralizedRelation α prop} (e : Equivalence R) : IsEquivalence R :=
  { refl  := e.refl,
    trans := e.trans,
    symm  := ⟨e.symm, e.symm⟩ }

  namespace relEquiv

    instance eq     (α : Sort u)                : IsEquivalence (V := prop) (@Eq α) := relEquiv Eq.isEquivalence
    instance setoid (α : Sort u) [s : Setoid α] : IsEquivalence (V := prop) s.r     := relEquiv s.iseqv

  end relEquiv

  instance hasUnitEquivalences : unit.HasUnitEquivalences prop := ⟨unit.Rel⟩

  instance hasEquivCongr : HasEquivCongr prop :=
  { equivCongrArg := λ _ => unit.unitFunctor (U := unit) ⟨⟩ ⟨⟩,
    equivCongrFun := λ _ => unit.unitFunctor (U := unit) ⟨⟩ ⟨⟩ }

  instance hasNaturalEquivalences : HasNaturalEquivalences prop :=
  { equivHasInstEquivs := unit.hasUnitInstanceEquivalences unit,
    isNat              := λ _ _ _ _ => trivial }

  section NaturalTransformations

    variable {α : Sort u} {β : Sort v} {V : Universe.{v}}
             [HasInternalFunctors V] [HasExternalFunctors V prop]
             (R : GeneralizedRelation α V) (S : GeneralizedRelation β prop) [HasTrans S]
             {mF mG : α → β} (F : MappedBaseFunctor R S mF) (G : MappedBaseFunctor R S mG)

    instance isNatural (n : ∀ a, S (mF a) (mG a)) : IsNatural R S F G n := ⟨λ _ => trivial⟩

    def natEquiv : (∀ a, S (mF a) (mG a)) ≃ NaturalQuantification R S F G :=
    { toFun    := λ n => ⟨n⟩,
      invFun   := λ N => N.n,
      leftInv  := λ _ => rfl,
      rightInv := λ { n := _, isNatural := ⟨_⟩ } => rfl }

    instance hasIntNat : HasInternalNaturalQuantification R S F G :=
    { Nat      := ∀ a, S (mF a) (mG a),
      natEquiv := natEquiv R S F G }

  end NaturalTransformations

  instance hasNat {U₁ U₂ V : Universe} [HasExternalFunctors U₁ U₂] [HasExternalFunctors V prop] :
    HasNaturalQuantification U₁ U₂ V prop :=
  { hasNat := λ {α β} R S {h mF mG} F G => hasIntNat R S F G }

  instance hasInstanceIsomorphisms : HasInstanceIsomorphisms prop :=
  { equivIsIso := λ p => unit.isIsomorphismRelation (unit.Rel p) }

end prop

namespace type

  class IsEquiv {α β : type} (toFun : α ⟶' β) (invFun : β ⟶' α) where
  (leftInv  : ∀ a, invFun (toFun a) = a)
  (rightInv : ∀ b, toFun (invFun b) = b)

  instance hasExternalEquivalences : HasExternalEquivalences type type := ⟨IsEquiv⟩

  @[reducible] def isEquivalence {α β : type} (e : Equiv α β) :
    IsEquiv (sort.toBundledFunctor e.toFun) (sort.toBundledFunctor e.invFun) :=
  ⟨e.leftInv, e.rightInv⟩

  theorem isEquivalenceIsUnique {α β : type} {e : Equiv α β} (h : IsEquiv (sort.toBundledFunctor e.toFun) (sort.toBundledFunctor e.invFun)) :
    h = isEquivalence e := match h with
  | ⟨_, _⟩ => sorry -- by proof irrelevance

  @[reducible] def invIsEquivalence {α β : type} {toFun : α ⟶' β} {invFun : β ⟶' α} (h : IsEquiv toFun invFun) :
    IsEquiv invFun toFun :=
  ⟨h.rightInv, h.leftInv⟩

  @[reducible] def toBundledEquivalence {α β : type} (e : Equiv α β) : α ⟷' β :=
  ⟨sort.toBundledFunctor e.toFun, sort.toBundledFunctor e.invFun, isEquivalence e⟩

  @[reducible] def fromBundledEquivalence {α β : type} (E : α ⟷' β) : Equiv α β :=
  ⟨E.toFun.f, E.invFun.f, E.isEquiv.leftInv, E.isEquiv.rightInv⟩

  theorem fromToBundledEquivalence {α β : type} (e : Equiv α β) :
    fromBundledEquivalence (toBundledEquivalence e) = e := match e with
  | ⟨_, _, _, _⟩ => rfl

  theorem toFromBundledEquivalence {α β : type} (E : α ⟷' β) :
    toBundledEquivalence (fromBundledEquivalence E) = E := match E with
  | ⟨toFun, invFun, _⟩ => by simp; exact ⟨sort.toFromBundledFunctor toFun, sort.toFromBundledFunctor invFun,
                                          sorry⟩ -- by `isEquivalenceIsUnique`

  def equivEquiv (α β : type) : Equiv α β ≃ (α ⟷' β) :=
  { toFun    := toBundledEquivalence,
    invFun   := fromBundledEquivalence,
    leftInv  := fromToBundledEquivalence,
    rightInv := toFromBundledEquivalence }

  instance hasInternalEquivalences : HasInternalEquivalences type :=
  { Equiv                := Equiv,
    equivEquiv           := equivEquiv,
    equivElimToFunIsFun  := λ _ _ => ⟨⟩,
    equivElimInvFunIsFun := λ _ _ => ⟨⟩ }

  instance hasIdEquiv   : HasIdEquiv   type           := ⟨λ α   => isEquivalence (Equiv.refl α)⟩
  instance hasCompEquiv : HasCompEquiv type type type := ⟨λ E F => isEquivalence (Equiv.trans (fromBundledEquivalence E) (fromBundledEquivalence F))⟩
  instance hasInvEquiv  : HasInvEquiv  type type      := ⟨λ E   => invIsEquivalence E.isEquiv⟩

  instance hasEquivOp : HasEquivOp type :=
  { compEquivIsFun    := λ _ _   => ⟨⟩,
    compEquivFunIsFun := λ _ _ _ => ⟨⟩,
    invEquivIsFun     := λ _ _   => ⟨⟩,
    invEquivIsEquiv   := λ α β   => ⟨@Equiv.symm_symm α β, @Equiv.symm_symm β α⟩ }

  def prodEquiv (α β : type) : Prod α β ≃ (α ⊓' β) :=
  { toFun    := λ p => ⟨p.fst, p.snd⟩,
    invFun   := λ P => ⟨P.fst, P.snd⟩,
    leftInv  := λ ⟨_, _⟩ => rfl,
    rightInv := λ ⟨_, _⟩ => rfl }

  instance hasInternalProducts : HasInternalProducts type :=
  { Prod             := Prod,
    prodEquiv        := prodEquiv,
    prodIntroIsFun   := λ _ _ => ⟨⟩,
    prodElimFstIsFun := λ _ _ => ⟨⟩,
    prodElimSndIsFun := λ _ _ => ⟨⟩ }

  instance hasEmptyType : HasEmptyType type :=
  { Empty          := Empty,
    emptyIsEmpty   := λ a => (by induction a),
    emptyElimIsFun := λ _ => ⟨⟩ }

  instance hasUnitType : HasUnitType type :=
  { Unit           := Unit,
    unit           := ⟨⟩,
    unitIntroIsFun := λ _ => ⟨⟩ }

  instance hasInstanceEquivalences : HasInstanceEquivalences type := ⟨prop, @Eq⟩

  instance hasEquivCongr : HasEquivCongr type :=
  { equivCongrArg := λ F => sort.toBundledFunctor (congrArg F.f),
    equivCongrFun := λ a => sort.toBundledFunctor (λ h => congrFun h a) }

  instance hasNaturalEquivalences : HasNaturalEquivalences type :=
  { equivHasInstEquivs := unit.hasUnitInstanceEquivalences prop,
    isNat              := λ _ _ _ _ => trivial }

  instance hasInstanceIsomorphisms : HasInstanceIsomorphisms type :=
  { equivIsIso := λ α => unit.isIsomorphismRelation (V := prop) (@Eq α) }

end type


/-
Copyright (c) 2021 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Adam Topaz, Scott Morrison
-/
import category_theory.punit
import category_theory.comma
import category_theory.limits.shapes.terminal

/-!
# The category of "structured arrows"

For `T : C ⥤ D`, a `T`-structured arrow with source `S : D`
is just a morphism `S ⟶ T.obj Y`, for some `Y : C`.

These form a category with morphisms `g : Y ⟶ Y'` making the obvious diagram commute.

We prove that `𝟙 (T.obj Y)` is the initial object in `T`-structured objects with source `T.obj Y`.
-/

namespace category_theory

-- morphism levels before object levels. See note [category_theory universes].
universes v₁ v₂ v₃ v₄ u₁ u₂ u₃ u₄
variables {C : Type u₁} [category.{v₁} C] {D : Type u₂} [category.{v₂} D]

/--
The category of `T`-structured arrows with domain `S : D` (here `T : C ⥤ D`),
has as its objects `D`-morphisms of the form `S ⟶ T Y`, for some `Y : C`,
and morphisms `C`-morphisms `Y ⟶ Y'` making the obvious triangle commute.
-/
@[derive category, nolint has_inhabited_instance]
def structured_arrow (S : D) (T : C ⥤ D) := comma (functor.from_punit S) T

namespace structured_arrow

/-- The obvious projection functor from structured arrows. -/
@[simps]
def proj (S : D) (T : C ⥤ D) : structured_arrow S T ⥤ C := comma.snd _ _

variables {S S' S'' : D} {Y Y' : C} {T : C ⥤ D}

/-- Construct a structured arrow from a morphism. -/
def mk (f : S ⟶ T.obj Y) : structured_arrow S T := ⟨⟨⟩, Y, f⟩

@[simp] lemma mk_left (f : S ⟶ T.obj Y) : (mk f).left = punit.star := rfl
@[simp] lemma mk_right (f : S ⟶ T.obj Y) : (mk f).right = Y := rfl
@[simp] lemma mk_hom_eq_self (f : S ⟶ T.obj Y) : (mk f).hom = f := rfl

@[simp, reassoc] lemma w {A B : structured_arrow S T} (f : A ⟶ B) : A.hom ≫ T.map f.right = B.hom :=
by { have := f.w; tidy }

lemma eq_mk (f : structured_arrow S T) : f = mk f.hom :=
by { cases f, congr, ext, }

/--
To construct a morphism of structured arrows,
we need a morphism of the objects underlying the target,
and to check that the triangle commutes.
-/
@[simps]
def hom_mk {f f' : structured_arrow S T} (g : f.right ⟶ f'.right) (w : f.hom ≫ T.map g = f'.hom) :
  f ⟶ f' :=
{ left := eq_to_hom (by ext),
  right := g,
  w' := by { dsimp, simpa using w.symm, }, }

/--
Given a structured arrow `X ⟶ F(U)`, and an arrow `U ⟶ Y`, we can construct a morphism of
structured arrow given by `(X ⟶ F(U)) ⟶ (X ⟶ F(U) ⟶ F(Y))`.
-/
def hom_mk' {F : C ⥤ D} {X : D} {Y : C}
(U : structured_arrow X F) (f : U.right ⟶ Y) :
U ⟶ mk (U.hom ≫ F.map f) := { right := f }

/--
To construct an isomorphism of structured arrows,
we need an isomorphism of the objects underlying the target,
and to check that the triangle commutes.
-/
@[simps]
def iso_mk {f f' : structured_arrow S T} (g : f.right ≅ f'.right)
  (w : f.hom ≫ T.map g.hom = f'.hom) : f ≅ f' :=
comma.iso_mk (eq_to_iso (by ext)) g (by simpa using w.symm)

/--
A morphism between source objects `S ⟶ S'`
contravariantly induces a functor between structured arrows,
`structured_arrow S' T ⥤ structured_arrow S T`.

Ideally this would be described as a 2-functor from `D`
(promoted to a 2-category with equations as 2-morphisms)
to `Cat`.
-/
@[simps]
def map (f : S ⟶ S') : structured_arrow S' T ⥤ structured_arrow S T :=
comma.map_left _ ((functor.const _).map f)

@[simp]

@[simp] lemma map_id {f : structured_arrow S T} : (map (𝟙 S)).obj f = f :=
by { rw eq_mk f, simp, }

@[simp] lemma map_comp {f : S ⟶ S'} {f' : S' ⟶ S''} {h : structured_arrow S'' T} :
  (map (f ≫ f')).obj h = (map f).obj ((map f').obj h) :=
by { rw eq_mk h, simp, }

instance proj_reflects_iso : reflects_isomorphisms (proj S T) :=
{ reflects := λ Y Z f t, by exactI
  ⟨⟨structured_arrow.hom_mk (inv ((proj S T).map f)) (by simp), by tidy⟩⟩ }

open category_theory.limits

/-- The identity structured arrow is initial. -/
def mk_id_initial [full T] [faithful T] : is_initial (mk (𝟙 (T.obj Y))) :=
{ desc := λ c, hom_mk (T.preimage c.X.hom) (by { dsimp, simp, }),
  uniq' := λ c m _, begin
    ext,
    apply T.map_injective,
    simpa only [hom_mk_right, T.image_preimage, ←w m] using (category.id_comp _).symm,
  end }

variables {A : Type u₃} [category.{v₃} A] {B : Type u₄} [category.{v₄} B]

/-- The functor `(S, F ⋙ G) ⥤ (S, G)`. -/
@[simps]
def pre (S : D) (F : B ⥤ C) (G : C ⥤ D) : structured_arrow S (F ⋙ G) ⥤ structured_arrow S G :=
comma.pre_right _ F G

/-- The functor `(S, F) ⥤ (G(S), F ⋙ G)`. -/
@[simps] def post (S : C) (F : B ⥤ C) (G : C ⥤ D) :
  structured_arrow S F ⥤ structured_arrow (G.obj S) (F ⋙ G) :=
{ obj := λ X, { right := X.right, hom := G.map X.hom },
  map := λ X Y f, { right := f.right, w' :=
    by { simp [functor.comp_map, ←G.map_comp, ← f.w] } } }

end structured_arrow

/--
The category of `S`-costructured arrows with target `T : D` (here `S : C ⥤ D`),
has as its objects `D`-morphisms of the form `S Y ⟶ T`, for some `Y : C`,
and morphisms `C`-morphisms `Y ⟶ Y'` making the obvious triangle commute.
-/
@[derive category, nolint has_inhabited_instance]
def costructured_arrow (S : C ⥤ D) (T : D) := comma S (functor.from_punit T)

namespace costructured_arrow

/-- The obvious projection functor from costructured arrows. -/
@[simps]
def proj (S : C ⥤ D) (T : D) : costructured_arrow S T ⥤ C := comma.fst _ _

variables {T T' T'' : D} {Y Y' : C} {S : C ⥤ D}

/-- Construct a costructured arrow from a morphism. -/
def mk (f : S.obj Y ⟶ T) : costructured_arrow S T := ⟨Y, ⟨⟩, f⟩

@[simp] lemma mk_left (f : S.obj Y ⟶ T) : (mk f).left = Y := rfl
@[simp] lemma mk_right (f : S.obj Y ⟶ T) : (mk f).right = punit.star := rfl
@[simp] lemma mk_hom_eq_self (f : S.obj Y ⟶ T) : (mk f).hom = f := rfl

@[simp, reassoc] lemma w {A B : costructured_arrow S T} (f : A ⟶ B) :
  S.map f.left ≫ B.hom = A.hom :=
by tidy

lemma eq_mk (f : costructured_arrow S T) : f = mk f.hom :=
by { cases f, congr, ext, }

/--
To construct a morphism of costructured arrows,
we need a morphism of the objects underlying the source,
and to check that the triangle commutes.
-/
@[simps]
def hom_mk {f f' : costructured_arrow S T} (g : f.left ⟶ f'.left) (w : S.map g ≫ f'.hom = f.hom) :
  f ⟶ f' :=
{ left := g,
  right := eq_to_hom (by ext),
  w' := by simpa using w, }

/--
To construct an isomorphism of costructured arrows,
we need an isomorphism of the objects underlying the source,
and to check that the triangle commutes.
-/
@[simps]
def iso_mk {f f' : costructured_arrow S T} (g : f.left ≅ f'.left)
  (w : S.map g.hom ≫ f'.hom = f.hom) : f ≅ f' :=
comma.iso_mk g (eq_to_iso (by ext)) (by simpa using w)

/--
A morphism between target objects `T ⟶ T'`
covariantly induces a functor between costructured arrows,
`costructured_arrow S T ⥤ costructured_arrow S T'`.

Ideally this would be described as a 2-functor from `D`
(promoted to a 2-category with equations as 2-morphisms)
to `Cat`.
-/
@[simps]
def map (f : T ⟶ T') : costructured_arrow S T ⥤ costructured_arrow S T' :=
comma.map_right _ ((functor.const _).map f)

@[simp] lemma map_mk {f : S.obj Y ⟶ T} (g : T ⟶ T') :
  (map g).obj (mk f) = mk (f ≫ g) := rfl

@[simp] lemma map_id {f : costructured_arrow S T} : (map (𝟙 T)).obj f = f :=
by { rw eq_mk f, simp, }

@[simp] lemma map_comp {f : T ⟶ T'} {f' : T' ⟶ T''} {h : costructured_arrow S T} :
  (map (f ≫ f')).obj h = (map f').obj ((map f).obj h) :=
by { rw eq_mk h, simp, }

instance proj_reflects_iso : reflects_isomorphisms (proj S T) :=
{ reflects := λ Y Z f t, by exactI
  ⟨⟨costructured_arrow.hom_mk (inv ((proj S T).map f)) (by simp), by tidy⟩⟩ }

open category_theory.limits

/-- The identity costructured arrow is terminal. -/
def mk_id_terminal [full S] [faithful S] : is_terminal (mk (𝟙 (S.obj Y))) :=
{ lift := λ c, hom_mk (S.preimage c.X.hom) (by { dsimp, simp, }),
  uniq' := begin
    rintros c m -,
    ext,
    apply S.map_injective,
    simpa only [hom_mk_left, S.image_preimage, ←w m] using (category.comp_id _).symm,
  end }

variables {A : Type u₃} [category.{v₃} A] {B : Type u₄} [category.{v₄} B]

/-- The functor `(F ⋙ G, S) ⥤ (G, S)`. -/
@[simps]
def pre (F : B ⥤ C) (G : C ⥤ D) (S : D) : costructured_arrow (F ⋙ G) S ⥤ costructured_arrow G S :=
comma.pre_left F G _

/-- The functor `(F, S) ⥤ (F ⋙ G, G(S))`. -/
@[simps] def post (F : B ⥤ C) (G : C ⥤ D) (S : C) :
  costructured_arrow F S ⥤ costructured_arrow (F ⋙ G) (G.obj S) :=
{ obj := λ X, { left := X.left, hom := G.map X.hom },
  map := λ X Y f, { left := f.left, w' :=
    by { simp [functor.comp_map, ←G.map_comp, ← f.w] } } }

end costructured_arrow

open opposite

namespace structured_arrow

/--
For a functor `F : C ⥤ D` and an object `d : D`, we obtain a contravariant functor from the
category of structured arrows `d ⟶ F.obj c` to the category of costructured arrows
`F.op.obj c ⟶ (op d)`.
-/
@[simps]
def to_costructured_arrow (F : C ⥤ D) (d : D) :
  (structured_arrow d F)ᵒᵖ ⥤ costructured_arrow F.op (op d) :=
{ obj := λ X, @costructured_arrow.mk _ _ _ _ _ (op X.unop.right) F.op X.unop.hom.op,
  map := λ X Y f, costructured_arrow.hom_mk (f.unop.right.op)
  begin
    dsimp,
    rw [← op_comp, ← f.unop.w, functor.const.obj_map],
    erw category.id_comp,
  end }

/--
For a functor `F : C ⥤ D` and an object `d : D`, we obtain a contravariant functor from the
category of structured arrows `op d ⟶ F.op.obj c` to the category of costructured arrows
`F.obj c ⟶ d`.
-/
@[simps]
def to_costructured_arrow' (F : C ⥤ D) (d : D) :
  (structured_arrow (op d) F.op)ᵒᵖ ⥤ costructured_arrow F d :=
{ obj := λ X, @costructured_arrow.mk _ _ _ _ _ (unop X.unop.right) F X.unop.hom.unop,
  map := λ X Y f, costructured_arrow.hom_mk f.unop.right.unop
  begin
    dsimp,
    rw [← quiver.hom.unop_op (F.map (quiver.hom.unop f.unop.right)), ← unop_comp, ← F.op_map,
      ← f.unop.w, functor.const.obj_map],
    erw category.id_comp,
  end }

end structured_arrow

namespace costructured_arrow

/--
For a functor `F : C ⥤ D` and an object `d : D`, we obtain a contravariant functor from the
category of costructured arrows `F.obj c ⟶ d` to the category of structured arrows
`op d ⟶ F.op.obj c`.
-/
@[simps]
def to_structured_arrow (F : C ⥤ D) (d : D) :
  (costructured_arrow F d)ᵒᵖ ⥤ structured_arrow (op d) F.op :=
{ obj := λ X, @structured_arrow.mk _ _ _ _ _ (op X.unop.left) F.op X.unop.hom.op,
  map := λ X Y f, structured_arrow.hom_mk f.unop.left.op
  begin
    dsimp,
    rw [← op_comp, f.unop.w, functor.const.obj_map],
    erw category.comp_id,
  end }

/--
For a functor `F : C ⥤ D` and an object `d : D`, we obtain a contravariant functor from the
category of costructured arrows `F.op.obj c ⟶ op d` to the category of structured arrows
`d ⟶ F.obj c`.
-/
@[simps]
def to_structured_arrow' (F : C ⥤ D) (d : D) :
  (costructured_arrow F.op (op d))ᵒᵖ ⥤ structured_arrow d F :=
{ obj := λ X, @structured_arrow.mk _ _ _ _ _ (unop X.unop.left) F X.unop.hom.unop,
  map := λ X Y f, structured_arrow.hom_mk (f.unop.left.unop)
  begin
    dsimp,
    rw [← quiver.hom.unop_op (F.map f.unop.left.unop), ← unop_comp, ← F.op_map,
      f.unop.w, functor.const.obj_map],
    erw category.comp_id,
  end }

end costructured_arrow

/--
For a functor `F : C ⥤ D` and an object `d : D`, the category of structured arrows `d ⟶ F.obj c`
is contravariantly equivalent to the category of costructured arrows `F.op.obj c ⟶ op d`.
-/
def structured_arrow_op_equivalence (F : C ⥤ D) (d : D) :
  (structured_arrow d F)ᵒᵖ ≌ costructured_arrow F.op (op d) :=
equivalence.mk (structured_arrow.to_costructured_arrow F d)
  (costructured_arrow.to_structured_arrow' F d).right_op
  (nat_iso.of_components (λ X, (@structured_arrow.iso_mk _ _ _ _ _ _
    (structured_arrow.mk (unop X).hom) (unop X) (iso.refl _) (by tidy)).op)
    (λ X Y f, quiver.hom.unop_inj $ begin ext, dsimp, simp end))
  (nat_iso.of_components (λ X, @costructured_arrow.iso_mk _ _ _ _ _ _
    (costructured_arrow.mk X.hom) X (iso.refl _) (by tidy))
    (λ X Y f, begin ext, dsimp, simp end))

/--
For a functor `F : C ⥤ D` and an object `d : D`, the category of costructured arrows
`F.obj c ⟶ d` is contravariantly equivalent to the category of structured arrows
`op d ⟶ F.op.obj c`.
-/
def costructured_arrow_op_equivalence (F : C ⥤ D) (d : D) :
  (costructured_arrow F d)ᵒᵖ ≌ structured_arrow (op d) F.op :=
equivalence.mk (costructured_arrow.to_structured_arrow F d)
  (structured_arrow.to_costructured_arrow' F d).right_op
  (nat_iso.of_components (λ X, (@costructured_arrow.iso_mk _ _ _ _ _ _
    (costructured_arrow.mk (unop X).hom) (unop X) (iso.refl _) (by tidy)).op)
    (λ X Y f, quiver.hom.unop_inj $ begin ext, dsimp, simp end))
  (nat_iso.of_components (λ X, @structured_arrow.iso_mk _ _ _ _ _ _
    (structured_arrow.mk X.hom) X (iso.refl _) (by tidy))
    (λ X Y f, begin ext, dsimp, simp end))

end category_theory