/-
Copyright (c) 2022 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Scott Morrison, Joël Riou
-/
import category_theory.comm_sq
import category_theory.limits.opposites
import category_theory.limits.shapes.biproducts
import category_theory.limits.shapes.zero_morphisms
import category_theory.limits.constructions.binary_products
import category_theory.limits.constructions.zero_objects

/-!
# Pullback and pushout squares, and bicartesian squares

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

We provide another API for pullbacks and pushouts.

`is_pullback fst snd f g` is the proposition that
```
  P --fst--> X
  |          |
 snd         f
  |          |
  v          v
  Y ---g---> Z

```
is a pullback square.

(And similarly for `is_pushout`.)

We provide the glue to go back and forth to the usual `is_limit` API for pullbacks, and prove
`is_pullback (pullback.fst : pullback f g ⟶ X) (pullback.snd : pullback f g ⟶ Y) f g`
for the usual `pullback f g` provided by the `has_limit` API.

We don't attempt to restate everything we know about pullbacks in this language,
but do restate the pasting lemmas.

We define bicartesian squares, and
show that the pullback and pushout squares for a biproduct are bicartesian.
-/

noncomputable theory

open category_theory
open category_theory.limits

universes v₁ v₂ u₁ u₂

namespace category_theory

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

attribute [simp] comm_sq.mk

namespace comm_sq

variables {W X Y Z : C} {f : W ⟶ X} {g : W ⟶ Y} {h : X ⟶ Z} {i : Y ⟶ Z}

/--
The (not necessarily limiting) `pullback_cone h i` implicit in the statement
that we have `comm_sq f g h i`.
-/
def cone (s : comm_sq f g h i) : pullback_cone h i := pullback_cone.mk _ _ s.w

/--
The (not necessarily limiting) `pushout_cocone f g` implicit in the statement
that we have `comm_sq f g h i`.
-/
def cocone (s : comm_sq f g h i) : pushout_cocone f g := pushout_cocone.mk _ _ s.w

@[simp] lemma cone_fst (s : comm_sq f g h i) : s.cone.fst = f := rfl
@[simp] lemma cone_snd (s : comm_sq f g h i) : s.cone.snd = g := rfl
@[simp] lemma cocone_inl (s : comm_sq f g h i) : s.cocone.inl = h := rfl
@[simp] lemma cocone_inr (s : comm_sq f g h i) : s.cocone.inr = i := rfl

/-- The pushout cocone in the opposite category associated to the cone of
a commutative square identifies to the cocone of the flipped commutative square in
the opposite category -/
def cone_op (p : comm_sq f g h i) : p.cone.op ≅ p.flip.op.cocone :=
pushout_cocone.ext (iso.refl _) (by tidy) (by tidy)

/-- The pullback cone in the opposite category associated to the cocone of
a commutative square identifies to the cone of the flipped commutative square in
the opposite category -/
def cocone_op (p : comm_sq f g h i) : p.cocone.op ≅ p.flip.op.cone :=
pullback_cone.ext (iso.refl _) (by tidy) (by tidy)

/-- The pushout cocone obtained from the pullback cone associated to a
commutative square in the opposite category identifies to the cocone associated
to the flipped square. -/
def cone_unop {W X Y Z : Cᵒᵖ} {f : W ⟶ X} {g : W ⟶ Y} {h : X ⟶ Z} {i : Y ⟶ Z}
  (p : comm_sq f g h i) : p.cone.unop ≅ p.flip.unop.cocone :=
pushout_cocone.ext (iso.refl _) (by tidy) (by tidy)

/-- The pullback cone obtained from the pushout cone associated to a
commutative square in the opposite category identifies to the cone associated
to the flipped square. -/
def cocone_unop {W X Y Z : Cᵒᵖ} {f : W ⟶ X} {g : W ⟶ Y} {h : X ⟶ Z} {i : Y ⟶ Z}
  (p : comm_sq f g h i) : p.cocone.unop ≅ p.flip.unop.cone :=
pullback_cone.ext (iso.refl _) (by tidy) (by tidy)

end comm_sq

/-- The proposition that a square
```
  P --fst--> X
  |          |
 snd         f
  |          |
  v          v
  Y ---g---> Z

```
is a pullback square. (Also known as a fibered product or cartesian square.)
-/
structure is_pullback {P X Y Z : C} (fst : P ⟶ X) (snd : P ⟶ Y) (f : X ⟶ Z) (g : Y ⟶ Z)
  extends comm_sq fst snd f g : Prop :=
(is_limit' : nonempty (is_limit (pullback_cone.mk _ _ w)))

/-- The proposition that a square
```
  Z ---f---> X
  |          |
  g         inl
  |          |
  v          v
  Y --inr--> P

```
is a pushout square. (Also known as a fiber coproduct or cocartesian square.)
-/
structure is_pushout {Z X Y P : C} (f : Z ⟶ X) (g : Z ⟶ Y) (inl : X ⟶ P) (inr : Y ⟶ P)
  extends comm_sq f g inl inr : Prop :=
(is_colimit' : nonempty (is_colimit (pushout_cocone.mk _ _ w)))

section
set_option old_structure_cmd true

/-- A *bicartesian* square is a commutative square
```
  W ---f---> X
  |          |
  g          h
  |          |
  v          v
  Y ---i---> Z

```
that is both a pullback square and a pushout square.
-/
structure bicartesian_sq {W X Y Z : C} (f : W ⟶ X) (g : W ⟶ Y) (h : X ⟶ Z) (i : Y ⟶ Z)
  extends is_pullback f g h i, is_pushout f g h i : Prop

-- Lean should make these parent projections as `lemma`, not `def`.
attribute [nolint def_lemma doc_blame] bicartesian_sq.to_is_pullback bicartesian_sq.to_is_pushout

end

/-!
We begin by providing some glue between `is_pullback` and the `is_limit` and `has_limit` APIs.
(And similarly for `is_pushout`.)
-/

namespace is_pullback

variables {P X Y Z : C} {fst : P ⟶ X} {snd : P ⟶ Y} {f : X ⟶ Z} {g : Y ⟶ Z}

/--
The (limiting) `pullback_cone f g` implicit in the statement
that we have a `is_pullback fst snd f g`.
-/
def cone (h : is_pullback fst snd f g) : pullback_cone f g := h.to_comm_sq.cone

@[simp] lemma cone_fst (h : is_pullback fst snd f g) : h.cone.fst = fst := rfl
@[simp] lemma cone_snd (h : is_pullback fst snd f g) : h.cone.snd = snd := rfl

/--
The cone obtained from `is_pullback fst snd f g` is a limit cone.
-/
noncomputable def is_limit (h : is_pullback fst snd f g) : is_limit h.cone :=
h.is_limit'.some

/-- If `c` is a limiting pullback cone, then we have a `is_pullback c.fst c.snd f g`. -/
lemma of_is_limit {c : pullback_cone f g} (h : limits.is_limit c) :
  is_pullback c.fst c.snd f g :=
{ w := c.condition,
  is_limit' := ⟨is_limit.of_iso_limit h
    (limits.pullback_cone.ext (iso.refl _) (by tidy) (by tidy))⟩, }

/-- A variant of `of_is_limit` that is more useful with `apply`. -/
lemma of_is_limit' (w : comm_sq fst snd f g) (h : limits.is_limit w.cone) :
  is_pullback fst snd f g :=
of_is_limit h

/-- The pullback provided by `has_pullback f g` fits into a `is_pullback`. -/
lemma of_has_pullback (f : X ⟶ Z) (g : Y ⟶ Z) [has_pullback f g] :
  is_pullback (pullback.fst : pullback f g ⟶ X) (pullback.snd : pullback f g ⟶ Y) f g :=
of_is_limit (limit.is_limit (cospan f g))

/-- If `c` is a limiting binary product cone, and we have a terminal object,
then we have `is_pullback c.fst c.snd 0 0`
(where each `0` is the unique morphism to the terminal object). -/
lemma of_is_product {c : binary_fan X Y} (h : limits.is_limit c) (t : is_terminal Z) :
  is_pullback c.fst c.snd (t.from _) (t.from _) :=
of_is_limit (is_pullback_of_is_terminal_is_product _ _ _ _ t
  (is_limit.of_iso_limit h (limits.cones.ext (iso.refl c.X) (by rintro ⟨⟨⟩⟩; { dsimp, simp, }))))

/-- A variant of `of_is_product` that is more useful with `apply`. -/
lemma of_is_product' (h : limits.is_limit (binary_fan.mk fst snd)) (t : is_terminal Z) :
  is_pullback fst snd (t.from _) (t.from _) :=
of_is_product h t

variables (X Y)

lemma of_has_binary_product' [has_binary_product X Y] [has_terminal C] :
  is_pullback limits.prod.fst limits.prod.snd (terminal.from X) (terminal.from Y) :=
of_is_product (limit.is_limit _) terminal_is_terminal

open_locale zero_object

lemma of_has_binary_product [has_binary_product X Y] [has_zero_object C] [has_zero_morphisms C] :
  is_pullback limits.prod.fst limits.prod.snd (0 : X ⟶ 0) (0 : Y ⟶ 0) :=
by convert of_is_product (limit.is_limit _) has_zero_object.zero_is_terminal

variables {X Y}

/-- Any object at the top left of a pullback square is
isomorphic to the pullback provided by the `has_limit` API. -/
noncomputable
def iso_pullback (h : is_pullback fst snd f g) [has_pullback f g] : P ≅ pullback f g :=
(limit.iso_limit_cone ⟨_, h.is_limit⟩).symm

@[simp] lemma iso_pullback_hom_fst (h : is_pullback fst snd f g) [has_pullback f g] :
  h.iso_pullback.hom ≫ pullback.fst = fst :=
by { dsimp [iso_pullback, cone, comm_sq.cone], simp, }
@[simp] lemma iso_pullback_hom_snd (h : is_pullback fst snd f g) [has_pullback f g] :
  h.iso_pullback.hom ≫ pullback.snd = snd :=
by { dsimp [iso_pullback, cone, comm_sq.cone], simp, }
@[simp] lemma iso_pullback_inv_fst (h : is_pullback fst snd f g) [has_pullback f g] :
  h.iso_pullback.inv ≫ fst = pullback.fst :=
by simp [iso.inv_comp_eq]
@[simp] lemma iso_pullback_inv_snd (h : is_pullback fst snd f g) [has_pullback f g] :
  h.iso_pullback.inv ≫ snd = pullback.snd :=
by simp [iso.inv_comp_eq]

lemma of_iso_pullback (h : comm_sq fst snd f g) [has_pullback f g] (i : P ≅ pullback f g)
  (w₁ : i.hom ≫ pullback.fst = fst) (w₂ : i.hom ≫ pullback.snd = snd) : is_pullback fst snd f g :=
of_is_limit' h (limits.is_limit.of_iso_limit (limit.is_limit _)
  (@pullback_cone.ext _ _ _ _ _ _ _ (pullback_cone.mk _ _ _) _ i w₁.symm w₂.symm).symm)

lemma of_horiz_is_iso [is_iso fst] [is_iso g] (sq : comm_sq fst snd f g) :
  is_pullback fst snd f g := of_is_limit' sq
begin
  refine pullback_cone.is_limit.mk _ (λ s, s.fst ≫ inv fst) (by tidy) (λ s, _) (by tidy),
  simp only [← cancel_mono g, category.assoc, ← sq.w, is_iso.inv_hom_id_assoc, s.condition],
end

end is_pullback

namespace is_pushout

variables {Z X Y P : C} {f : Z ⟶ X} {g : Z ⟶ Y} {inl : X ⟶ P} {inr : Y ⟶ P}

/--
The (colimiting) `pushout_cocone f g` implicit in the statement
that we have a `is_pushout f g inl inr`.
-/
def cocone (h : is_pushout f g inl inr) : pushout_cocone f g := h.to_comm_sq.cocone

@[simp] lemma cocone_inl (h : is_pushout f g inl inr) : h.cocone.inl = inl := rfl
@[simp] lemma cocone_inr (h : is_pushout f g inl inr) : h.cocone.inr = inr := rfl

/--
The cocone obtained from `is_pushout f g inl inr` is a colimit cocone.
-/
noncomputable def is_colimit (h : is_pushout f g inl inr) : is_colimit h.cocone :=
h.is_colimit'.some

/-- If `c` is a colimiting pushout cocone, then we have a `is_pushout f g c.inl c.inr`. -/
lemma of_is_colimit {c : pushout_cocone f g} (h : limits.is_colimit c) :
  is_pushout f g c.inl c.inr :=
{ w := c.condition,
  is_colimit' := ⟨is_colimit.of_iso_colimit h
    (limits.pushout_cocone.ext (iso.refl _) (by tidy) (by tidy))⟩, }

/-- A variant of `of_is_colimit` that is more useful with `apply`. -/
lemma of_is_colimit' (w : comm_sq f g inl inr) (h : limits.is_colimit w.cocone) :
  is_pushout f g inl inr :=
of_is_colimit h

/-- The pushout provided by `has_pushout f g` fits into a `is_pushout`. -/
lemma of_has_pushout (f : Z ⟶ X) (g : Z ⟶ Y) [has_pushout f g] :
  is_pushout f g (pushout.inl : X ⟶ pushout f g) (pushout.inr : Y ⟶ pushout f g) :=
of_is_colimit (colimit.is_colimit (span f g))

/-- If `c` is a colimiting binary coproduct cocone, and we have an initial object,
then we have `is_pushout 0 0 c.inl c.inr`
(where each `0` is the unique morphism from the initial object). -/
lemma of_is_coproduct {c : binary_cofan X Y} (h : limits.is_colimit c) (t : is_initial Z) :
  is_pushout (t.to _) (t.to _) c.inl c.inr :=
of_is_colimit (is_pushout_of_is_initial_is_coproduct _ _ _ _ t
  (is_colimit.of_iso_colimit h
    (limits.cocones.ext (iso.refl c.X) (by rintro ⟨⟨⟩⟩; { dsimp, simp, }))))

/-- A variant of `of_is_coproduct` that is more useful with `apply`. -/
lemma of_is_coproduct' (h : limits.is_colimit (binary_cofan.mk inl inr)) (t : is_initial Z) :
  is_pushout (t.to _) (t.to _) inl inr :=
of_is_coproduct h t

variables (X Y)

lemma of_has_binary_coproduct' [has_binary_coproduct X Y] [has_initial C] :
  is_pushout (initial.to _) (initial.to _) (coprod.inl : X ⟶ _) (coprod.inr : Y ⟶ _)  :=
of_is_coproduct (colimit.is_colimit _) initial_is_initial

open_locale zero_object

lemma of_has_binary_coproduct
  [has_binary_coproduct X Y] [has_zero_object C] [has_zero_morphisms C] :
  is_pushout (0 : 0 ⟶ X) (0 : 0 ⟶ Y) coprod.inl coprod.inr :=
by convert of_is_coproduct (colimit.is_colimit _) has_zero_object.zero_is_initial

variables {X Y}

/-- Any object at the top left of a pullback square is
isomorphic to the pullback provided by the `has_limit` API. -/
noncomputable
def iso_pushout (h : is_pushout f g inl inr) [has_pushout f g] : P ≅ pushout f g :=
(colimit.iso_colimit_cocone ⟨_, h.is_colimit⟩).symm

@[simp] lemma inl_iso_pushout_inv (h : is_pushout f g inl inr) [has_pushout f g] :
  pushout.inl ≫ h.iso_pushout.inv = inl :=
by { dsimp [iso_pushout, cocone, comm_sq.cocone], simp, }
@[simp] lemma inr_iso_pushout_inv (h : is_pushout f g inl inr) [has_pushout f g] :
  pushout.inr ≫ h.iso_pushout.inv = inr :=
by { dsimp [iso_pushout, cocone, comm_sq.cocone], simp, }
@[simp] lemma inl_iso_pushout_hom (h : is_pushout f g inl inr) [has_pushout f g] :
  inl ≫ h.iso_pushout.hom = pushout.inl :=
by simp [←iso.eq_comp_inv]
@[simp] lemma inr_iso_pushout_hom (h : is_pushout f g inl inr) [has_pushout f g] :
  inr ≫ h.iso_pushout.hom = pushout.inr :=
by simp [←iso.eq_comp_inv]

lemma of_iso_pushout (h : comm_sq f g inl inr) [has_pushout f g] (i : P ≅ pushout f g)
  (w₁ : inl ≫ i.hom = pushout.inl) (w₂ : inr ≫ i.hom = pushout.inr) : is_pushout f g inl inr :=
of_is_colimit' h (limits.is_colimit.of_iso_colimit (colimit.is_colimit _)
  (@pushout_cocone.ext _ _ _ _ _ _ _ (pushout_cocone.mk _ _ _) _ i w₁ w₂).symm)

end is_pushout

namespace is_pullback

variables {P X Y Z : C} {fst : P ⟶ X} {snd : P ⟶ Y} {f : X ⟶ Z} {g : Y ⟶ Z}

lemma flip (h : is_pullback fst snd f g) : is_pullback snd fst g f :=
of_is_limit (@pullback_cone.flip_is_limit _ _ _ _ _ _ _ _ _ _ h.w.symm h.is_limit)

lemma flip_iff : is_pullback fst snd f g ↔ is_pullback snd fst g f :=
⟨flip, flip⟩

section

variables [has_zero_object C] [has_zero_morphisms C]
open_locale zero_object

/-- The square with `0 : 0 ⟶ 0` on the left and `𝟙 X` on the right is a pullback square. -/
@[simp] lemma zero_left (X : C) : is_pullback (0 : 0 ⟶ X) (0 : 0 ⟶ 0) (𝟙 X) (0 : 0 ⟶ X) :=
{ w := by simp,
  is_limit' :=
  ⟨{ lift := λ s, 0,
     fac' := λ s, by simpa using @pullback_cone.equalizer_ext _ _ _ _ _ _ _ s _ 0 (𝟙 _)
       (by simpa using (pullback_cone.condition s).symm), }⟩ }

/-- The square with `0 : 0 ⟶ 0` on the top and `𝟙 X` on the bottom is a pullback square. -/
@[simp] lemma zero_top (X : C) : is_pullback (0 : 0 ⟶ 0) (0 : 0 ⟶ X) (0 : 0 ⟶ X) (𝟙 X) :=
(zero_left X).flip

/-- The square with `0 : 0 ⟶ 0` on the right and `𝟙 X` on the left is a pullback square. -/
@[simp] lemma zero_right (X : C) : is_pullback (0 : X ⟶ 0) (𝟙 X) (0 : 0 ⟶ 0) (0 : X ⟶ 0) :=
of_iso_pullback (by simp) ((zero_prod_iso X).symm ≪≫ (pullback_zero_zero_iso _ _).symm)
  (by simp) (by simp)

/-- The square with `0 : 0 ⟶ 0` on the bottom and `𝟙 X` on the top is a pullback square. -/
@[simp] lemma zero_bot (X : C) : is_pullback (𝟙 X) (0 : X ⟶ 0) (0 : X ⟶ 0) (0 : 0 ⟶ 0) :=
(zero_right X).flip

end

/-- Paste two pullback squares "vertically" to obtain another pullback square. -/
-- Objects here are arranged in a 3x2 grid, and indexed by their xy coordinates.
-- Morphisms are named `hᵢⱼ` for a horizontal morphism starting at `(i,j)`,
-- and `vᵢⱼ` for a vertical morphism starting at `(i,j)`.
lemma paste_vert {X₁₁ X₁₂ X₂₁ X₂₂ X₃₁ X₃₂ : C}
  {h₁₁ : X₁₁ ⟶ X₁₂} {h₂₁ : X₂₁ ⟶ X₂₂} {h₃₁ : X₃₁ ⟶ X₃₂}
  {v₁₁ : X₁₁ ⟶ X₂₁} {v₁₂ : X₁₂ ⟶ X₂₂} {v₂₁ : X₂₁ ⟶ X₃₁} {v₂₂ : X₂₂ ⟶ X₃₂}
  (s : is_pullback h₁₁ v₁₁ v₁₂ h₂₁) (t : is_pullback h₂₁ v₂₁ v₂₂ h₃₁) :
  is_pullback h₁₁ (v₁₁ ≫ v₂₁) (v₁₂ ≫ v₂₂) h₃₁ :=
(of_is_limit
  (big_square_is_pullback _ _ _ _ _ _ _ s.w t.w t.is_limit s.is_limit))

/-- Paste two pullback squares "horizontally" to obtain another pullback square. -/
lemma paste_horiz {X₁₁ X₁₂ X₁₃ X₂₁ X₂₂ X₂₃ : C}
  {h₁₁ : X₁₁ ⟶ X₁₂} {h₁₂ : X₁₂ ⟶ X₁₃} {h₂₁ : X₂₁ ⟶ X₂₂} {h₂₂ : X₂₂ ⟶ X₂₃}
  {v₁₁ : X₁₁ ⟶ X₂₁} {v₁₂ : X₁₂ ⟶ X₂₂} {v₁₃ : X₁₃ ⟶ X₂₃}
  (s : is_pullback h₁₁ v₁₁ v₁₂ h₂₁) (t : is_pullback h₁₂ v₁₂ v₁₃ h₂₂) :
  is_pullback (h₁₁ ≫ h₁₂) v₁₁ v₁₃ (h₂₁ ≫ h₂₂) :=
(paste_vert s.flip t.flip).flip

/-- Given a pullback square assembled from a commuting square on the top and
a pullback square on the bottom, the top square is a pullback square. -/
lemma of_bot {X₁₁ X₁₂ X₂₁ X₂₂ X₃₁ X₃₂ : C}
  {h₁₁ : X₁₁ ⟶ X₁₂} {h₂₁ : X₂₁ ⟶ X₂₂} {h₃₁ : X₃₁ ⟶ X₃₂}
  {v₁₁ : X₁₁ ⟶ X₂₁} {v₁₂ : X₁₂ ⟶ X₂₂} {v₂₁ : X₂₁ ⟶ X₃₁} {v₂₂ : X₂₂ ⟶ X₃₂}
  (s : is_pullback h₁₁ (v₁₁ ≫ v₂₁) (v₁₂ ≫ v₂₂) h₃₁) (p : h₁₁ ≫ v₁₂ = v₁₁ ≫ h₂₁)
  (t : is_pullback h₂₁ v₂₁ v₂₂ h₃₁) :
  is_pullback h₁₁ v₁₁ v₁₂ h₂₁ :=
of_is_limit (left_square_is_pullback _ _ _ _ _ _ _ p _ t.is_limit s.is_limit)

/-- Given a pullback square assembled from a commuting square on the left and
a pullback square on the right, the left square is a pullback square. -/
lemma of_right {X₁₁ X₁₂ X₁₃ X₂₁ X₂₂ X₂₃ : C}
  {h₁₁ : X₁₁ ⟶ X₁₂} {h₁₂ : X₁₂ ⟶ X₁₃} {h₂₁ : X₂₁ ⟶ X₂₂} {h₂₂ : X₂₂ ⟶ X₂₃}
  {v₁₁ : X₁₁ ⟶ X₂₁} {v₁₂ : X₁₂ ⟶ X₂₂} {v₁₃ : X₁₃ ⟶ X₂₃}
  (s : is_pullback (h₁₁ ≫ h₁₂) v₁₁ v₁₃ (h₂₁ ≫ h₂₂)) (p : h₁₁ ≫ v₁₂ = v₁₁ ≫ h₂₁)
  (t : is_pullback h₁₂ v₁₂ v₁₃ h₂₂) :
  is_pullback h₁₁ v₁₁ v₁₂ h₂₁ :=
(of_bot s.flip p.symm t.flip).flip

lemma paste_vert_iff {X₁₁ X₁₂ X₂₁ X₂₂ X₃₁ X₃₂ : C}
  {h₁₁ : X₁₁ ⟶ X₁₂} {h₂₁ : X₂₁ ⟶ X₂₂} {h₃₁ : X₃₁ ⟶ X₃₂}
  {v₁₁ : X₁₁ ⟶ X₂₁} {v₁₂ : X₁₂ ⟶ X₂₂} {v₂₁ : X₂₁ ⟶ X₃₁} {v₂₂ : X₂₂ ⟶ X₃₂}
  (s : is_pullback h₂₁ v₂₁ v₂₂ h₃₁) (e : h₁₁ ≫ v₁₂ = v₁₁ ≫ h₂₁) :
  is_pullback h₁₁ (v₁₁ ≫ v₂₁) (v₁₂ ≫ v₂₂) h₃₁ ↔ is_pullback h₁₁ v₁₁ v₁₂ h₂₁ :=
⟨λ h, h.of_bot e s, λ h, h.paste_vert s⟩

lemma paste_horiz_iff {X₁₁ X₁₂ X₁₃ X₂₁ X₂₂ X₂₃ : C}
  {h₁₁ : X₁₁ ⟶ X₁₂} {h₁₂ : X₁₂ ⟶ X₁₃} {h₂₁ : X₂₁ ⟶ X₂₂} {h₂₂ : X₂₂ ⟶ X₂₃}
  {v₁₁ : X₁₁ ⟶ X₂₁} {v₁₂ : X₁₂ ⟶ X₂₂} {v₁₃ : X₁₃ ⟶ X₂₃}
  (s : is_pullback h₁₂ v₁₂ v₁₃ h₂₂) (e : h₁₁ ≫ v₁₂ = v₁₁ ≫ h₂₁) :
  is_pullback (h₁₁ ≫ h₁₂) v₁₁ v₁₃ (h₂₁ ≫ h₂₂) ↔ is_pullback h₁₁ v₁₁ v₁₂ h₂₁ :=
⟨λ h, h.of_right e s, λ h, h.paste_horiz s⟩

section

variables [has_zero_object C] [has_zero_morphisms C]
open_locale zero_object

lemma of_is_bilimit {b : binary_bicone X Y} (h : b.is_bilimit) :
  is_pullback b.fst b.snd (0 : X ⟶ 0) (0 : Y ⟶ 0) :=
by convert is_pullback.of_is_product' h.is_limit has_zero_object.zero_is_terminal

@[simp] lemma of_has_biproduct (X Y : C) [has_binary_biproduct X Y] :
  is_pullback biprod.fst biprod.snd (0 : X ⟶ 0) (0 : Y ⟶ 0) :=
of_is_bilimit (binary_biproduct.is_bilimit X Y)

lemma inl_snd' {b : binary_bicone X Y} (h : b.is_bilimit) :
  is_pullback b.inl (0 : X ⟶ 0) b.snd (0 : 0 ⟶ Y) :=
by { refine of_right _ (by simp) (of_is_bilimit h), simp, }

/--
The square
```
  X --inl--> X ⊞ Y
  |            |
  0           snd
  |            |
  v            v
  0 ---0-----> Y
```
is a pullback square.
-/
@[simp] lemma inl_snd (X Y : C) [has_binary_biproduct X Y] :
  is_pullback biprod.inl (0 : X ⟶ 0) biprod.snd (0 : 0 ⟶ Y) :=
inl_snd' (binary_biproduct.is_bilimit X Y)

lemma inr_fst' {b : binary_bicone X Y} (h : b.is_bilimit) :
  is_pullback b.inr (0 : Y ⟶ 0) b.fst (0 : 0 ⟶ X) :=
by { apply flip, refine of_bot _ (by simp) (of_is_bilimit h), simp, }

/--
The square
```
  Y --inr--> X ⊞ Y
  |            |
  0           fst
  |            |
  v            v
  0 ---0-----> X
```
is a pullback square.
-/
@[simp] lemma inr_fst (X Y : C) [has_binary_biproduct X Y] :
  is_pullback biprod.inr (0 : Y ⟶ 0) biprod.fst (0 : 0 ⟶ X) :=
inr_fst' (binary_biproduct.is_bilimit X Y)

lemma of_is_bilimit' {b : binary_bicone X Y} (h : b.is_bilimit) :
  is_pullback (0 : 0 ⟶ X) (0 : 0 ⟶ Y) b.inl b.inr :=
by { refine is_pullback.of_right _ (by simp) (is_pullback.inl_snd' h).flip, simp, }

lemma of_has_binary_biproduct (X Y : C) [has_binary_biproduct X Y] :
  is_pullback (0 : 0 ⟶ X) (0 : 0 ⟶ Y) biprod.inl biprod.inr :=
of_is_bilimit' (binary_biproduct.is_bilimit X Y)

instance has_pullback_biprod_fst_biprod_snd [has_binary_biproduct X Y] :
  has_pullback (biprod.inl : X ⟶ _) (biprod.inr : Y ⟶ _) :=
has_limit.mk ⟨_, (of_has_binary_biproduct X Y).is_limit⟩

/-- The pullback of `biprod.inl` and `biprod.inr` is the zero object. -/
def pullback_biprod_inl_biprod_inr [has_binary_biproduct X Y] :
  pullback (biprod.inl : X ⟶ _) (biprod.inr : Y ⟶ _) ≅ 0 :=
limit.iso_limit_cone ⟨_, (of_has_binary_biproduct X Y).is_limit⟩

end

lemma op (h : is_pullback fst snd f g) : is_pushout g.op f.op snd.op fst.op :=
is_pushout.of_is_colimit (is_colimit.of_iso_colimit
  (limits.pullback_cone.is_limit_equiv_is_colimit_op h.flip.cone h.flip.is_limit)
  h.to_comm_sq.flip.cone_op)

lemma unop {P X Y Z : Cᵒᵖ} {fst : P ⟶ X} {snd : P ⟶ Y} {f : X ⟶ Z} {g : Y ⟶ Z}
  (h : is_pullback fst snd f g) : is_pushout g.unop f.unop snd.unop fst.unop :=
is_pushout.of_is_colimit (is_colimit.of_iso_colimit
  (limits.pullback_cone.is_limit_equiv_is_colimit_unop h.flip.cone h.flip.is_limit)
  h.to_comm_sq.flip.cone_unop)

lemma of_vert_is_iso [is_iso snd] [is_iso f] (sq : comm_sq fst snd f g) :
  is_pullback fst snd f g := is_pullback.flip (of_horiz_is_iso sq.flip)

end is_pullback

namespace is_pushout

variables {Z X Y P : C} {f : Z ⟶ X} {g : Z ⟶ Y} {inl : X ⟶ P} {inr : Y ⟶ P}

lemma flip (h : is_pushout f g inl inr) : is_pushout g f inr inl :=
of_is_colimit (@pushout_cocone.flip_is_colimit _ _ _ _ _ _ _ _ _ _ h.w.symm h.is_colimit)

lemma flip_iff : is_pushout f g inl inr ↔ is_pushout g f inr inl :=
⟨flip, flip⟩

section

variables [has_zero_object C] [has_zero_morphisms C]
open_locale zero_object

/-- The square with `0 : 0 ⟶ 0` on the right and `𝟙 X` on the left is a pushout square. -/
@[simp] lemma zero_right (X : C) : is_pushout (0 : X ⟶ 0) (𝟙 X) (0 : 0 ⟶ 0) (0 : X ⟶ 0) :=
{ w := by simp,
  is_colimit' :=
  ⟨{ desc := λ s, 0,
     fac' := λ s, begin
       have c := @pushout_cocone.coequalizer_ext _ _ _ _ _ _ _ s _ 0 (𝟙 _) (by simp)
         (by simpa using (pushout_cocone.condition s)),
      dsimp at c,
      simpa using c,
     end }⟩ }

/-- The square with `0 : 0 ⟶ 0` on the bottom and `𝟙 X` on the top is a pushout square. -/
@[simp] lemma zero_bot (X : C) : is_pushout (𝟙 X) (0 : X ⟶ 0) (0 : X ⟶ 0) (0 : 0 ⟶ 0) :=
(zero_right X).flip

/-- The square with `0 : 0 ⟶ 0` on the right left `𝟙 X` on the right is a pushout square. -/
@[simp] lemma zero_left (X : C) : is_pushout (0 : 0 ⟶ X) (0 : 0 ⟶ 0) (𝟙 X) (0 : 0 ⟶ X) :=
of_iso_pushout (by simp) ((coprod_zero_iso X).symm ≪≫ (pushout_zero_zero_iso _ _).symm)
  (by simp) (by simp)

/-- The square with `0 : 0 ⟶ 0` on the top and `𝟙 X` on the bottom is a pushout square. -/
@[simp] lemma zero_top (X : C) : is_pushout (0 : 0 ⟶ 0) (0 : 0 ⟶ X) (0 : 0 ⟶ X) (𝟙 X) :=
(zero_left X).flip

end

/-- Paste two pushout squares "vertically" to obtain another pushout square. -/
-- Objects here are arranged in a 3x2 grid, and indexed by their xy coordinates.
-- Morphisms are named `hᵢⱼ` for a horizontal morphism starting at `(i,j)`,
-- and `vᵢⱼ` for a vertical morphism starting at `(i,j)`.
lemma paste_vert {X₁₁ X₁₂ X₂₁ X₂₂ X₃₁ X₃₂ : C}
  {h₁₁ : X₁₁ ⟶ X₁₂} {h₂₁ : X₂₁ ⟶ X₂₂} {h₃₁ : X₃₁ ⟶ X₃₂}
  {v₁₁ : X₁₁ ⟶ X₂₁} {v₁₂ : X₁₂ ⟶ X₂₂} {v₂₁ : X₂₁ ⟶ X₃₁} {v₂₂ : X₂₂ ⟶ X₃₂}
  (s : is_pushout h₁₁ v₁₁ v₁₂ h₂₁) (t : is_pushout h₂₁ v₂₁ v₂₂ h₃₁) :
  is_pushout h₁₁ (v₁₁ ≫ v₂₁) (v₁₂ ≫ v₂₂) h₃₁ :=
(of_is_colimit
  (big_square_is_pushout _ _ _ _ _ _ _ s.w t.w t.is_colimit s.is_colimit))

/-- Paste two pushout squares "horizontally" to obtain another pushout square. -/
lemma paste_horiz {X₁₁ X₁₂ X₁₃ X₂₁ X₂₂ X₂₃ : C}
  {h₁₁ : X₁₁ ⟶ X₁₂} {h₁₂ : X₁₂ ⟶ X₁₃} {h₂₁ : X₂₁ ⟶ X₂₂} {h₂₂ : X₂₂ ⟶ X₂₃}
  {v₁₁ : X₁₁ ⟶ X₂₁} {v₁₂ : X₁₂ ⟶ X₂₂} {v₁₃ : X₁₃ ⟶ X₂₃}
  (s : is_pushout h₁₁ v₁₁ v₁₂ h₂₁) (t : is_pushout h₁₂ v₁₂ v₁₃ h₂₂) :
  is_pushout (h₁₁ ≫ h₁₂) v₁₁ v₁₃ (h₂₁ ≫ h₂₂) :=
(paste_vert s.flip t.flip).flip

/-- Given a pushout square assembled from a pushout square on the top and
a commuting square on the bottom, the bottom square is a pushout square. -/
lemma of_bot {X₁₁ X₁₂ X₂₁ X₂₂ X₃₁ X₃₂ : C}
  {h₁₁ : X₁₁ ⟶ X₁₂} {h₂₁ : X₂₁ ⟶ X₂₂} {h₃₁ : X₃₁ ⟶ X₃₂}
  {v₁₁ : X₁₁ ⟶ X₂₁} {v₁₂ : X₁₂ ⟶ X₂₂} {v₂₁ : X₂₁ ⟶ X₃₁} {v₂₂ : X₂₂ ⟶ X₃₂}
  (s : is_pushout h₁₁ (v₁₁ ≫ v₂₁) (v₁₂ ≫ v₂₂) h₃₁) (p : h₂₁ ≫ v₂₂ = v₂₁ ≫ h₃₁)
  (t : is_pushout h₁₁ v₁₁ v₁₂ h₂₁) :
  is_pushout h₂₁ v₂₁ v₂₂ h₃₁ :=
of_is_colimit (right_square_is_pushout _ _ _ _ _ _ _ _ p t.is_colimit s.is_colimit)

/-- Given a pushout square assembled from a pushout square on the left and
a commuting square on the right, the right square is a pushout square. -/
lemma of_right {X₁₁ X₁₂ X₁₃ X₂₁ X₂₂ X₂₃ : C}
  {h₁₁ : X₁₁ ⟶ X₁₂} {h₁₂ : X₁₂ ⟶ X₁₃} {h₂₁ : X₂₁ ⟶ X₂₂} {h₂₂ : X₂₂ ⟶ X₂₃}
  {v₁₁ : X₁₁ ⟶ X₂₁} {v₁₂ : X₁₂ ⟶ X₂₂} {v₁₃ : X₁₃ ⟶ X₂₃}
  (s : is_pushout (h₁₁ ≫ h₁₂) v₁₁ v₁₃ (h₂₁ ≫ h₂₂)) (p : h₁₂ ≫ v₁₃ = v₁₂ ≫ h₂₂)
  (t : is_pushout h₁₁ v₁₁ v₁₂ h₂₁) :
  is_pushout h₁₂ v₁₂ v₁₃ h₂₂ :=
(of_bot s.flip p.symm t.flip).flip

lemma paste_vert_iff {X₁₁ X₁₂ X₂₁ X₂₂ X₃₁ X₃₂ : C}
  {h₁₁ : X₁₁ ⟶ X₁₂} {h₂₁ : X₂₁ ⟶ X₂₂} {h₃₁ : X₃₁ ⟶ X₃₂}
  {v₁₁ : X₁₁ ⟶ X₂₁} {v₁₂ : X₁₂ ⟶ X₂₂} {v₂₁ : X₂₁ ⟶ X₃₁} {v₂₂ : X₂₂ ⟶ X₃₂}
  (s : is_pushout h₁₁ v₁₁ v₁₂ h₂₁) (e : h₂₁ ≫ v₂₂ = v₂₁ ≫ h₃₁) :
  is_pushout h₁₁ (v₁₁ ≫ v₂₁) (v₁₂ ≫ v₂₂) h₃₁ ↔ is_pushout h₂₁ v₂₁ v₂₂ h₃₁ :=
⟨λ h, h.of_bot e s, s.paste_vert⟩

lemma paste_horiz_iff {X₁₁ X₁₂ X₁₃ X₂₁ X₂₂ X₂₃ : C}
  {h₁₁ : X₁₁ ⟶ X₁₂} {h₁₂ : X₁₂ ⟶ X₁₃} {h₂₁ : X₂₁ ⟶ X₂₂} {h₂₂ : X₂₂ ⟶ X₂₃}
  {v₁₁ : X₁₁ ⟶ X₂₁} {v₁₂ : X₁₂ ⟶ X₂₂} {v₁₃ : X₁₃ ⟶ X₂₃}
  (s : is_pushout h₁₁ v₁₁ v₁₂ h₂₁) (e : h₁₂ ≫ v₁₃ = v₁₂ ≫ h₂₂) :
  is_pushout (h₁₁ ≫ h₁₂) v₁₁ v₁₃ (h₂₁ ≫ h₂₂) ↔ is_pushout h₁₂ v₁₂ v₁₃ h₂₂ :=
⟨λ h, h.of_right e s, s.paste_horiz⟩

section

variables [has_zero_object C] [has_zero_morphisms C]
open_locale zero_object

lemma of_is_bilimit {b : binary_bicone X Y} (h : b.is_bilimit) :
  is_pushout (0 : 0 ⟶ X) (0 : 0 ⟶ Y) b.inl b.inr :=
by convert is_pushout.of_is_coproduct' h.is_colimit has_zero_object.zero_is_initial

@[simp] lemma of_has_biproduct (X Y : C) [has_binary_biproduct X Y] :
  is_pushout (0 : 0 ⟶ X) (0 : 0 ⟶ Y) biprod.inl biprod.inr :=
of_is_bilimit (binary_biproduct.is_bilimit X Y)

lemma inl_snd' {b : binary_bicone X Y} (h : b.is_bilimit) :
  is_pushout b.inl (0 : X ⟶ 0) b.snd (0 : 0 ⟶ Y) :=
by { apply flip, refine of_right _ (by simp) (of_is_bilimit h), simp, }

/--
The square
```
  X --inl--> X ⊞ Y
  |            |
  0           snd
  |            |
  v            v
  0 ---0-----> Y
```
is a pushout square.
-/
lemma inl_snd (X Y : C) [has_binary_biproduct X Y] :
  is_pushout biprod.inl (0 : X ⟶ 0) biprod.snd (0 : 0 ⟶ Y) :=
inl_snd' (binary_biproduct.is_bilimit X Y)

lemma inr_fst' {b : binary_bicone X Y} (h : b.is_bilimit) :
  is_pushout b.inr (0 : Y ⟶ 0) b.fst (0 : 0 ⟶ X) :=
by { refine of_bot _ (by simp) (of_is_bilimit h), simp, }

/--
The square
```
  Y --inr--> X ⊞ Y
  |            |
  0           fst
  |            |
  v            v
  0 ---0-----> X
```
is a pushout square.
-/
lemma inr_fst (X Y : C) [has_binary_biproduct X Y] :
  is_pushout biprod.inr (0 : Y ⟶ 0) biprod.fst (0 : 0 ⟶ X) :=
inr_fst' (binary_biproduct.is_bilimit X Y)

lemma of_is_bilimit' {b : binary_bicone X Y} (h : b.is_bilimit) :
  is_pushout b.fst b.snd (0 : X ⟶ 0) (0 : Y ⟶ 0) :=
by { refine is_pushout.of_right _ (by simp) (is_pushout.inl_snd' h), simp, }

lemma of_has_binary_biproduct (X Y : C) [has_binary_biproduct X Y] :
  is_pushout biprod.fst biprod.snd (0 : X ⟶ 0) (0 : Y ⟶ 0) :=
of_is_bilimit' (binary_biproduct.is_bilimit X Y)

instance has_pushout_biprod_fst_biprod_snd [has_binary_biproduct X Y] :
  has_pushout (biprod.fst : _ ⟶ X) (biprod.snd : _ ⟶ Y) :=
has_colimit.mk ⟨_, (of_has_binary_biproduct X Y).is_colimit⟩

/-- The pushout of `biprod.fst` and `biprod.snd` is the zero object. -/
def pushout_biprod_fst_biprod_snd [has_binary_biproduct X Y] :
  pushout (biprod.fst : _ ⟶ X) (biprod.snd : _ ⟶ Y) ≅ 0 :=
colimit.iso_colimit_cocone ⟨_, (of_has_binary_biproduct X Y).is_colimit⟩

end

lemma op (h : is_pushout f g inl inr) : is_pullback inr.op inl.op g.op f.op :=
is_pullback.of_is_limit (is_limit.of_iso_limit
  (limits.pushout_cocone.is_colimit_equiv_is_limit_op h.flip.cocone h.flip.is_colimit)
  h.to_comm_sq.flip.cocone_op)

lemma unop {Z X Y P : Cᵒᵖ} {f : Z ⟶ X} {g : Z ⟶ Y} {inl : X ⟶ P} {inr : Y ⟶ P}
  (h : is_pushout f g inl inr) : is_pullback inr.unop inl.unop g.unop f.unop :=
is_pullback.of_is_limit (is_limit.of_iso_limit
  (limits.pushout_cocone.is_colimit_equiv_is_limit_unop h.flip.cocone h.flip.is_colimit)
  h.to_comm_sq.flip.cocone_unop)

lemma of_horiz_is_iso [is_iso f] [is_iso inr] (sq : comm_sq f g inl inr) :
  is_pushout f g inl inr := of_is_colimit' sq
begin
  refine pushout_cocone.is_colimit.mk _ (λ s, inv inr ≫ s.inr) (λ s, _) (by tidy) (by tidy),
  simp only [← cancel_epi f, s.condition, sq.w_assoc, is_iso.hom_inv_id_assoc],
end

lemma of_vert_is_iso [is_iso g] [is_iso inl] (sq : comm_sq f g inl inr) :
  is_pushout f g inl inr := (of_horiz_is_iso sq.flip).flip

end is_pushout

section equalizer

variables {X Y Z : C} {f f' : X ⟶ Y} {g g' : Y ⟶ Z}

/-- If `f : X ⟶ Y`, `g g' : Y ⟶ Z` forms a pullback square, then `f` is the equalizer of
`g` and `g'`. -/
noncomputable
def is_pullback.is_limit_fork (H : is_pullback f f g g') :
  is_limit (fork.of_ι f H.w) :=
begin
  fapply fork.is_limit.mk,
  { exact λ s, H.is_limit.lift (pullback_cone.mk s.ι s.ι s.condition) },
  { exact λ s, H.is_limit.fac _ walking_cospan.left },
  { intros s m e, apply pullback_cone.is_limit.hom_ext H.is_limit; refine e.trans _;
      symmetry; exact H.is_limit.fac _ _ }
end

/-- If `f f' : X ⟶ Y`, `g : Y ⟶ Z` forms a pushout square, then `g` is the coequalizer of
`f` and `f'`. -/
noncomputable
def is_pushout.is_limit_fork (H : is_pushout f f' g g) :
  is_colimit (cofork.of_π g H.w) :=
begin
  fapply cofork.is_colimit.mk,
  { exact λ s, H.is_colimit.desc (pushout_cocone.mk s.π s.π s.condition) },
  { exact λ s, H.is_colimit.fac _ walking_span.left },
  { intros s m e, apply pushout_cocone.is_colimit.hom_ext H.is_colimit; refine e.trans _;
      symmetry; exact H.is_colimit.fac _ _ }
end

end equalizer

namespace bicartesian_sq

variables {W X Y Z : C} {f : W ⟶ X} {g : W ⟶ Y} {h : X ⟶ Z} {i : Y ⟶ Z}

lemma of_is_pullback_is_pushout (p₁ : is_pullback f g h i) (p₂ : is_pushout f g h i) :
  bicartesian_sq f g h i :=
bicartesian_sq.mk p₁.to_comm_sq ⟨p₁.is_limit⟩ ⟨p₂.is_colimit⟩

lemma flip (p : bicartesian_sq f g h i) : bicartesian_sq g f i h :=
of_is_pullback_is_pushout p.to_is_pullback.flip p.to_is_pushout.flip

variables [has_zero_object C] [has_zero_morphisms C]
open_locale zero_object

/--
```
 X ⊞ Y --fst--> X
   |            |
  snd           0
   |            |
   v            v
   Y -----0---> 0
```
is a bicartesian square.
-/
lemma of_is_biproduct₁ {b : binary_bicone X Y} (h : b.is_bilimit) :
  bicartesian_sq b.fst b.snd (0 : X ⟶ 0) (0 : Y ⟶ 0) :=
of_is_pullback_is_pushout (is_pullback.of_is_bilimit h) (is_pushout.of_is_bilimit' h)

/--
```
   0 -----0---> X
   |            |
   0           inl
   |            |
   v            v
   Y --inr--> X ⊞ Y
```
is a bicartesian square.
-/
lemma of_is_biproduct₂ {b : binary_bicone X Y} (h : b.is_bilimit) :
  bicartesian_sq (0 : 0 ⟶ X) (0 : 0 ⟶ Y) b.inl b.inr :=
of_is_pullback_is_pushout (is_pullback.of_is_bilimit' h) (is_pushout.of_is_bilimit h)

/--
```
 X ⊞ Y --fst--> X
   |            |
  snd           0
   |            |
   v            v
   Y -----0---> 0
```
is a bicartesian square.
-/
@[simp] lemma of_has_biproduct₁ [has_binary_biproduct X Y] :
  bicartesian_sq biprod.fst biprod.snd (0 : X ⟶ 0) (0 : Y ⟶ 0) :=
by convert of_is_biproduct₁ (binary_biproduct.is_bilimit X Y)

/--
```
   0 -----0---> X
   |            |
   0           inl
   |            |
   v            v
   Y --inr--> X ⊞ Y
```
is a bicartesian square.
-/
@[simp] lemma of_has_biproduct₂ [has_binary_biproduct X Y] :
  bicartesian_sq (0 : 0 ⟶ X) (0 : 0 ⟶ Y) biprod.inl biprod.inr :=
by convert of_is_biproduct₂ (binary_biproduct.is_bilimit X Y)

end bicartesian_sq

section functor

variables {D : Type u₂} [category.{v₂} D]
variables (F : C ⥤ D) {W X Y Z : C} {f : W ⟶ X} {g : W ⟶ Y} {h : X ⟶ Z} {i : Y ⟶ Z}

lemma functor.map_is_pullback [preserves_limit (cospan h i) F] (s : is_pullback f g h i) :
  is_pullback (F.map f) (F.map g) (F.map h) (F.map i) :=
-- This is made slightly awkward because `C` and `D` have different universes,
-- and so the relevant `walking_cospan` diagrams live in different universes too!
begin
  refine is_pullback.of_is_limit' (F.map_comm_sq s.to_comm_sq)
    (is_limit.equiv_of_nat_iso_of_iso (cospan_comp_iso F h i) _ _ (walking_cospan.ext _ _ _)
      (is_limit_of_preserves F s.is_limit)),
  { refl, },
  { dsimp, simp, },
  { dsimp, simp, },
end

lemma functor.map_is_pushout [preserves_colimit (span f g) F] (s : is_pushout f g h i) :
  is_pushout (F.map f) (F.map g) (F.map h) (F.map i) :=
begin
  refine is_pushout.of_is_colimit' (F.map_comm_sq s.to_comm_sq)
    (is_colimit.equiv_of_nat_iso_of_iso (span_comp_iso F f g) _ _ (walking_span.ext _ _ _)
      (is_colimit_of_preserves F s.is_colimit)),
  { refl, },
  { dsimp, simp, },
  { dsimp, simp, },
end

alias functor.map_is_pullback ← is_pullback.map
alias functor.map_is_pushout ← is_pushout.map

lemma is_pullback.of_map [reflects_limit (cospan h i) F] (e : f ≫ h = g ≫ i)
  (H : is_pullback (F.map f) (F.map g) (F.map h) (F.map i)) : is_pullback f g h i :=
begin
  refine ⟨⟨e⟩, ⟨is_limit_of_reflects F $ _⟩⟩,
  refine (is_limit.equiv_of_nat_iso_of_iso (cospan_comp_iso F h i) _ _
    (walking_cospan.ext _ _ _)).symm H.is_limit,
  exacts [iso.refl _, (category.comp_id _).trans (category.id_comp _).symm,
    (category.comp_id _).trans (category.id_comp _).symm]
end

lemma is_pullback.of_map_of_faithful [reflects_limit (cospan h i) F] [faithful F]
  (H : is_pullback (F.map f) (F.map g) (F.map h) (F.map i)) : is_pullback f g h i :=
H.of_map F (F.map_injective $ by simpa only [F.map_comp] using H.w)

lemma is_pushout.of_map [reflects_colimit (span f g) F] (e : f ≫ h = g ≫ i)
  (H : is_pushout (F.map f) (F.map g) (F.map h) (F.map i)) : is_pushout f g h i :=
begin
  refine ⟨⟨e⟩, ⟨is_colimit_of_reflects F $ _⟩⟩,
  refine (is_colimit.equiv_of_nat_iso_of_iso (span_comp_iso F f g) _ _
    (walking_span.ext _ _ _)).symm H.is_colimit,
  exacts [iso.refl _, (category.comp_id _).trans (category.id_comp _),
    (category.comp_id _).trans (category.id_comp _)]
end

lemma is_pushout.of_map_of_faithful [reflects_colimit (span f g) F] [faithful F]
  (H : is_pushout (F.map f) (F.map g) (F.map h) (F.map i)) : is_pushout f g h i :=
H.of_map F (F.map_injective $ by simpa only [F.map_comp] using H.w)

lemma is_pushout.map_iff {D : Type*} [category D] (F : C ⥤ D)
  [preserves_colimit (span f g) F] [reflects_colimit (span f g) F] (e : f ≫ h = g ≫ i) :
  is_pushout (F.map f) (F.map g) (F.map h) (F.map i) ↔ is_pushout f g h i  :=
⟨λ h, h.of_map F e, λ h, h.map F⟩

end functor

end category_theory


import data.stream

import unitb.category
import unitb.logic.safety

import util.logic
import util.meta.expr
import util.meta.tactic
import util.predicate

import temporal_logic

universe variables u v

namespace unitb

local attribute [instance] classical.prop_decidable

section connectors

open predicate

class system (α : Type u) extends has_safety α : Type (u+1) :=
   (transient : α → pred' σ → pred' σ → Prop)
   (init : α → pred' σ → Prop)
   (transient_false : ∀ {s} (p : pred' σ), transient s p False)
   (transient_antimono : ∀ {s : α} {p q p' q' : pred' σ},
         (p' ⟹ p) →
         (q' ⟹ q) →
         transient s p q →
         transient s p' q' )

parameters (α : Type u) [system α] (s : α)

def system.state := has_safety.σ α

parameters {α}

def transient (p : pred' (state α)) : Prop :=
system.transient s True p

def transient' (p q : pred' (state α)) : Prop :=
system.transient s p q

lemma system.transient_str {p q r : pred' (state α)}
  (H : r ⟹ q)
: transient' p q → transient' p r :=
system.transient_antimono (by refl) H

def init (p : pred' (state α)) : Prop :=
system.init s p

inductive leads_to : pred' (state α) → pred' (state α) → Prop
  | trivial {} : ∀ {p}, leads_to p True
  | basis' : ∀ {p q : pred' (state α)} r,
          transient' r (p ⋀ - q) →
          unless s p q →
          leads_to (p ⋀ -q) (r ⋁ q) →
          leads_to p q
  | trans : ∀ {p} q {r}, leads_to p q → leads_to q r → leads_to p r
  | disj : ∀ (t : Type u) (p : t → pred' (state α)) {q},
         (∀ i, leads_to (p i) q) →
         leads_to (∃∃ i, p i) q

attribute [trans] leads_to.trans

local notation x ` ↦ `:60 y ` in ` s := leads_to x y

inductive often_imp_often : pred' (state α) → pred' (state α) → Prop
  | transient : ∀ {p q}, transient' p (-q) → often_imp_often p q
  | trans : ∀ {p} q {r}, often_imp_often p q →
                         often_imp_often q r →
                         often_imp_often p r
  | disj : ∀ {p q r}, often_imp_often p r →
                      often_imp_often q r →
                      often_imp_often (p ⋁ q) r
  | induct : ∀ (t : Type) (V : var (state α) t) [has_well_founded t]
         {p q}
         (P : ∀ v : t, p ⋀ V ≃ v  ↦  V ≺≺ v ⋁ q  in  s)
         (S : ∀ v : t, unless s (V ≃ v) (V ≺≺ v ⋁ q)),
         often_imp_often p q

attribute [trans] often_imp_often.trans

end connectors

notation x `  ↦  `:60 y ` in ` s := leads_to s x y
notation x `  >~>  `:60 y ` in ` s := often_imp_often s x y

section conversion

parameter {α  : Type u}
parameter {α' : Type u}
parameter [system α]
parameter [system α']
parameter (f : state α' → state α)
parameters (s : α) (s' : α')
parameter (Tf : ∀ {p q}, transient' s p q → transient' s' (p ∘' f) (q ∘' f))
parameter (Uf : ∀ {p q}, unless s p q → unless s' (p ∘' f) (q ∘' f))

include Tf Uf

lemma leads_to.subst {p q}
  (H : p ↦ q in s)
: (p ∘' f) ↦ (q ∘' f) in s' :=
begin
  induction H,
  case leads_to.trivial p
  { apply leads_to.trivial },
  case leads_to.basis' p q b t u P₀ P₁
  { apply leads_to.basis' (b ∘' ↑f),
    { specialize Tf t, simp at Tf, apply Tf, },
    { apply Uf u },
    { simp at P₁, simp [P₁], }, },
  case leads_to.trans p q r Pa₀ Pa₁ Pb₀ Pb₁
  { apply leads_to.trans (q '∘ f) Pb₀ Pb₁, },
  case leads_to.disj t p q Pa Pb
  { simp, apply leads_to.disj t (λ x, p x '∘ f),
    intro, apply Pb, },
end
open predicate

lemma often_imp_often.subst {p q}
  (H : p >~> q in s)
: (p ∘' f) >~> (q ∘' f) in s' :=
begin
  induction H,
  case often_imp_often.transient p q T
  { specialize Tf T, simp at Tf,
    apply often_imp_often.transient Tf },
  case often_imp_often.trans p q r _ _ Pb₀ Pb₁
  { apply often_imp_often.trans _ Pb₀ Pb₁ },
  case often_imp_often.induct t V _inst_3 p q P S
  { apply often_imp_often.induct t (V ∘' ↑f),
    { intro v, have := leads_to.subst f s s' @Tf @Uf (P v),
      simp at this, apply this },
    { intro v, specialize Uf (S v),
      simp at Uf, apply Uf } },
  case often_imp_often.disj p q r P₀ P₁
  { have := often_imp_often.disj ih_1 ih_2, simp [this] }
end

end conversion

open predicate

section rules

parameters {α : Type u} [system α]
parameter {s : α}

lemma leads_to.basis {p q : pred' (state α)}
  (h₀ : transient s (p ⋀ - q))
  (h₁ : unless s p q)
: leads_to s p q :=
begin
  apply leads_to.basis' _ h₀ h₁,
  rw True_p_or, apply leads_to.trivial
end

parameter s

theorem leads_to.imp {p q : pred' (state α)}
   (h : p ⟹ q)
   : p ↦ q in s :=
begin
  apply leads_to.basis,
  { have h' : (p ⋀ -q) = False,
    { lifted_pred [not_not_iff_self] using h,
      assumption, },
    rw h',
    apply system.transient_false },
  apply unless_imp h
end

@[refl]
theorem leads_to_refl {p : pred' (state α)}
: p ↦ p in s :=
by { apply leads_to.imp, refl }

parameter {s}

instance category_leads_to : disjunctive (leads_to s) :=
  { ident := @leads_to_refl
  , comp := λ p q r P₀ P₁, leads_to.trans _ P₁ P₀
  , assoc := by { intros, refl }
  , left_ident := by { intros, refl }
  , disj' := @leads_to.disj _ _ _
  , right_ident := by { intros, refl }
  , imp := @leads_to.imp
  , imp_comp_imp_eq_imp_trans := by { intros, refl }
  , imp_self_eq_ident := by { intros, refl }
  , disj_imp_imp := by { intros, refl }
  , select_left_disj := by { intros, refl }
  , comp_over_disj_right := by { intros, refl }
  , disj_flip := by { intros, refl } }

theorem leads_to.antimono_left (q : pred' (state α)) {p r : pred' (state α)}
  (H  : p ⟹ q)
  (P₀ : q  ↦ r in s)
: p ↦ r in s :=
unitb.antimono_left _ _ H P₀

theorem leads_to.mono_right
  (q : pred' (state α)) {p r : pred' (state α)}
  (H  : q ⟹ r)
  (P₀ : p  ↦ q in s)
: p ↦ r in s :=
lifted_pred.mono_right _ _ H P₀

theorem leads_to.monotonicity
  {p p' q q' : pred' (state α)}
  (Hp : p' ⟹ p)
  (Hq : q  ⟹ q')
  (P₀ : p  ↦ q in s)
: p' ↦ q' in s :=
monotonicity _ Hp Hq P₀

lemma leads_to.disj_rng {t : Type u} {p : t → pred' (state α)} {q} {r : t → Prop}
  (h : ∀ i, r i → p i ↦ q in s)
: (∃∃ i, (r i) ⋀ p i) ↦ q in s :=
unitb.disj_rng _ h

theorem leads_to.disj' {p q r : pred' (state α)}
  (Pp : p ↦ r in s)
  (Pq : q ↦ r in s)
: p ⋁ q ↦ r in s :=
finite_disjunctive.disj _ Pp Pq

theorem leads_to.gen_disj {p q r₀ r₁ : pred' (state α)}
  (Pp : p ↦ r₀ in s)
  (Pq : q ↦ r₁ in s)
: p ⋁ q ↦ r₀ ⋁ r₁ in s :=
unitb.gen_disj _ Pp Pq

theorem leads_to.gen_disj' {t : Type u} {p q : t → pred' (state α)}
  (P : ∀ x, p x ↦ q x in s)
: (∃∃ x, p x) ↦ (∃∃ x, q x) in s :=
unitb.gen_disj' _ P

theorem leads_to.cancellation
  {p : pred' (state α)} (q : pred' (state α))
  {r b : pred' (state α)}
  (P₀ : p ↦ q ⋁ b in s)
  (P₁ : q ↦ r ⋁ b in s)
: p ↦ r ⋁ b in s :=
unitb.cancellation _ q P₀ P₁

theorem leads_to.cancellation'
  {p : pred' (state α)} (q : pred' (state α))
  {r b : pred' (state α)}
  (P₀ : p ↦ q ⋁ b in s)
  (P₁ : q ↦ r in s)
: p ↦ r ⋁ b in s :=
unitb.cancellation' _ q P₀ P₁

theorem leads_to.induction' {β : Type u}
  [has_well_founded β]
  (V : var (state α) β)
  {p q : pred' (state α)}
  (P : ∀ v : β, p ⋀ V ≃ v  ↦  p ⋀ V ≺≺ v ⋁ q  in  s)
: p ↦ q in s :=
unitb.induction _ V P

def rel : Type u := state α → state α → Prop

theorem leads_to.PSP {p q r b : pred' (state α)}
  (P : p ↦ q in s)
  (S : unless s r b)
: p ⋀ r  ↦  (q ⋀ r) ⋁ b in s :=
begin
  induction P with p p₀ q₀ b₀ t₀ u₀ P PSP₀
         p₁ q₁ r₁ PP₀ PP₁,
  { apply leads_to.imp,
    apply p_and_entails_of_entails_right,
    apply entails_p_or_of_entails_left,
    simp, },
  { apply leads_to.basis' b₀,
    { apply system.transient_str _ _ t₀,
      lifted_pred, begin [smt] intros end },
    { have H : unless s r (r ⋁ b),
      { apply unless_imp, propositional, },
      have H' : unless s p₀ (q₀ ⋁ b),
      { apply unless_weak_rhs _ u₀,
        propositional },
      have H'' := unless_conj_gen u₀ S,
      apply unless_weak_rhs _ H'',
      lifted_pred, begin [smt] intros, break_asms, end },
    { apply leads_to.monotonicity _ _ PSP₀,
      { lifted_pred, begin [smt] intros, end },
      { lifted_pred, begin [smt] intros, break_asms end }, } },
  { have H := leads_to.cancellation _ ih_1 ih_2,
    apply H },
  { apply leads_to.antimono_left (∃∃i, p_1 i ⋀ r),
    { lifted_pred only [p_and_over_p_exists_right],
      exact id, },
    apply leads_to.disj, intro i,
    apply ih_1 i, },
end

lemma leads_to.trading {p q r : pred' (state α)}
  (P : p ⋀ -q ↦ r in s)
: p ↦ q ⋁ r in s :=
begin
  have P₀ : p ⋀ q ↦ q in s,
  { apply leads_to.imp,
    apply p_and_elim_right },
  have P₁ := leads_to.gen_disj P₀ P,
  rw [←  p_and_over_or_left] at P₁,
  simp at P₁,
  apply P₁,
end

lemma True_leads_to_True
: True ↦ True in s :=
leads_to.trivial

lemma leads_to.completion_a {p p' q q' : pred' (state α)} {b : pred' (state α)}
  (P₀ : p  ↦ q  in s)
  (P₁ : p' ↦ q' in s)
  (S₀ : unless s q  b)
  (S₁ : unless s q' b)
: p ⋀ p' ↦ (q ⋀ q') ⋁ b in s :=
begin
  revert p' q' b,
  induction P₀
  ; intros p' q' b P₁ S₀ S₁,
  case leads_to.trivial p₀
  { apply leads_to.monotonicity _ _ P₁,
    { propositional, },
    { propositional, }, },
  case leads_to.basis' p₀ q₀ b₀ T S₂ P₂
  { -- have P₃ : p₀ ⋀ p' ↦ _ in s,
    apply leads_to.basis' (b₀ ⋀ q'),
    { apply system.transient_antimono _ _ T,
      { propositional, },
      { lifted_pred [p_not_p_and,p_not_p_or],
        intros, split,
        -- by_contradiction,
        -- classical_simp,
        { begin [smt] intros, end },
        { admit }, } },
    { admit },
    { admit }, },
  case leads_to.trans pp qq rr P₂ P₃
  { rw [← p_or_self b,p_or_assoc],
    have H' : pp ⋀ p'  ↦  rr ⋀ q' ⋁ b ⋁ b in s,
    { apply leads_to.cancellation' (qq ⋀ q'),
      { have h : qq ⋀ q' ⋁ b = qq ⋀ q' ⋁ (qq ⋀ q' ⋁ b),
        { admit },
        rw h,
        apply ih_1,
        { apply P₁ },
        { apply unless_imp, admit, },
        { apply unless_weak_rhs _ S₁,
          propositional, }, },
      { apply ih_2,
        { refl },
        { apply S₀ },
        { apply S₁ }, } },
    apply leads_to.mono_right _ _ H',
    propositional, },
  case leads_to.disj t pp qq P₂
  { rw p_and_over_p_exists_right,
    apply leads_to.disj,
    intro i, apply ih_1 _ P₁ S₀ S₁, }
end

lemma leads_to.completion_b {p p' q q' : pred' (state α)} {b : pred' (state α)}
  (P₀ : p  ↦ q  ⋁ b in s)
  (P₁ : p' ↦ q' ⋁ b in s)
  (S₀ : unless s q  b)
  (S₁ : unless s q' b)
: p ⋀ p' ↦ (q ⋀ q') ⋁ b in s :=
begin
  have H : unless s b b := unless_refl _,
  have H₀ : unless s (q  ⋁ b) b,
  { have H' := unless_disj' S₀ H,
    simp at H', apply H', },
  have H₁ : unless s (q' ⋁ b) b,
  { have H' := unless_disj' S₁ H,
    simp at H', apply H', },
  have H₂ : p ⋀ p' ↦ ( (q ⋁ b) ⋀ (q' ⋁ b) ) ⋁ b in s,
  { apply leads_to.completion_a P₀ P₁ H₀ H₁, },
  apply leads_to.mono_right _ _ H₂,
  { lifted_pred,
    begin [smt] intros, break_asms, end },
end

lemma leads_to.completion {n : ℕ} {p q : fin n → pred' (state α)} {b : pred' (state α)}
  (P : ∀ i, p i ↦ q i ⋁ b in s)
  (S : ∀ i, unless s (q i) b)
: (∀∀ i, p i) ↦ (∀∀ i, q i) ⋁ b in s :=
begin
  revert p q,
  induction n with n IH ; intros p q P S,
  { simp [p_forall_fin_zero] },
  { simp [p_forall_split_one],
    apply leads_to.completion_b,
    { apply P },
    { apply IH,
      { intro, apply P },
      { intro, apply S }, },
    { apply S },
    { apply forall_unless,
      intro, apply S }, },
end
open predicate

lemma often_imp_often.basis {p q}
  (h : p ↦ q in s)
: p >~> q in s :=
begin
  let V : var (state α) unit := ↑(),
  have H : ∀ (v : unit), V ≺≺ ↑v = @False (state α),
  { intros, lifted_pred [V], rw unit_eq_unit v,
    intro h, cases nat.lt_irrefl _ h, },
  have H' : ∀ (v : unit), V ≃ v = @True (state α),
  { intros, lifted_pred [V],
    rw [unit_eq_unit v], },
  apply often_imp_often.induct _ V _
  ; intro
  ; simp [H,H',h],
end

@[refl]
lemma often_imp_often_refl {p}
: p >~> p in s :=
begin
  apply often_imp_often.basis,
  refl
end

lemma often_imp_often.imp {p q}
  (H : p ⟹ q)
: p >~> q in s :=
by { apply often_imp_often.basis, apply leads_to.imp _ H, }

lemma True_often_imp_often_True
: True >~> True in s :=
by refl

instance often_imp_often_fin_disj : finite_disjunctive (often_imp_often s) :=
 { ident := by { intro, refl }
 , comp  := by { introv h₀ h₁, apply often_imp_often.trans _ h₁ h₀ }
 , left_ident  := by { intros, refl }
 , right_ident := by { intros, refl }
 , assoc := by { intros, refl }
 , imp :=
   begin
     introv P,
     apply often_imp_often.imp P,
   end
 , imp_self_eq_ident := by { intros, refl }
 , imp_comp_imp_eq_imp_trans := by { intros, refl }
 , disj := @often_imp_often.disj _ _ s
 , disj_flip := by { intros, refl }
 , disj_imp_imp := by { intros, refl }
 , select_left_disj := by { intros, refl }
 , comp_over_disj_right := by { intros, refl } }
end rules

open predicate temporal

class system_sem (α : Type u) extends system α :=
  (ex : α → cpred _)
  (safety : ∀ s, ex s ⟹ saf_ex s)
  (inhabited : ∀s, ∃τ, τ ⊨ ex s)
  (init_sem : ∀ {s : α} {Γ p : pred' _},
         Γ ⊢ ex s →
         init s p →
         Γ ⊢ •p)
  (transient_sem : ∀ {s : α} {Γ p q : pred' _},
         Γ ⊢ ex s →
         transient' s p q →
         Γ ⊢ ◻◇•p ⟶ ◻◇-•q)

namespace system_sem

variables {α : Type u}

open temporal

section

variable [system_sem α]

lemma leads_to_sem {s : α} {p q : pred' (state α)}
    {Γ : cpred _}
    (P : p ↦ q in s)
    (sem : Γ ⊢ ex s)
: Γ ⊢ •p ~> •q :=
begin [temporal]
  have saf : saf_ex s := system_sem.safety s Γ sem,
  induction P ,
  case leads_to.trivial
  { apply temporal.leads_to_of_inf_often, simp, },
  case leads_to.basis' p q b T S B Bsem
  { have := transient_sem sem T,
    clear sem,
    henceforth,
    intros hp,
    have saf' : _ ⋁ _ := unless_sem saf S hp,
    cases saf' with saf' saf',
    { have T' : ◻◇-•(p ⋀ -q),
      { rw [← p_or_self (◻◇-•(p ⋀ -q))],
        focus_left with h, simp [p_not_p_not_iff_self] at h,
        suffices : ◻◇-•(p ⋀ -q) ⋁ ◻◇•q,
        { cases this with this this ; revert this
          ; persistent ; monotonicity
          ; lifted_pred,
          show _, { intros, auto } },
        focusing_left
        { apply this _,  clear this },
        rw ← inf_often_p_or,
        simp at Bsem,
        replace h : (◻◇(•p ⋀ -•q)) := inf_often_of_stable (•p ⋀ -•q) Γ h,
        apply inf_often_of_leads_to Bsem h, },
      have T'' := (coincidence' saf' T'),
      henceforth at T'', revert T'', persistent,
      monotonicity, lifted_pred,
      show _, { intros, auto } },
    { assumption, } },
  case leads_to.trans p q r P₀ P₁ H₀ H₁
  { apply leads_to_trans H₀ H₁ },
  case leads_to.disj X p' q' P₀ H₀ x y z
  { clear sem,
    henceforth,
    rw [init_exists,p_exists_p_imp ],
    intros x hp,
    apply H₀ x hp, }
end

end

section

variable [system_sem α]

lemma often_imp_often_sem'
    {s : α}
    {Γ : cpred _}
  {p q : pred' (state α)}
  (P : p >~> q in s)
  (sem : Γ ⊢ ex s)
: Γ ⊢ ◻◇•p ⟶ ◻◇•q :=
begin [temporal]
  induction P,
  case often_imp_often.transient p q T
  { have Tsem : ◻◇•p ⟶ ◻◇-•-q
              := system_sem.transient_sem sem T,
    rw [not_init,p_not_p_not_iff_self] at Tsem },
  case often_imp_often.trans p q r P₀ P₁ Lpq Lqr
  { intro Hp,
    apply Lqr (Lpq Hp) },
  case often_imp_often.induct  t V wf p q P₀ S₀
  { apply inf_often_induction' (V : var (state α) t) p q,
    { intros v h,
      apply unless_sem_str _ (S₀ v) h,
      apply system_sem.safety s Γ sem, },
    { intro v,
      apply leads_to_sem (P₀ v) sem, } },
  case often_imp_often.disj p q r P₀ P₁
  { intros H,
    rw [init_p_or,inf_often_p_or] at H,
    cases H with H H,
    { apply ih_1 H },
    { apply ih_2 H } }
end

end

end system_sem

end unitb


/- import mcl
import mcl_rhl
import parlang
import syncablep
import use_cases.assign_mcl
import use_cases.assign_mcl.def

open mcl
open mcl.mclk
open mcl.rhl
open parlang
open parlang.state
open parlang.thread_state
open assign_mcl

namespace assign_mcl
namespace proof1

lemma store_access_elim_idx {sig : signature} {n n_idx} {s : state n (memory $ parlang_mcl_tlocal sig) (parlang_mcl_shared sig)} {var} {idx : vector (expression sig type.int) n_idx}
{t} {h₄ : ((sig.val var).type).dim = n_idx} {h₃ : type_of (sig.val var) = t } {f} {t : fin n} {i : mcl_address sig} {ac₁ : vector bool n} {updates}
(h₂ : i.2.to_list ≠ (idx.map ((eval (((map_active_threads ac₁ (compute_list updates) s).threads).nth t).tlocal))).to_list)
(h₁ : i ∉ accesses (vector.nth ((map_active_threads ac₁ (f ∘ compute_list updates) s).threads) t)) :
i ∉ accesses (vector.nth ((map_active_threads ac₁ (f ∘ (thread_state.tlocal_to_shared var idx h₃ h₄) ∘ compute_list updates) s).threads) t) := begin
    sorry,
end

lemma store_access_elim_idx' {sig : signature} {n n_idx} {s : state n (memory $ parlang_mcl_tlocal sig) (parlang_mcl_shared sig)} {var} {idx : vector (expression sig type.int) n_idx}
{t} {h₄ : ((sig.val var).type).dim = n_idx} {h₃ : type_of (sig.val var) = t } {t : fin n} {i : mcl_address sig} {ac₁ : vector bool n} {updates}
(h₂ : i.2.to_list ≠ (idx.map ((eval (((map_active_threads ac₁ (compute_list updates) s).threads).nth t).tlocal ))).to_list)
(h₁ : i ∉ accesses (vector.nth (s.threads) t)) :
i ∉ accesses (vector.nth ((map_active_threads ac₁ ((thread_state.tlocal_to_shared var idx h₃ h₄) ∘ compute_list updates) s).threads) t) := begin
    sorry,
end

lemma store_store_success {sig : signature} {i : mcl_address sig} {updates} {ts : thread_state (memory $ parlang_mcl_tlocal sig) (parlang_mcl_shared sig)}
{dim} {idx : vector (expression sig type.int) dim} {var t} {h₁ : type_of (sig.val var) = t} {h₂ : ((sig.val var).type).dim = dim}
{f : thread_state (memory $ parlang_mcl_tlocal sig) (parlang_mcl_shared sig) → thread_state (memory $ parlang_mcl_tlocal sig) (parlang_mcl_shared sig)} :
i = ⟨var, vector_mpr h₂ (idx.map (eval (compute_list updates ts).tlocal))⟩ → i ∈ ((f ∘ thread_state.tlocal_to_shared var idx h₁ h₂ ∘ compute_list updates) ts).stores := by sorry

/-- Stores can be skipped if the variable name does not match. Does not work for idx -/
lemma store_store_skip_name {sig : signature} {i : mcl_address sig} {updates} {ts : thread_state (memory $ parlang_mcl_tlocal sig) (parlang_mcl_shared sig)}
{dim} {idx : vector (expression sig type.int) dim} {var t} {h₁ : type_of (sig.val var) = t} {h₂ : ((sig.val var).type).dim = dim}
{f : thread_state (memory $ parlang_mcl_tlocal sig) (parlang_mcl_shared sig) → thread_state (memory $ parlang_mcl_tlocal sig) (parlang_mcl_shared sig)} :
i ∈ ((f ∘ compute_list updates) ts).stores → i ∈ ((f ∘ thread_state.tlocal_to_shared var idx h₁ h₂ ∘ compute_list updates) ts).stores := by sorry

lemma access_init  {sig₁ sig₂ : signature} {P : memory (parlang_mcl_shared sig₁) → memory (parlang_mcl_shared sig₂) → Prop}
{f₁ : memory (parlang_mcl_shared sig₁) → ℕ} {f₂ : memory (parlang_mcl_shared sig₂) → ℕ} {m₁ : memory (parlang_mcl_shared sig₁)} {m₂ : memory (parlang_mcl_shared sig₂)}
{n₁} {s₁ : state n₁ (memory $ parlang_mcl_tlocal sig₁) (parlang_mcl_shared sig₁)} {ac₁ : vector bool n₁} {n₂} {s₂ : state n₂ (memory $ parlang_mcl_tlocal sig₂) (parlang_mcl_shared sig₂)} {ac₂ : vector bool n₂} {t} {i} :
initial_kernel_assertion mcl_init mcl_init P f₁ f₂ m₁ m₂ n₁ s₁ ac₁ n₂ s₂ ac₂ → i ∉ accesses (vector.nth (s₁.threads) t) := begin
    sorry
end

-- question: should we limit ourselfs to shared scope here?
/-- generic array access for cases-distinction. Covers all accesses with the same variable name and the right number of dimensions -/
structure array_access (sig : signature) (var : string) (i : mcl_address sig) : Prop :=
(var_eq : i.1 = var)
(idx_len : i.2.length = (sig.val var).type.dim)
-- (bound : list.forall₂ nat.lt i.2 (sig var).type.sizes.to_list)

/-- An extension of array_access. Restricts itself to arrays with one dimension and that index being less than n. n is usually used for the numer of threads to create a 1-to-1 mapping from threads to elements. Without shifting thread n stores to element n -/
structure array_access_tid_to_idx (sig : signature) (var : string) (i : mcl_address sig) (n : ℕ) extends array_access sig var i : Prop :=
(one_dim : i.2.length = 1)
(idx_1_lt_n : i.2.nth ⟨0, begin rw [var_eq, ←idx_len, one_dim], exact lt_zero_one end⟩ < n)

/-- Returns the thread identifier, which performs the store -/
def array_access_tid_to_idx.storing_tid {sig : signature} {var : string} {i : mcl_address sig} {n} (a : array_access_tid_to_idx sig var i n) :
fin n := ⟨i.2.nth ⟨0, begin rw [a.to_array_access.var_eq, ← a.to_array_access.idx_len, a.one_dim], exact lt_zero_one end⟩, a.idx_1_lt_n⟩

instance forall₂_decidable {α : Type} [decidable_eq α] (l₁ : list α) (l₂ : list α) : decidable (list.forall₂ eq l₁ l₂) := begin
    induction l₁ generalizing l₂,
    case list.nil {
        cases l₂,
        case list.nil {
            exact is_true (list.forall₂.nil)
        },
        case list.cons {
            exact is_false (begin
                intro h,
                cases h,
            end)
        }
    },
    case list.cons {
        cases l₂,
        case list.nil {
            exact is_false (begin
                intro h,
                cases h,
            end)
        },
        case list.cons {
            specialize l₁_ih l₂_tl,
            admit,
            -- by_cases h : l₁_hd = l₂_hd ∧ list.forall₂ eq l₁_tl l₂_tl,
            -- {
            --     exact is_true (begin
            --         apply list.forall₂.cons,
            --         exact h,
            --         apply l₁_ih,
            --     end)
            -- }
        }
    }
end

instance {sig var i} : decidable (array_access sig var i) :=
  if var_eq : i.1 = var then
    if idx_len : i.2.length = (sig.val var).type.dim then is_true ⟨var_eq, idx_len⟩
    --   if bound : list.forall₂ eq i.2 (sig var).type.sizes.to_list then is_true ⟨var_eq, idx_len, bound⟩
    --   else is_false (assume h : array_access sig var i, bound (array_access.bound h))
    else is_false (assume h : array_access sig var i, idx_len (array_access.idx_len h))
  else is_false (assume h : array_access sig var i, var_eq (array_access.var_eq h))

instance ll {sig var i n} : decidable (array_access_tid_to_idx sig var i n) := sorry

lemma store_shared_success {sig : signature} {i : mcl_address sig} {updates}
{dim} {idx : vector (expression sig type.int) dim} {var₁ var₂ t} {h₁ : type_of (sig.val var₂) = t} {h₂}
{ts : thread_state (memory $ parlang_mcl_tlocal sig) (parlang_mcl_shared sig)}
{f : thread_state (memory $ parlang_mcl_tlocal sig) (parlang_mcl_shared sig) → thread_state (memory $ parlang_mcl_tlocal sig) (parlang_mcl_shared sig)} (a : array_access sig var₁ i) (h : var₁ = var₂) : ((
        f ∘
        thread_state.tlocal_to_shared var₂ idx h₁ h₂ ∘
        compute_list updates)
    ts
).shared i = (begin simp [parlang_mcl_shared, signature.lean_type_of, lean_type_of], rw a.var_eq, rw h, exact ((compute_list updates ts).tlocal.get ⟨var₂, vector_mpr h₂ $ idx.map (eval (compute_list updates ts).tlocal)⟩) end) := sorry

lemma store_shared_skip {sig : signature} {i : mcl_address sig} {updates}
{dim} {idx : vector (expression sig type.int) dim} {var₁ var₂ t} {h₁ : type_of (sig.val var₂) = t} {h₂}
{ts : thread_state (memory $ parlang_mcl_tlocal sig) (parlang_mcl_shared sig)}
{f : thread_state (memory $ parlang_mcl_tlocal sig) (parlang_mcl_shared sig) → thread_state (memory $ parlang_mcl_tlocal sig) (parlang_mcl_shared sig)} (a : array_access sig var₁ i) (h : var₁ ≠ var₂) : ((
        f ∘
        thread_state.tlocal_to_shared var₂ idx h₁ h₂ ∘
        compute_list updates)
    ts
).shared i = ((f ∘ compute_list updates) ts).shared i := sorry

def memory_array_update_tid {sig : signature} {n} (var) (s : state n (memory $ parlang_mcl_tlocal sig) (parlang_mcl_shared sig)) (expr : expression sig (type_of (sig.val var))) (m : memory (parlang_mcl_shared sig)) :=
((list.range_fin n).foldl (λ (m : parlang.memory (parlang_mcl_shared sig)) i, m.update ⟨var, eq.mpr sorry v[i]⟩ (eval (s.threads.nth i).tlocal expr))) m

lemma memory_array_update_tid_skip {sig : signature} {n} {var₁ var₂} {s : state n (memory $ parlang_mcl_tlocal sig) (parlang_mcl_shared sig)}
{expr : expression sig (type_of (sig.val var₂))} {m : memory (parlang_mcl_shared sig)} {i} (a : array_access sig var₁ i) (h : var₁ ≠ var₂) :
(memory_array_update_tid var₂ s expr m) i = m i := begin
    cases i,
    have : i_fst = var₁ := a.var_eq,
    admit,
    -- induction on n
    -- show non-interference on memory.update
end

lemma memory_array_update_tid_success {sig : signature} {n} {var₁ var₂} {s : state n (memory $ parlang_mcl_tlocal sig) (parlang_mcl_shared sig)}
{expr : expression sig (type_of (sig.val var₂))} {m : memory (parlang_mcl_shared sig)} {i} (a : array_access_tid_to_idx sig var₁ i n) (h : var₁ = var₂) :
(memory_array_update_tid var₂ s expr m) i = eval (s.threads.nth ⟨_, a.idx_1_lt_n⟩).tlocal (by rw a.to_array_access.var_eq; rw h; exact expr) := begin
    admit,
end

structure array_access_oob (sig : signature) (var : string) (i : mcl_address sig) (n : ℕ) : Prop :=
(var_eq: i.1 = var) (idx_len : i.2.length = (sig.val var).type.dim) (one_dim : i.2.length = 1)
(oob: ¬i.2.nth ⟨0, begin rw [var_eq, ←idx_len, one_dim], exact lt_zero_one end⟩ < n)

instance bet {sig var i n} : decidable (array_access_oob sig var i n) := sorry

lemma array_access_false {sig : signature} {n i var} : ¬array_access_tid_to_idx sig var i n →
    i.1 ≠ var ∨ i.2.length ≠ (sig.val var).type.dim ∨
    i.2.length ≠ 1 ∨ array_access_oob sig var i n := begin
    intro h,
    by_cases var_eq: i.fst = var, swap, {
        left,
        trivial,
    },
    by_cases idx_len : vector.length (i.snd) = ((sig.val var).type).dim, swap, {
        right, left,
        trivial,
    },
    by_cases one_dim : vector.length (i.snd) = 1, swap, {
        right, right, left,
        trivial,
    },
    by_cases array_access_oob sig var i n, {
        right, right, right,
        assumption,
    }, {
        have : i.2.nth ⟨0, begin rw [var_eq, ←idx_len, one_dim], exact lt_zero_one end⟩ < n := begin
            by_contra oob,
            have : array_access_oob sig var i n := ⟨var_eq, idx_len, one_dim, oob⟩,
            contradiction,
        end,
        have : array_access_tid_to_idx sig var i n := ⟨⟨var_eq, idx_len⟩, one_dim, this⟩,
        contradiction,
    }
end

-- this approach is like computing both programs and comparing their output
-- this is a fairly naive approach, another approach would be to show that their behavior is equal (based on the fact that we have to show equality)
/--
Show
-/
lemma assign_rel : mclp_rel eq p₁ p₂ eq := begin
    apply rel_mclk_to_mclp,

    apply skip_right.mpr,
    apply rhl.seq,
    swap,

    apply skip_left_after.mpr,
    apply skip_right.mpr,
    apply rhl.seq,
    swap,

    -- break it down into individual proofs
    apply add_skip_left.mpr,
    apply rhl.seq,
    swap,
    {
        apply shared_assign_right,
    },{
        apply shared_assign_right,
    }, {
        apply shared_assign_left,
    },
    apply shared_assign_left',
    intros _ _ _ _ _ _ h,
    cases h with m₁ h,
    cases h with m₂ h,
    simp,
    have : n₁ = n₂ := begin
        sorry
    end,
    subst this,
    have hseq : s₁ = s₂ := begin
        sorry
    end,

    -- the proof obligation in the form of a map thread on syncable is the simple version because we never consider threads to change active state (here all threads are always active)

    -- the two updates store indepedently because "a" ≠ "b"
    -- the two updates read indepedently because they both depend on the same state (AFAIK they could still be swaped because the state is fixed)
    apply exists.intro (memory_array_update_tid "b" s₁ (read_tid + (expression.literal_int 1 (by refl))) (memory_array_update_tid "a" s₁ read_tid m₁)),

    -- split up the proof for the individual memories
    split, {
        have : thread_state.update_shared_vars_for_expr read_tid = id := by refl,
        rw this,
        have : thread_state.update_shared_vars_for_expr (read_tid + (expression.literal_int 1 (show type_of (sig.val "b") = type_of (sig.val "b"), by refl))) = id := by refl,
        rw this,
        simp,

        -- put maps in store
        -- todo we could distinct cases
           -- store stores the same value as update
           -- update changes the value of an index of store
           -- update can be ignored
        -- rw ← function.comp.assoc,
        -- rw ← function.comp.assoc,
        -- rw thread_state_map,
        -- rw ← function.comp.assoc,
        -- rw thread_state_map',
        -- rw function.comp.assoc,
        -- rw function.comp.assoc,
        -- rw syncable_remove_map,

        have hbni : list.all (vector.to_list v[read_tid]) (bnot ∘ expr_reads "b") = tt := by refl,
        have hani : list.all (vector.to_list v[read_tid]) (bnot ∘ expr_reads "a") = tt := by refl,
        have hani' : expr_reads "a" read_tid = ff := by refl,
        have hbni' : expr_reads "b" read_tid = ff := by refl,
        have hbni'' : expr_reads "b" (read_tid + expression.literal_int 1 p₁._proof_5) = ff := by refl,
        have hani'' : expr_reads "a" (read_tid + expression.literal_int 1 p₁._proof_5) = ff := by refl,

        -- resolve get and update (the result should only be mcl_init, literals and memory (in case of loads))

        -- simp [state_get_update_success _ _ _ _ _, eval_update_ignore' hbni, eval_update_ignore' hani, eval_update_ignore hani'', eval_update_ignore hbni''],
        -- conv {
        --     congr,
        --     congr,
        --     skip,
        --     congr,
        --     congr,
        --     funext,
        --     rw vector.map_single,
        --     rw vector.to_list,
        --     rw eval_update_ignore hbni',
        --     rw eval_update_ignore hani',
        --     skip,
        --     congr,
        --     funext,
        --     rw vector.map_single,
        --     rw vector.to_list,
        --     rw eval_update_ignore hani',
        -- },
        intro,
        -- handle all addresses from array "a"
        by_cases ha : array_access_tid_to_idx sig "a" i n₁, {
            -- choose that we have a store
            right,
            use ha.storing_tid,
            repeat { rw compute_to_compute_list },
            split,
            {
                -- find the correct store instruction which performs the write
                rw map_active_threads_nth_ac, {
                    rw initial_kernel_assertion_left_thread_state h,
                    apply store_store_success,
                    apply address_eq,
                    swap,
                    {
                        apply ha.var_eq,
                    }, {
                        rw vector.map_single,
                        cases i,
                        cases ha,
                        cases ha__to_array_access,
                        simp at ha__to_array_access_var_eq,
                        simp at ha__to_array_access_idx_len,
                        dedup,
                        subst ha__to_array_access_var_eq_1,
                        rw ← vector.eq_one,
                        refl,
                    }
                }, {
                    -- thread is active
                    apply all_threads_active_nth,
                    exact h.left_all_threads_active,
                }
            },
            split,
            {
                -- proof that the value at i is the same in the resulting memory
                rw map_active_threads_nth_ac (all_threads_active_nth h.left_all_threads_active _),
                rw memory_array_update_tid_skip ha.to_array_access,
                swap, {
                    intro heq,
                    cases heq,
                },
                rw memory_array_update_tid_success ha,
                swap, {
                    refl,
                },
                rw store_shared_success ha.to_array_access,
                swap, {
                    refl
                },
                rw initial_kernel_assertion_left_thread_state h,
                sorry, -- proof that the value is the same
            }, {
                -- proof that all other threads t' don't access i
                intros t' hneqtt',
                -- handle store to "a"
                apply store_access_elim_idx, {
                    apply list_neq_elem 0,
                    swap, {
                        rw vector.length_list,
                        rw ha.one_dim,
                        exact lt_zero_one,
                    }, {
                        rw list_nth_vector,
                        rw list_nth_vector,
                        rw vector.nth_map,
                        rw map_active_threads_nth_ac,
                        rw initial_kernel_assertion_left_thread_state h,
                        exact fin.fin_eq hneqtt',
                        sorry, -- todo thread is actives
                    }, {
                        rw vector.length_list,
                        rw vector.length,
                        exact lt_zero_one,
                    }
                }, {
                    -- handle store to "b"
                    rw function.comp.assoc,
                    rw compute_list_merge,
                    apply store_access_elim_idx', {
                        apply list_neq_elem 0,
                        swap, {
                            rw vector.length_list,
                            rw ha.one_dim,
                            exact lt_zero_one,
                        }, {
                            rw list_nth_vector,
                            rw list_nth_vector,
                            rw vector.nth_map,
                            rw map_active_threads_nth_ac,
                            rw initial_kernel_assertion_left_thread_state h,
                            exact fin.fin_eq hneqtt',
                            sorry, -- todo thread is actives
                        }, {
                            sorry, -- todo prove length through map and stuff
                        }
                    }, {
                        -- initial state does not access any i
                        apply access_init h,
                    }
                }
            }
        },
        -- handle all addresses from array "b"
        by_cases hb : array_access_tid_to_idx sig "b" i n₁, {
            -- choose that we have a store
            right,
            use hb.storing_tid,
            repeat { rw compute_to_compute_list },
            split,
            {
                -- find the correct store instruction which performs the write
                rw map_active_threads_nth_ac, {
                    rw initial_kernel_assertion_left_thread_state h,
                    apply store_store_skip_name,
                    rw function.comp.assoc,
                    rw compute_list_merge,
                    rw ← function.left_id (thread_state.tlocal_to_shared _ _ _ _ ∘ _),
                    apply store_store_success,
                    apply address_eq,
                    swap,
                    {
                        apply hb.var_eq,
                    }, {
                        rw vector.map_single,
                        cases i,
                        cases hb,
                        cases hb__to_array_access,
                        simp at hb__to_array_access_var_eq,
                        simp at hb__to_array_access_idx_len,
                        dedup,
                        subst hb__to_array_access_var_eq_1,
                        rw ← vector.eq_one,
                        refl,
                    }
                }, {
                    -- thread is active
                    apply all_threads_active_nth,
                    exact h.left_all_threads_active,
                }
            },
            split,
            {
                -- proof that the value at i is the same in the resulting memory
                rw map_active_threads_nth_ac (all_threads_active_nth h.left_all_threads_active _),
                rw memory_array_update_tid_success hb,
                swap, {
                    refl,
                },
                rw store_shared_skip hb.to_array_access,
                swap, {
                    intro heq,
                    cases heq,
                },
                rw initial_kernel_assertion_left_thread_state h,
                rw function.comp.assoc,
                rw compute_list_merge,
                rw ← function.left_id (thread_state.tlocal_to_shared _ _ _ _ ∘ _),
                rw store_shared_success hb.to_array_access,
                swap, {
                    refl
                },
                sorry, -- proof that the value is the same
            }, {
                -- proof that all other threads t' don't access i
                -- the order is defined by the program, we approach them similar to the proof for "a"
                intros t' hneqtt',
                -- handle store to "a"
                apply store_access_elim_idx, {
                    apply list_neq_elem 0,
                    swap, {
                        rw vector.length_list,
                        rw hb.one_dim,
                        exact lt_zero_one,
                    }, {
                        rw list_nth_vector,
                        rw list_nth_vector,
                        rw vector.nth_map,
                        rw map_active_threads_nth_ac,
                        rw initial_kernel_assertion_left_thread_state h,
                        exact fin.fin_eq hneqtt',
                        sorry, -- todo thread is actives
                    }, {
                        rw vector.length_list,
                        rw vector.length,
                        exact lt_zero_one,
                    }
                }, {
                    -- handle store to "b"
                    rw function.comp.assoc,
                    rw compute_list_merge,
                    apply store_access_elim_idx', {
                        apply list_neq_elem 0,
                        swap, {
                            rw vector.length_list,
                            rw hb.one_dim,
                            exact lt_zero_one,
                        }, {
                            rw list_nth_vector,
                            rw list_nth_vector,
                            rw vector.nth_map,
                            rw map_active_threads_nth_ac,
                            rw initial_kernel_assertion_left_thread_state h,
                            exact fin.fin_eq hneqtt',
                            sorry, -- todo thread is actives
                        }, {
                            sorry, -- todo prove length through map and stuff
                        }
                    }, {
                        -- initial state does not access any i
                        apply access_init h,
                    }
                }
            }
        },
        -- no thread stores in addresses which are not "a" or "b"
        left,
        intro t,
        split,
        {
            repeat { rw compute_to_compute_list },
            apply thread_state.store_accesses,
            by_cases i.fst = "a", {
                have : _ := array_access_false ha,
                sorry,
                -- apply store_access_elim_idx, {

                -- }
            },
            by_cases i.fst = "b", {
                sorry,
            },
            sorry,
        },
        -- TODO: handle all remaining addresses but "a"
        sorry,
    }, {
        sorry,
    }
end

end proof1
end assign_mcl -/


import category_theory.adjunction.basic
import category_theory.limits.preserves.basic
import data.pfun

open category_theory category_theory.functor category_theory.limits

variables (𝒞 : Type) [category.{0} 𝒞]

inductive bicompletion_aux : bool → Type 1
| of_cat_obj : 𝒞 → bicompletion_aux ff
| limit_obj {𝒟 : Type} [category.{0} 𝒟] (F_obj : 𝒟 → bicompletion_aux ff)
  (F_hom : Π {X Y : 𝒟}, (X ⟶ Y) → bicompletion_aux tt) : bicompletion_aux ff
| colimit_obj {𝒟 : Type} [category.{0} 𝒟] (F_obj : 𝒟 → bicompletion_aux ff)
  (F_hom : Π {X Y : 𝒟}, (X ⟶ Y) → bicompletion_aux tt) : bicompletion_aux ff
| of_cat_hom : Π {X Y : 𝒞}, (X ⟶ Y) → bicompletion_aux tt -- of_cat_obj X ⟶ of_cat_obj Y
| limit_cone_comp {𝒟 : Type} [category.{0} 𝒟] (F_obj : 𝒟 → bicompletion_aux ff)
  (F_hom : Π {X Y : 𝒟}, (X ⟶ Y) → bicompletion_aux tt)
  (X : 𝒟) (Y : bicompletion_aux ff) (f : bicompletion_aux tt) : -- F_obj X ⟶ Y
  bicompletion_aux tt -- limit_obj F_obj F_hom ⟶ Y
| is_limit {𝒟 : Type} [category.{0} 𝒟] (F_obj : 𝒟 → bicompletion_aux ff)
  (F_hom : Π {X Y : 𝒟}, (X ⟶ Y) → bicompletion_aux tt)
  (cone_obj : bicompletion_aux ff)
  (cone : Π (X : 𝒟), bicompletion_aux tt) : -- cone_obj ⟶ F_obj X
  bicompletion_aux tt -- cone_obj → limit_obj F_obj F_hom
| colimit_cocone_comp {𝒟 : Type} [category.{0} 𝒟] (F_obj : 𝒟 → bicompletion_aux ff)
  (F_hom : Π {X Y : 𝒟}, (X ⟶ Y) → bicompletion_aux tt)
  (X : 𝒟) (Y : bicompletion_aux ff) (f : bicompletion_aux tt) : -- Y ⟶ F_obj X
  bicompletion_aux tt -- Y ⟶ colimit_obj F_obj F_hom
| is_colimit {𝒟 : Type} [category.{0} 𝒟] (F_obj : 𝒟 → bicompletion_aux ff)
  (F_hom : Π {X Y : 𝒟}, (X ⟶ Y) → bicompletion_aux tt)
  (cocone_obj : bicompletion_aux ff)
  (cocone : Π (X : 𝒟), bicompletion_aux tt) : -- F_obj X ⟶ cocone_obj
  bicompletion_aux tt -- colimit_obj F_obj F_hom ⟶ cocone_obj

namespace bicompletion_aux

variable {𝒞}

@[simp] def dom : Π (X : bicompletion_aux 𝒞 tt), bicompletion_aux 𝒞 ff
| (@of_cat_hom _ _ X Y f) := of_cat_obj X
| (@limit_cone_comp _ _ 𝒟 _ F_obj F_hom X _ _) := by exactI limit_obj F_obj @F_hom
| (@is_limit _ _ 𝒟 _ F_obj F_hom cone_obj cone) := cone_obj
| (@colimit_cocone_comp _ _ 𝒟 _ F_obj F_hom X Y f) := Y
| (@is_colimit _ _ 𝒟 _ F_obj F_hom cocone_obj cocone) := by exactI colimit_obj F_obj @F_hom

@[simp] def cod : Π (X : bicompletion_aux 𝒞 tt), bicompletion_aux 𝒞 ff
| (@of_cat_hom _ _ X Y f) := of_cat_obj Y
| (@colimit_cocone_comp _ _ 𝒟 _ F_obj F_hom X _ _) := by exactI colimit_obj F_obj @F_hom
| (@is_colimit _ _ 𝒟 _ F_obj F_hom cocone_obj cocone) := cocone_obj
| (@limit_cone_comp _ _ 𝒟 _ F_obj F_hom X Y f) := Y
| (@is_limit _ _ 𝒟 _ F_obj F_hom cone_obj cone) := by exactI limit_obj F_obj @F_hom

variable (𝒞)

def obj₁ : Type 1 := bicompletion_aux 𝒞 ff

variable {𝒞}
variables {𝒟 : Type} [category.{0} 𝒟]

def hom₁ (X Y : obj₁ 𝒞) : Type 1 :=
{ f : bicompletion_aux 𝒞 tt // f.dom = X ∧ f.cod = Y }

def of_cat_obj₁ (X : 𝒞) : obj₁ 𝒞 := of_cat_obj X

def limit_obj₁ (F_obj : 𝒟 → obj₁ 𝒞)
  (F_hom : Π {X Y : 𝒟}, (X ⟶ Y) → hom₁ (F_obj X) (F_obj Y)) : obj₁ 𝒞 :=
limit_obj F_obj (λ X Y f, (F_hom f).1)

def colimit_obj₁ (F_obj : 𝒟 → obj₁ 𝒞)
  (F_hom : Π {X Y : 𝒟}, (X ⟶ Y) → hom₁ (F_obj X) (F_obj Y)) : obj₁ 𝒞 :=
colimit_obj F_obj (λ X Y f, (F_hom f).1)

def of_cat_hom₁ {X Y : 𝒞} (f : X ⟶ Y) : hom₁ (of_cat_obj X) (of_cat_obj Y) :=
⟨of_cat_hom f, by simp⟩

def limit_cone_comp₁ (F_obj : 𝒟 → obj₁ 𝒞)
  (F_hom : Π {X Y : 𝒟}, (X ⟶ Y) → hom₁ (F_obj X) (F_obj Y)) (X : 𝒟)
  {Y : obj₁ 𝒞} (f : hom₁ (F_obj X) Y) :
  hom₁ (limit_obj₁ F_obj @F_hom) Y :=
⟨limit_cone_comp F_obj (λ X Y f, (F_hom f).1) X Y f.1, by simp [limit_obj₁]⟩

def colimit_cocone_comp₁ (F_obj : 𝒟 → obj₁ 𝒞)
  (F_hom : Π {X Y : 𝒟}, (X ⟶ Y) → hom₁ (F_obj X) (F_obj Y)) (X : 𝒟)
  {Y : obj₁ 𝒞} (f : hom₁ Y (F_obj X)) :
  hom₁ Y (colimit_obj₁ F_obj @F_hom) :=
⟨colimit_cocone_comp F_obj (λ X Y f, (F_hom f).1) X Y f.1, by simp [colimit_obj₁]⟩

def is_limit₁ (F_obj : 𝒟 → obj₁ 𝒞)
  (F_hom : Π {X Y : 𝒟}, (X ⟶ Y) → hom₁ (F_obj X) (F_obj Y))
  (cone_obj : obj₁ 𝒞)
  (cone : Π (X : 𝒟), hom₁ cone_obj (F_obj X)) :
  hom₁ cone_obj (limit_obj₁ F_obj @F_hom) :=
⟨is_limit F_obj (λ X Y f, (F_hom f).1) cone_obj (λ X, (cone X).1), by simp [limit_obj₁]⟩

def is_colimit₁ (F_obj : 𝒟 → obj₁ 𝒞)
  (F_hom : Π {X Y : 𝒟}, (X ⟶ Y) → hom₁ (F_obj X) (F_obj Y))
  (cocone_obj : obj₁ 𝒞)
  (cocone : Π (X : 𝒟), hom₁ (F_obj X) cocone_obj) :
  hom₁ (colimit_obj₁ F_obj @F_hom) cocone_obj  :=
⟨is_colimit F_obj (λ X Y f, (F_hom f).1) cocone_obj (λ X, (cocone X).1), by simp [colimit_obj₁]⟩

def id₁_aux (b : bool) (hb : b = ff) (X : bicompletion_aux 𝒞 b) :
  hom₁ (show bicompletion_aux 𝒞 ff, from eq.rec_on hb X)
       (show bicompletion_aux 𝒞 ff, from eq.rec_on hb X) :=
begin
  revert hb,
  refine bicompletion_aux.rec_on X _ _ _ _ _ _ _ _,
  { rintros X h,
    exact of_cat_hom₁ (𝟙 X) },
  { introsI 𝒟 _ F_obj F_hom ih₁ ih₂ _,
    exact ⟨is_limit F_obj @F_hom (limit_obj F_obj @F_hom)
      (λ D, limit_cone_comp F_obj @F_hom D (F_obj D) (ih₁ D rfl).1),
      by simp⟩ },
  { introsI 𝒟 _ F_obj F_hom ih₁ ih₂ _,
    exact ⟨is_colimit F_obj @F_hom (colimit_obj F_obj @F_hom)
      (λ D, colimit_cocone_comp F_obj @F_hom D (F_obj D) (ih₁ D rfl).1),
      by simp⟩ },
  all_goals { intros, contradiction }
end

def id₁ (X : obj₁ 𝒞) : hom₁ X X :=
id₁_aux ff rfl X

-- def comp₁ : Π
--   (f : bicompletion_aux 𝒞 tt)
--   (g : bicompletion_aux 𝒞 tt),
--   part (bicompletion_aux 𝒞 tt)
-- | (@of_cat_hom _ _ A B f) (@of_cat_hom _ _ B' C g) :=
--   ⟨B = B', λ h, by subst h; exact (of_cat_hom₁ (f ≫ g)).1⟩
-- | (@limit_cone_comp _ _ 𝒟 _ F_obj F_hom A B f) g :=
--   do ih ← comp₁ f g, return (by exactI limit_cone_comp F_obj @F_hom A g.cod ih)
-- | f (@colimit_cocone_comp _ _ 𝒟 _ F_obj F_hom A B g) :=
--   do ih ← comp₁ f g, return (by exactI colimit_cocone_comp F_obj @F_hom A g.cod ih)
-- | (@is_colimit _ _ 𝒟 _ F_obj F_hom cocone_obj cocone) g :=
--   let f : Π (A : 𝒟), part (bicompletion_aux 𝒞 tt) := λ A, comp₁ (cocone A) g in
--   ⟨∀ A : 𝒟, (f A).dom, λ h, by exactI @is_colimit _ _ 𝒟 _ F_obj @F_hom cocone_obj
--     (λ A, (f A).get (h A))⟩
-- | f (@is_limit _ _ 𝒟 _ F_obj F_hom cone_obj cone) :=
--   let f : Π (A : 𝒟), part (bicompletion_aux 𝒞 tt) := λ A, comp₁ f (cone A) in
--   ⟨∀ A : 𝒟, (f A).dom, λ h, by exactI @is_colimit _ _ 𝒟 _ F_obj @F_hom cone_obj
--     (λ A, (f A).get (h A))⟩
-- using_well_founded { dec_tac := `[admit] }

inductive valid_obj₁ : Π (X : obj₁ 𝒞), Prop
| of_cat_obj (X : 𝒞) : valid_obj₁ (of_cat_obj X)
| limit_obj {𝒟 : Type} [category.{0} 𝒟] (F_obj : 𝒟 → obj₁ 𝒞)
  (F_hom : Π {X Y : 𝒟}, (X ⟶ Y) → hom₁ (F_obj X) (F_obj Y))
  (h : Π X : 𝒟, valid_obj₁ (F_obj X)) :
  valid_obj₁ (limit_obj₁ F_obj @F_hom)
| colimit_obj {𝒟 : Type} [category.{0} 𝒟] (F_obj : 𝒟 → obj₁ 𝒞)
  (F_hom : Π {X Y : 𝒟}, (X ⟶ Y) → hom₁ (F_obj X) (F_obj Y))
  (h : Π X : 𝒟, valid_obj₁ (F_obj X)) :
  valid_obj₁ (colimit_obj₁ F_obj @F_hom)

def valid_obj₁_limit_obj
  {𝒟 : Type} [category.{0} 𝒟] {F_obj : 𝒟 → obj₁ 𝒞}
  {F_hom : Π {X Y : 𝒟}, (X ⟶ Y) → bicompletion_aux 𝒞 tt}
  (h : valid_obj₁ (limit_obj F_obj @F_hom)) :
  Π (X : 𝒟), valid_obj₁ (F_obj X) :=
begin
  generalize hX : limit_obj F_obj @F_hom = X,
  rw hX at h,
  induction h,
  { simp * at * },
  { simp [limit_obj₁] at hX,
    rcases hX with ⟨hX₁, hX₂, hX₂, hX₄⟩,
    subst hX₁,
    simp at *,
    subst hX₂,
    assumption },
  { simp [*, colimit_obj₁] at * }
end

def valid_obj₁_colimit_obj
  {𝒟 : Type} [category.{0} 𝒟] {F_obj : 𝒟 → obj₁ 𝒞}
  {F_hom : Π {X Y : 𝒟}, (X ⟶ Y) → bicompletion_aux 𝒞 tt}
  (h : valid_obj₁ (colimit_obj F_obj @F_hom)) :
  Π (X : 𝒟), valid_obj₁ (F_obj X) :=
begin
  generalize hX : colimit_obj F_obj @F_hom = X,
  rw hX at h,
  induction h,
  { simp * at * },
  { simp [*, limit_obj₁] at * },
  { simp [colimit_obj₁] at hX,
    rcases hX with ⟨hX₁, hX₂, hX₂, hX₄⟩,
    subst hX₁,
    simp at *,
    subst hX₂,
    assumption }
end

inductive valid_hom₁ : Π {X Y : obj₁ 𝒞}, hom₁ X Y → Type 1
| of_cat_hom {X Y : 𝒞} (f : X ⟶ Y) : valid_hom₁ (of_cat_hom₁ f)
| limit_cone_comp {𝒟 : Type} [category.{0} 𝒟] (F_obj : 𝒟 → obj₁ 𝒞)
  (F_hom : Π {X Y : 𝒟}, (X ⟶ Y) → hom₁ (F_obj X) (F_obj Y))
  (X : 𝒟) {Y : obj₁ 𝒞} (f : hom₁ (F_obj X) Y)
  (F_hom_valid : Π {X Y : 𝒟} (f : X ⟶ Y), valid_hom₁ (F_hom f))
  (f_valid : valid_hom₁ f) :
  valid_hom₁ (limit_cone_comp₁ F_obj @F_hom X f)
| colimit_cocone_comp {𝒟 : Type} [category.{0} 𝒟] (F_obj : 𝒟 → obj₁ 𝒞)
  (F_hom : Π {X Y : 𝒟}, (X ⟶ Y) → hom₁ (F_obj X) (F_obj Y))
  (X : 𝒟) {Y : obj₁ 𝒞} (f : hom₁ Y (F_obj X))
  (F_hom_valid : Π {X Y : 𝒟} (f : X ⟶ Y), valid_hom₁ (F_hom f))
  (f_valid : valid_hom₁ f) :
  valid_hom₁ (colimit_cocone_comp₁ F_obj @F_hom X f)
| is_limit {𝒟 : Type} [category.{0} 𝒟] (F_obj : 𝒟 → obj₁ 𝒞)
  (F_hom : Π {X Y : 𝒟}, (X ⟶ Y) → hom₁ (F_obj X) (F_obj Y))
  (cone_obj : obj₁ 𝒞)
  (cone : Π (X : 𝒟), hom₁ cone_obj (F_obj X))
  (F_hom_valid : Π {X Y : 𝒟} (f : X ⟶ Y), valid_hom₁ (F_hom f))
  (cone_valid : Π (X : 𝒟), valid_hom₁ (cone X)) :
  valid_hom₁ (is_limit₁ F_obj @F_hom cone_obj cone)
| is_colimit {𝒟 : Type} [category.{0} 𝒟] (F_obj : 𝒟 → obj₁ 𝒞)
  (F_hom : Π {X Y : 𝒟}, (X ⟶ Y) → hom₁ (F_obj X) (F_obj Y))
  (cocone_obj : obj₁ 𝒞)
  (cocone : Π (X : 𝒟), hom₁ (F_obj X) cocone_obj)
  (F_hom_valid : Π {X Y : 𝒟} (f : X ⟶ Y), valid_hom₁ (F_hom f))
  (cocone_valid : Π (X : 𝒟), valid_hom₁ (cocone X)) :
  valid_hom₁ (is_colimit₁ F_obj @F_hom cocone_obj cocone)

variable (𝒞)

def obj₂ : Type 1 := { X : obj₁ 𝒞 // valid_obj₁ X }

variable {𝒞}

def hom₂ (X Y : obj₂ 𝒞) : Type 1 := Σ (f : hom₁ X.1 Y.1), valid_hom₁ f

open valid_hom₁

-- lemma valid_hom₁_limit_cone_comp {𝒟 : Type} [category.{0} 𝒟] (F_obj : 𝒟 → obj₁ 𝒞)
--   (F_hom : Π {X Y : 𝒟}, (X ⟶ Y) → hom₁ (F_obj X) (F_obj Y))
--   (X : 𝒟) {Y : obj₁ 𝒞} (f : hom₁ (F_obj X) Y)
--   (F_hom_valid : Π {X Y : 𝒟} (f : X ⟶ Y), valid_hom₁ (F_hom f))
--   (f_valid : valid_hom₁ f)
--   (h : valid_hom₁ (limit_cone_comp₁ F_obj @F_hom X f)) :
--   h == valid_hom₁.limit_cone_comp F_obj @F_hom X f @F_hom_valid f_valid :=
-- @valid_hom₁.rec_on _ _ (λ A B g hg, g == limit_cone_comp₁ F_obj @F_hom X f →
--   hg == valid_hom₁.limit_cone_comp F_obj @F_hom X f @F_hom_valid f_valid)
--   _ _ _ _
--   begin
--     intros,
--     simp [of_cat_hom₁] at *,

--   end _ _ _ _ (heq.refl _)

-- lemma hom₂_ext_aux {X Y : obj₁ 𝒞} (f : hom₁ X Y) (h₁ : valid_hom₁ f) :
--   ∀ (h₂ : valid_hom₁ f), h₁ = h₂ :=
-- begin
--   induction h₁,
--   { intro h₂, cases h₂, refl },
--   { intro h₂,
--     refine valid_hom₁.rec_on h₂ _ _ _ _ _,
--     { intros X Y f, }
--      }

-- end

def of_cat_obj₂ (X : 𝒞) : obj₂ 𝒞 :=
⟨of_cat_obj X, valid_obj₁.of_cat_obj _⟩

lemma of_cat_obj₂_injective : function.injective (@of_cat_obj₂ 𝒞 _) :=
begin
  intros X Y hXY,
  simp [of_cat_obj₂] at hXY,
  injection hXY,
end

def limit_obj₂ (F_obj : 𝒟 → obj₂ 𝒞)
  (F_hom : Π {X Y : 𝒟}, (X ⟶ Y) → hom₂ (F_obj X) (F_obj Y)) : obj₂ 𝒞 :=
⟨limit_obj₁ (λ X, (F_obj X).1) (λ X Y f, (F_hom f).1), valid_obj₁.limit_obj _ _ (λ X, (F_obj X).2)⟩

lemma limit_obj₂_injective {𝒟₁ 𝒟₂ : Type} [i₁ : category 𝒟₁] [i₂ : category 𝒟₂]
  {F_obj₁ : 𝒟₁ → obj₂ 𝒞} {F_obj₂ : 𝒟₂ → obj₂ 𝒞}
  {F_hom₁ : Π {X Y : 𝒟₁}, (X ⟶ Y) → hom₂ (F_obj₁ X) (F_obj₁ Y)}
  {F_hom₂ : Π {X Y : 𝒟₂}, (X ⟶ Y) → hom₂ (F_obj₂ X) (F_obj₂ Y)}
  (h : limit_obj₂ F_obj₁ @F_hom₁ = limit_obj₂ F_obj₂ @F_hom₂) :
  𝒟₁ = 𝒟₂ ∧ i₁ == i₂ ∧ F_obj₁ == F_obj₂ ∧ @F_hom₁ == @F_hom₂ :=
begin
  simp [limit_obj₂, limit_obj₁] at h,
  injection h with h₁ h₂ h₃ h₄,
  unfreezingI { subst h₁ },
  rw heq_iff_eq at h₂,
  unfreezingI { subst h₂ },
  simp [heq_iff_eq, function.funext_iff, subtype.coe_injective.eq_iff] at h₃,
  rw [← function.funext_iff] at h₃,
  dsimp at h₃,
  subst h₃,
  simp [heq_iff_eq, function.funext_iff, subtype.coe_injective.eq_iff] at h₄,
end

def colimit_obj₂ (F_obj : 𝒟 → obj₂ 𝒞)
  (F_hom : Π {X Y : 𝒟}, (X ⟶ Y) → hom₂ (F_obj X) (F_obj Y)) : obj₂ 𝒞 :=
⟨colimit_obj₁ (λ X, (F_obj X).1) (λ X Y f, (F_hom f).1), valid_obj₁.colimit_obj _ _ (λ X, (F_obj X).2)⟩

def of_cat_hom₂ {X Y : 𝒞} (f : X ⟶ Y) : hom₂ (of_cat_obj₂ X) (of_cat_obj₂ Y) :=
⟨of_cat_hom₁ f, valid_hom₁.of_cat_hom _⟩

def limit_cone_comp₂ (F_obj : 𝒟 → obj₂ 𝒞)
  (F_hom : Π {X Y : 𝒟}, (X ⟶ Y) → hom₂ (F_obj X) (F_obj Y)) (X : 𝒟)
  {Y : obj₂ 𝒞} (f : hom₂ (F_obj X) Y) :
  hom₂ (limit_obj₂ F_obj @F_hom) Y :=
⟨limit_cone_comp₁ (λ X, (F_obj X).1) (λ X Y f, (F_hom f).1) X f.1,
  valid_hom₁.limit_cone_comp _ _ _ _ (λ X Y f, (F_hom f).2) f.2⟩

def colimit_cocone_comp₂ (F_obj : 𝒟 → obj₂ 𝒞)
  (F_hom : Π {X Y : 𝒟}, (X ⟶ Y) → hom₂ (F_obj X) (F_obj Y)) (X : 𝒟)
  {Y : obj₂ 𝒞} (f : hom₂ Y (F_obj X)):
  hom₂ Y (colimit_obj₂ F_obj @F_hom) :=
⟨colimit_cocone_comp₁ (λ X, (F_obj X).1) (λ X Y f, (F_hom f).1) X f.1,
  valid_hom₁.colimit_cocone_comp _ _ _ _ (λ X Y f, (F_hom f).2) f.2⟩

def is_limit₂ (F_obj : 𝒟 → obj₂ 𝒞)
  (F_hom : Π {X Y : 𝒟}, (X ⟶ Y) → hom₂ (F_obj X) (F_obj Y))
  (cone_obj : obj₂ 𝒞)
  (cone : Π (X : 𝒟), hom₂ cone_obj (F_obj X)) :
  hom₂ cone_obj (limit_obj₂ F_obj @F_hom) :=
⟨is_limit₁ (λ X, (F_obj X).1) (λ X Y f, (F_hom f).1) cone_obj.1 (λ X, (cone X).1),
  valid_hom₁.is_limit _ _ _ _ (λ X Y f, (F_hom f).2) (λ X, (cone X).2)⟩

def is_colimit₂ (F_obj : 𝒟 → obj₂ 𝒞)
  (F_hom : Π {X Y : 𝒟}, (X ⟶ Y) → hom₂ (F_obj X) (F_obj Y))
  (cocone_obj : obj₂ 𝒞)
  (cocone : Π (X : 𝒟), hom₂ (F_obj X) cocone_obj) :
  hom₂ (colimit_obj₂ F_obj @F_hom) cocone_obj  :=
⟨is_colimit₁ (λ X, (F_obj X).1) (λ X Y f, (F_hom f).1) cocone_obj.1 (λ X, (cocone X).1),
  valid_hom₁.is_colimit _ _ _ _ (λ X Y f, (F_hom f).2) (λ X, (cocone X).2)⟩

@[elab_as_eliminator] protected def hom₂.rec_on
  {motive : Π {X Y : obj₂ 𝒞} (f : hom₂ X Y), Sort*} {X Y : obj₂ 𝒞} (f : hom₂ X Y)
  (of_cat_hom : Π {X Y : 𝒞} (f : X ⟶ Y), motive (of_cat_hom₂ f))
  (limit_cone_comp : Π {𝒟 : Type} [category 𝒟] (F_obj : 𝒟 → obj₂ 𝒞)
    (F_hom : Π {X Y : 𝒟}, (by exactI X ⟶ Y) → hom₂ (F_obj X) (F_obj Y))
    (ih_F_hom : Π {X Y : 𝒟} (f : by exactI X ⟶ Y), motive (F_hom f))
    (X : 𝒟) {Y : obj₂ 𝒞} (f : hom₂ (F_obj X) Y)
    (ih_f : motive f),
      motive (by exactI limit_cone_comp₂ F_obj @F_hom X f))
  (colimit_cocone_comp : Π {𝒟 : Type} [category 𝒟] (F_obj : 𝒟 → obj₂ 𝒞)
    (F_hom : Π {X Y : 𝒟}, (by exactI X ⟶ Y) → hom₂ (F_obj X) (F_obj Y))
    (ih_F_hom : Π {X Y : 𝒟} (f : by exactI X ⟶ Y), motive (F_hom f))
    (X : 𝒟) {Y : obj₂ 𝒞} (f : hom₂ Y (F_obj X))
    (ih_f : motive f),
      motive (by exactI colimit_cocone_comp₂ F_obj @F_hom X f))
  (is_limit : Π {𝒟 : Type} [category 𝒟] (F_obj : 𝒟 → obj₂ 𝒞)
    (F_hom : Π {X Y : 𝒟}, (by exactI X ⟶ Y) → hom₂ (F_obj X) (F_obj Y))
    (ih_F_hom : Π {X Y : 𝒟} (f : by exactI X ⟶ Y), motive (F_hom f))
    (cone_obj : obj₂ 𝒞) (cone : Π (X : 𝒟), hom₂ cone_obj (F_obj X))
    (ih_cone : Π (X : 𝒟), motive (cone X)),
      motive (by exactI is_limit₂ F_obj @F_hom cone_obj cone))
  (is_colimit : Π {𝒟 : Type} [category 𝒟] (F_obj : 𝒟 → obj₂ 𝒞)
    (F_hom : Π {X Y : 𝒟}, (by exactI X ⟶ Y) → hom₂ (F_obj X) (F_obj Y))
    (ih_F_hom : Π {X Y : 𝒟} (f : by exactI X ⟶ Y), motive (F_hom f))
    (cocone_obj : obj₂ 𝒞) (cocone : Π (X : 𝒟), hom₂ (F_obj X) cocone_obj)
    (ih_cone : Π (X : 𝒟), motive (cocone X)),
      motive (by exactI is_colimit₂ F_obj @F_hom cocone_obj cocone)) :
  motive f :=
begin
  cases X with X hX, cases Y with Y hY,
  cases f with f hf,
  dsimp at f, dsimp at hf,
  revert hX hY,
  refine valid_hom₁.rec_on hf _ _ _ _ _,
  { intros A B g hX hY,
    exact of_cat_hom g },
  { introsI 𝒟 _ F_obj F_hom X Y f F_hom_valid f_valid ih₁ ih₂ hX hY,
    exact @limit_cone_comp _ _ (λ A, ⟨F_obj A, valid_obj₁_limit_obj hX A⟩)
      (λ X Y f, ⟨F_hom f, F_hom_valid f⟩)
      (λ X Y f, ih₁ f _ _) X ⟨Y, hY⟩ ⟨f, f_valid⟩ (ih₂ _ _) },
  { introsI 𝒟 _ F_obj F_hom X Y f F_hom_valid f_valid ih₁ ih₂ hY hX,
    exact @colimit_cocone_comp _ _ (λ A, ⟨F_obj A, valid_obj₁_colimit_obj hX A⟩)
      (λ X Y f, ⟨F_hom f, F_hom_valid f⟩)
      (λ X Y f, ih₁ f _ _) X ⟨Y, hY⟩ ⟨f, f_valid⟩ (ih₂ _ _) },
  { introsI 𝒟 _ F_obj F_hom cone_obj cone F_hom_valid cone_valid ih₁ ih₂ hX hY,
    exact @is_limit 𝒟 _ (λ A, ⟨F_obj A, valid_obj₁_limit_obj hY A⟩)
      (λ X Y f, ⟨F_hom f, F_hom_valid f⟩)
      (λ X Y f, ih₁ f _ _) ⟨cone_obj, hX⟩
      (λ X, ⟨cone X, cone_valid X⟩)
      (λ X, ih₂ X _ _) },
  { introsI 𝒟 _ F_obj F_hom cocone_obj cocone F_hom_valid cocone_valid ih₁ ih₂ hX hY,
    exact @is_colimit 𝒟 _ (λ A, ⟨F_obj A, valid_obj₁_colimit_obj hX A⟩)
      (λ X Y f, ⟨F_hom f, F_hom_valid f⟩)
      (λ X Y f, ih₁ f _ _) ⟨cocone_obj, hY⟩
      (λ X, ⟨cocone X, cocone_valid X⟩)
      (λ X, ih₂ X _ _) }
end

def hom₂_of_cat_obj_rec_on
  {motive : Π {X : 𝒞} {Y : obj₂ 𝒞} (f : hom₂ (of_cat_obj₂ X) Y), Sort*}
  {X : 𝒞} {Y : obj₂ 𝒞} (f : hom₂ (of_cat_obj₂ X) Y)
  (of_cat_hom : Π {Y : 𝒞} (f : X ⟶ Y), motive (of_cat_hom₂ f))
  (colimit_cocone_comp : Π {𝒟 : Type} [category 𝒟] (F_obj : 𝒟 → obj₂ 𝒞)
    (F_hom : Π {X Y : 𝒟}, (by exactI X ⟶ Y) → hom₂ (F_obj X) (F_obj Y))
    (X : 𝒟) {Y : 𝒞} (f : hom₂ (of_cat_obj₂ Y) (F_obj X))
    (ih_f : motive f),
      motive (by exactI colimit_cocone_comp₂ F_obj @F_hom X f))
  (is_limit : Π {𝒟 : Type} [category 𝒟] (F_obj : 𝒟 → obj₂ 𝒞)
    (F_hom : Π {X Y : 𝒟}, (by exactI X ⟶ Y) → hom₂ (F_obj X) (F_obj Y))
    (cone_obj : 𝒞) (cone : Π (X : 𝒟), hom₂ (of_cat_obj₂ cone_obj) (F_obj X))
    (ih_cone : Π (X : 𝒟), motive (cone X)),
      motive (by exactI is_limit₂ F_obj @F_hom (of_cat_obj₂ cone_obj) cone)) :
  motive f :=
@hom₂.rec_on 𝒞 _ (λ A B f, ∀ (h : A = of_cat_obj₂ X),
  motive (show hom₂ (of_cat_obj₂ X) B, from eq.rec_on h f))
  (of_cat_obj₂ X) Y f
  (λ A B g h, begin
      have := of_cat_obj₂_injective h,
      subst this,
      dsimp,
      exact of_cat_hom g
    end)
  begin
    intros,
    simp [limit_obj₂, of_cat_obj₂, limit_obj₁] at h,
    contradiction
  end
  begin
    introsI 𝒟 _ F_obj F_hom ih₁ A B g ih₂ h,
    subst h,
    exact colimit_cocone_comp _ _ _ _ (ih₂ rfl)
  end
  begin
    introsI 𝒟 _ F_obj F_hom ih₁ cone_obj cone ih₂ h,
    subst h,
    exact is_limit _ _ _ _ (λ A, ih₂ A rfl),
  end
  begin
    intros,
    simp [colimit_obj₂, of_cat_obj₂] at h,
    contradiction
  end
  rfl

def hom₂_limit_obj_rec_on
  {motive : Π {𝒟 : Type} [category 𝒟] {F_obj : 𝒟 → obj₂ 𝒞}
    {F_hom : Π {X Y : 𝒟}, (by exactI X ⟶ Y) → hom₂ (F_obj X) (F_obj Y)} {Y : obj₂ 𝒞},
    hom₂ (by exactI limit_obj₂ F_obj @F_hom) Y → Sort*}
  {𝒟 : Type} [category 𝒟] {F_obj : 𝒟 → obj₂ 𝒞}
  {F_hom : Π {X Y : 𝒟}, (X ⟶ Y) → hom₂ (F_obj X) (F_obj Y)} {Y : obj₂ 𝒞}
  (f : hom₂ (limit_obj₂ F_obj @F_hom) Y)
  (limit_cone_comp : Π {𝒟 : Type} [category 𝒟] (F_obj : 𝒟 → obj₂ 𝒞)
    (F_hom : Π {X Y : 𝒟}, (by exactI X ⟶ Y) → hom₂ (F_obj X) (F_obj Y))
    (X : 𝒟) {Y : obj₂ 𝒞} (f : hom₂ (F_obj X) Y),
      by exactI motive (limit_cone_comp₂ F_obj @F_hom X f))
  (colimit_cocone_comp : Π {𝒟 : Type} [category 𝒟] (F_obj : 𝒟 → obj₂ 𝒞)
    (F_hom : Π {X Y : 𝒟}, (by exactI X ⟶ Y) → hom₂ (F_obj X) (F_obj Y))
    (X : 𝒟)
    {ℰ : Type} [category ℰ] (G_obj : ℰ → obj₂ 𝒞)
    (G_hom : Π {X Y : ℰ}, (by exactI X ⟶ Y) → hom₂ (G_obj X) (G_obj Y))
    (f : hom₂ (by exactI limit_obj₂ G_obj @G_hom) (F_obj X))
    (ih_f : by exactI motive f),
      by exactI motive (colimit_cocone_comp₂ F_obj @F_hom X f))
  (is_limit : Π {𝒟 : Type} [category 𝒟] (F_obj : 𝒟 → obj₂ 𝒞)
    (F_hom : Π {X Y : 𝒟}, (by exactI X ⟶ Y) → hom₂ (F_obj X) (F_obj Y))
    {ℰ : Type} [category ℰ] (G_obj : ℰ → obj₂ 𝒞)
    (G_hom : Π {X Y : ℰ}, (by exactI X ⟶ Y) → hom₂ (G_obj X) (G_obj Y))
    (cone : Π (X : 𝒟), hom₂ (by exactI limit_obj₂ G_obj @G_hom) (F_obj X))
    (ih_cone : Π (X : 𝒟), by exactI motive (cone X)),
      by exactI motive (is_limit₂ F_obj @F_hom (limit_obj₂ G_obj @G_hom) cone)) :
  motive f := sorry
-- @hom₂.rec_on 𝒞 _ (λ A B f, ∀ (h : A = limit_obj₂ F_obj @F_hom),
--   motive (show hom₂ (limit_obj₂ F_obj @F_hom) B, from eq.rec_on h f))
--   (limit_obj₂ F_obj @F_hom) Y f
--   begin
--     intros,
--     simp [limit_obj₂, of_cat_obj₂, limit_obj₁] at h,
--     contradiction
--   end
--   begin
--     intros ℰ _ G_obj G_hom ih₁ A B g ih₂ h,
--     simp [limit_obj₂, of_cat_obj₂, limit_obj₁] at h,
--     injection h with h₁ h₂ h₃ h₄,
--     unfreezingI { subst h₁ },
--     rw [heq_iff_eq] at h₂,
--     unfreezingI { subst h₂ },
--     dsimp at h₄,
--     dsimp,

--   end
--   begin
--     introsI 𝒟 _ F_obj F_hom ih₁ A B g ih₂ h,
--     subst h,
--     exact colimit_cocone_comp _ _ _ _ (ih₂ rfl)
--   end
--   begin
--     introsI 𝒟 _ F_obj F_hom ih₁ cone_obj cone ih₂ h,
--     subst h,
--     exact is_limit _ _ _ _ (λ A, ih₂ A rfl),
--   end
--   begin
--     intros,
--     simp [colimit_obj₂, of_cat_obj₂] at h,
--     contradiction
--   end
--   rfl

def hom₂_colimit_obj_rec_on
  {motive : Π {𝒟 : Type} [category 𝒟] {F_obj : 𝒟 → obj₂ 𝒞}
    {F_hom : Π {X Y : 𝒟}, (by exactI X ⟶ Y) → hom₂ (F_obj X) (F_obj Y)} {Y : obj₂ 𝒞},
    hom₂ (by exactI colimit_obj₂ F_obj @F_hom) Y → Sort*}
  {𝒟 : Type} [category 𝒟] {F_obj : 𝒟 → obj₂ 𝒞}
  {F_hom : Π {X Y : 𝒟}, (X ⟶ Y) → hom₂ (F_obj X) (F_obj Y)} {Y : obj₂ 𝒞}
  (f : hom₂ (limit_obj₂ F_obj @F_hom) Y)
  (limit_cone_comp : Π {𝒟 : Type} [category 𝒟] (F_obj : 𝒟 → obj₂ 𝒞)
    (F_hom : Π {X Y : 𝒟}, (by exactI X ⟶ Y) → hom₂ (F_obj X) (F_obj Y))
    (X : 𝒟) {Y : obj₂ 𝒞} (f : hom₂ (F_obj X) Y),
      by exactI motive (limit_cone_comp₂ F_obj @F_hom X f))
  (colimit_cocone_comp : Π {𝒟 : Type} [category 𝒟] (F_obj : 𝒟 → obj₂ 𝒞)
    (F_hom : Π {X Y : 𝒟}, (by exactI X ⟶ Y) → hom₂ (F_obj X) (F_obj Y))
    (X : 𝒟)
    {ℰ : Type} [category ℰ] (G_obj : ℰ → obj₂ 𝒞)
    (G_hom : Π {X Y : ℰ}, (by exactI X ⟶ Y) → hom₂ (G_obj X) (G_obj Y))
    (f : hom₂ (by exactI limit_obj₂ G_obj @G_hom) (F_obj X))
    (ih_f : by exactI motive f),
      by exactI motive (colimit_cocone_comp₂ F_obj @F_hom X f))
  (is_limit : Π {𝒟 : Type} [category 𝒟] (F_obj : 𝒟 → obj₂ 𝒞)
    (F_hom : Π {X Y : 𝒟}, (by exactI X ⟶ Y) → hom₂ (F_obj X) (F_obj Y))
    {ℰ : Type} [category ℰ] (G_obj : ℰ → obj₂ 𝒞)
    (G_hom : Π {X Y : ℰ}, (by exactI X ⟶ Y) → hom₂ (G_obj X) (G_obj Y))
    (cone : Π (X : 𝒟), hom₂ (by exactI limit_obj₂ G_obj @G_hom) (F_obj X))
    (ih_cone : Π (X : 𝒟), by exactI motive (cone X)),
      by exactI motive (is_limit₂ F_obj @F_hom (limit_obj₂ G_obj @G_hom) cone)) :
  motive f

def comp₂ {X Y : obj₂ 𝒞} (f : hom₂ X Y) : Π {Z : obj₂ 𝒞}, hom₂ Y Z → hom₂ X Z :=
hom₂.rec_on f
  begin
    intros X Y f Z g,
    refine hom₂_of_cat_obj_rec_on g _ _ _,
    { intros B g,
      exact of_cat_hom₂ (f ≫ g) },
    { introsI 𝒟 _ F_obj F_hom ih₁ B g ih₂,
      exact colimit_cocone_comp₂ F_obj _ _ ih₂ },
    { introsI 𝒟 _ F_obj F_hom ih₁ cone ih₂,
      exact is_limit₂ _ _ _ (λ X, ih₂ _) }
  end
  begin
    introsI 𝒟 _ F_obj F_hom ih₁ A B f ih₂ Z g,
    refine limit_cone_comp₂ _ _ _ (ih₂ g),
  end
  begin
    introsI 𝒟 _ F_obj F_hom ih₁ A B f ih₂ Z g,
    refine ih₂ _,
    admit
  end
  begin
    introsI 𝒟 _ F_obj F_hom ih₁ cone_obj cone ih₂ Z g,
    revert ih₂,
    refine hom₂_limit_obj_rec_on g _ _ _,
    { introsI ℰ _ G_obj G_hom A B g ih₂,
      exact ih₂ A g },
    { introsI ℰ _ F_obj F_hom A ℱ _ G_obj G_hom g ih₃ ih₂,
      exact colimit_cocone_comp₂ _ _ A (ih₃ @ih₂) },
    { introsI ℰ _ F_obj F_hom ℱ _ G_obj G_hom ih₃ ih₄ ih₂,
      exact is_limit₂ _ _ _ (λ X, ih₄ _ @ih₂) }
  end
  begin
    introsI 𝒟 _ F_obj F_hom ih₁ cocone_obj cocone ih₂ Z g,
    exact is_colimit₂ _ _ _ (λ A, ih₂ _ g)
  end

end bicompletion_aux