/-
Copyright (c) 2018 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Scott Morrison
-/
import category_theory.limits.preserves.limits

/-!
# (Co)limits in functor categories.

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

We show that if `D` has limits, then the functor category `C ⥤ D` also has limits
(`category_theory.limits.functor_category_has_limits`),
and the evaluation functors preserve limits
(`category_theory.limits.evaluation_preserves_limits`)
(and similarly for colimits).

We also show that `F : D ⥤ K ⥤ C` preserves (co)limits if it does so for each `k : K`
(`category_theory.limits.preserves_limits_of_evaluation` and
`category_theory.limits.preserves_colimits_of_evaluation`).
-/

open category_theory category_theory.category category_theory.functor

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

namespace category_theory.limits

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

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

@[simp, reassoc]
lemma limit.lift_π_app (H : J ⥤ K ⥤ C) [has_limit H] (c : cone H) (j : J) (k : K) :
  (limit.lift H c).app k ≫ (limit.π H j).app k = (c.π.app j).app k :=
congr_app (limit.lift_π c j) k

@[simp, reassoc]
lemma colimit.ι_desc_app (H : J ⥤ K ⥤ C) [has_colimit H] (c : cocone H) (j : J) (k : K) :
  (colimit.ι H j).app k ≫ (colimit.desc H c).app k = (c.ι.app j).app k :=
congr_app (colimit.ι_desc c j) k

/--
The evaluation functors jointly reflect limits: that is, to show a cone is a limit of `F`
it suffices to show that each evaluation cone is a limit. In other words, to prove a cone is
limiting you can show it's pointwise limiting.
-/
def evaluation_jointly_reflects_limits {F : J ⥤ K ⥤ C} (c : cone F)
  (t : Π (k : K), is_limit (((evaluation K C).obj k).map_cone c)) : is_limit c :=
{ lift := λ s,
  { app := λ k, (t k).lift ⟨s.X.obj k, whisker_right s.π ((evaluation K C).obj k)⟩,
    naturality' := λ X Y f, (t Y).hom_ext $ λ j,
    begin
      rw [assoc, (t Y).fac _ j],
      simpa using
        ((t X).fac_assoc ⟨s.X.obj X, whisker_right s.π ((evaluation K C).obj X)⟩ j _).symm,
    end },
  fac' := λ s j, nat_trans.ext _ _ $ funext $ λ k, (t k).fac _ j,
  uniq' := λ s m w, nat_trans.ext _ _ $ funext $ λ x, (t x).hom_ext $ λ j,
      (congr_app (w j) x).trans
        ((t x).fac ⟨s.X.obj _, whisker_right s.π ((evaluation K C).obj _)⟩ j).symm }

/--
Given a functor `F` and a collection of limit cones for each diagram `X ↦ F X k`, we can stitch
them together to give a cone for the diagram `F`.
`combined_is_limit` shows that the new cone is limiting, and `eval_combined` shows it is
(essentially) made up of the original cones.
-/
@[simps] def combine_cones (F : J ⥤ K ⥤ C) (c : Π (k : K), limit_cone (F.flip.obj k)) :
  cone F :=
{ X :=
  { obj := λ k, (c k).cone.X,
    map := λ k₁ k₂ f, (c k₂).is_limit.lift ⟨_, (c k₁).cone.π ≫ F.flip.map f⟩,
    map_id' := λ k, (c k).is_limit.hom_ext (λ j, by { dsimp, simp }),
    map_comp' := λ k₁ k₂ k₃ f₁ f₂, (c k₃).is_limit.hom_ext (λ j, by simp) },
  π :=
  { app := λ j, { app := λ k, (c k).cone.π.app j },
    naturality' := λ j₁ j₂ g, nat_trans.ext _ _ $ funext $ λ k, (c k).cone.π.naturality g } }

/-- The stitched together cones each project down to the original given cones (up to iso). -/
def evaluate_combined_cones (F : J ⥤ K ⥤ C) (c : Π (k : K), limit_cone (F.flip.obj k)) (k : K) :
  ((evaluation K C).obj k).map_cone (combine_cones F c) ≅ (c k).cone :=
cones.ext (iso.refl _) (by tidy)

/-- Stitching together limiting cones gives a limiting cone. -/
def combined_is_limit (F : J ⥤ K ⥤ C) (c : Π (k : K), limit_cone (F.flip.obj k)) :
  is_limit (combine_cones F c) :=
evaluation_jointly_reflects_limits _
  (λ k, (c k).is_limit.of_iso_limit (evaluate_combined_cones F c k).symm)

/--
The evaluation functors jointly reflect colimits: that is, to show a cocone is a colimit of `F`
it suffices to show that each evaluation cocone is a colimit. In other words, to prove a cocone is
colimiting you can show it's pointwise colimiting.
-/
def evaluation_jointly_reflects_colimits {F : J ⥤ K ⥤ C} (c : cocone F)
  (t : Π (k : K), is_colimit (((evaluation K C).obj k).map_cocone c)) : is_colimit c :=
{ desc := λ s,
  { app := λ k, (t k).desc ⟨s.X.obj k, whisker_right s.ι ((evaluation K C).obj k)⟩,
    naturality' := λ X Y f, (t X).hom_ext $ λ j,
    begin
      rw [(t X).fac_assoc _ j],
      erw ← (c.ι.app j).naturality_assoc f,
      erw (t Y).fac ⟨s.X.obj _, whisker_right s.ι _⟩ j,
      dsimp,
      simp,
    end },
  fac' := λ s j, nat_trans.ext _ _ $ funext $ λ k, (t k).fac _ j,
  uniq' := λ s m w, nat_trans.ext _ _ $ funext $ λ x, (t x).hom_ext $ λ j,
      (congr_app (w j) x).trans
        ((t x).fac ⟨s.X.obj _, whisker_right s.ι ((evaluation K C).obj _)⟩ j).symm }

/--
Given a functor `F` and a collection of colimit cocones for each diagram `X ↦ F X k`, we can stitch
them together to give a cocone for the diagram `F`.
`combined_is_colimit` shows that the new cocone is colimiting, and `eval_combined` shows it is
(essentially) made up of the original cocones.
-/
@[simps] def combine_cocones (F : J ⥤ K ⥤ C) (c : Π (k : K), colimit_cocone (F.flip.obj k)) :
  cocone F :=
{ X :=
  { obj := λ k, (c k).cocone.X,
    map := λ k₁ k₂ f, (c k₁).is_colimit.desc ⟨_, F.flip.map f ≫ (c k₂).cocone.ι⟩,
    map_id' := λ k, (c k).is_colimit.hom_ext (λ j, by { dsimp, simp }),
    map_comp' := λ k₁ k₂ k₃ f₁ f₂, (c k₁).is_colimit.hom_ext (λ j, by simp) },
  ι :=
  { app := λ j, { app := λ k, (c k).cocone.ι.app j },
    naturality' := λ j₁ j₂ g, nat_trans.ext _ _ $ funext $ λ k, (c k).cocone.ι.naturality g } }

/-- The stitched together cocones each project down to the original given cocones (up to iso). -/
def evaluate_combined_cocones
  (F : J ⥤ K ⥤ C) (c : Π (k : K), colimit_cocone (F.flip.obj k)) (k : K) :
  ((evaluation K C).obj k).map_cocone (combine_cocones F c) ≅ (c k).cocone :=
cocones.ext (iso.refl _) (by tidy)

/-- Stitching together colimiting cocones gives a colimiting cocone. -/
def combined_is_colimit (F : J ⥤ K ⥤ C) (c : Π (k : K), colimit_cocone (F.flip.obj k)) :
  is_colimit (combine_cocones F c) :=
evaluation_jointly_reflects_colimits _
  (λ k, (c k).is_colimit.of_iso_colimit (evaluate_combined_cocones F c k).symm)

noncomputable theory

instance functor_category_has_limits_of_shape
  [has_limits_of_shape J C] : has_limits_of_shape J (K ⥤ C) :=
{ has_limit := λ F, has_limit.mk
  { cone := combine_cones F (λ k, get_limit_cone _),
    is_limit := combined_is_limit _ _ } }

instance functor_category_has_colimits_of_shape
  [has_colimits_of_shape J C] : has_colimits_of_shape J (K ⥤ C) :=
{ has_colimit := λ F, has_colimit.mk
  { cocone := combine_cocones _ (λ k, get_colimit_cocone _),
    is_colimit := combined_is_colimit _ _ } }

instance functor_category_has_limits_of_size [has_limits_of_size.{v₁ u₁} C] :
  has_limits_of_size.{v₁ u₁} (K ⥤ C) := ⟨infer_instance⟩

instance functor_category_has_colimits_of_size [has_colimits_of_size.{v₁ u₁} C] :
  has_colimits_of_size.{v₁ u₁} (K ⥤ C) := ⟨infer_instance⟩

instance evaluation_preserves_limits_of_shape [has_limits_of_shape J C] (k : K) :
  preserves_limits_of_shape J ((evaluation K C).obj k) :=
{ preserves_limit :=
  λ F, preserves_limit_of_preserves_limit_cone (combined_is_limit _ _) $
    is_limit.of_iso_limit (limit.is_limit _)
      (evaluate_combined_cones F _ k).symm }

/--
If `F : J ⥤ K ⥤ C` is a functor into a functor category which has a limit,
then the evaluation of that limit at `k` is the limit of the evaluations of `F.obj j` at `k`.
-/
def limit_obj_iso_limit_comp_evaluation [has_limits_of_shape J C] (F : J ⥤ K ⥤ C) (k : K) :
  (limit F).obj k ≅ limit (F ⋙ ((evaluation K C).obj k)) :=
preserves_limit_iso ((evaluation K C).obj k) F

@[simp, reassoc]
lemma limit_obj_iso_limit_comp_evaluation_hom_π
  [has_limits_of_shape J C] (F : J ⥤ (K ⥤ C)) (j : J) (k : K) :
  (limit_obj_iso_limit_comp_evaluation F k).hom ≫ limit.π (F ⋙ ((evaluation K C).obj k)) j =
    (limit.π F j).app k :=
begin
  dsimp [limit_obj_iso_limit_comp_evaluation],
  simp,
end

@[simp, reassoc]
lemma limit_obj_iso_limit_comp_evaluation_inv_π_app
  [has_limits_of_shape J C] (F : J ⥤ (K ⥤ C)) (j : J) (k : K):
  (limit_obj_iso_limit_comp_evaluation F k).inv ≫ (limit.π F j).app k =
    limit.π (F ⋙ ((evaluation K C).obj k)) j :=
begin
  dsimp [limit_obj_iso_limit_comp_evaluation],
  rw iso.inv_comp_eq,
  simp,
end

@[simp, reassoc]
lemma limit_map_limit_obj_iso_limit_comp_evaluation_hom
  [has_limits_of_shape J C] {i j : K} (F : J ⥤ K ⥤ C) (f : i ⟶ j) :
  (limit F).map f ≫ (limit_obj_iso_limit_comp_evaluation _ _).hom =
  (limit_obj_iso_limit_comp_evaluation _ _).hom ≫
  lim_map (whisker_left _ ((evaluation _ _).map f)) :=
by { ext, dsimp, simp }

@[simp, reassoc]
lemma limit_obj_iso_limit_comp_evaluation_inv_limit_map
  [has_limits_of_shape J C] {i j : K} (F : J ⥤ K ⥤ C) (f : i ⟶ j) :
  (limit_obj_iso_limit_comp_evaluation _ _).inv ≫ (limit F).map f =
  lim_map (whisker_left _ ((evaluation _ _).map f)) ≫
  (limit_obj_iso_limit_comp_evaluation _ _).inv :=
by rw [iso.inv_comp_eq, ← category.assoc, iso.eq_comp_inv,
  limit_map_limit_obj_iso_limit_comp_evaluation_hom]

@[ext]
lemma limit_obj_ext {H : J ⥤ K ⥤ C} [has_limits_of_shape J C]
  {k : K} {W : C} {f g : W ⟶ (limit H).obj k}
  (w : ∀ j, f ≫ (limits.limit.π H j).app k = g ≫ (limits.limit.π H j).app k) : f = g :=
begin
  apply (cancel_mono (limit_obj_iso_limit_comp_evaluation H k).hom).1,
  ext,
  simpa using w j,
end

instance evaluation_preserves_colimits_of_shape [has_colimits_of_shape J C] (k : K) :
  preserves_colimits_of_shape J ((evaluation K C).obj k) :=
{ preserves_colimit :=
  λ F, preserves_colimit_of_preserves_colimit_cocone (combined_is_colimit _ _) $
    is_colimit.of_iso_colimit (colimit.is_colimit _)
      (evaluate_combined_cocones F _ k).symm }

/--
If `F : J ⥤ K ⥤ C` is a functor into a functor category which has a colimit,
then the evaluation of that colimit at `k` is the colimit of the evaluations of `F.obj j` at `k`.
-/
def colimit_obj_iso_colimit_comp_evaluation [has_colimits_of_shape J C] (F : J ⥤ K ⥤ C) (k : K) :
  (colimit F).obj k ≅ colimit (F ⋙ ((evaluation K C).obj k)) :=
preserves_colimit_iso ((evaluation K C).obj k) F

@[simp, reassoc]
lemma colimit_obj_iso_colimit_comp_evaluation_ι_inv
  [has_colimits_of_shape J C] (F : J ⥤ (K ⥤ C)) (j : J) (k : K) :
  colimit.ι (F ⋙ ((evaluation K C).obj k)) j ≫ (colimit_obj_iso_colimit_comp_evaluation F k).inv =
    (colimit.ι F j).app k :=
begin
  dsimp [colimit_obj_iso_colimit_comp_evaluation],
  simp,
end

@[simp, reassoc]
lemma colimit_obj_iso_colimit_comp_evaluation_ι_app_hom
  [has_colimits_of_shape J C] (F : J ⥤ (K ⥤ C)) (j : J) (k : K) :
  (colimit.ι F j).app k ≫ (colimit_obj_iso_colimit_comp_evaluation F k).hom =
     colimit.ι (F ⋙ ((evaluation K C).obj k)) j :=
begin
  dsimp [colimit_obj_iso_colimit_comp_evaluation],
  rw ←iso.eq_comp_inv,
  simp,
end

@[simp, reassoc]
lemma colimit_obj_iso_colimit_comp_evaluation_inv_colimit_map
  [has_colimits_of_shape J C] (F : J ⥤ K ⥤ C) {i j : K} (f : i ⟶ j) :
  (colimit_obj_iso_colimit_comp_evaluation _ _).inv ≫ (colimit F).map f =
  colim_map (whisker_left _ ((evaluation _ _).map f)) ≫
  (colimit_obj_iso_colimit_comp_evaluation _ _).inv :=
by { ext, dsimp, simp }

@[simp, reassoc]
lemma colimit_map_colimit_obj_iso_colimit_comp_evaluation_hom
  [has_colimits_of_shape J C] (F : J ⥤ K ⥤ C) {i j : K} (f : i ⟶ j) :
  (colimit F).map f ≫ (colimit_obj_iso_colimit_comp_evaluation _ _).hom =
  (colimit_obj_iso_colimit_comp_evaluation _ _).hom ≫
  colim_map (whisker_left _ ((evaluation _ _).map f)) :=
by rw [← iso.inv_comp_eq, ← category.assoc, ← iso.eq_comp_inv,
  colimit_obj_iso_colimit_comp_evaluation_inv_colimit_map]

@[ext]
lemma colimit_obj_ext {H : J ⥤ K ⥤ C} [has_colimits_of_shape J C]
  {k : K} {W : C} {f g : (colimit H).obj k ⟶ W}
  (w : ∀ j, (colimit.ι H j).app k ≫ f = (colimit.ι H j).app k ≫ g) : f = g :=
begin
  apply (cancel_epi (colimit_obj_iso_colimit_comp_evaluation H k).inv).1,
  ext,
  simpa using w j,
end

instance evaluation_preserves_limits [has_limits C] (k : K) :
  preserves_limits ((evaluation K C).obj k) :=
{ preserves_limits_of_shape := λ J 𝒥, by resetI; apply_instance }

/-- `F : D ⥤ K ⥤ C` preserves the limit of some `G : J ⥤ D` if it does for each `k : K`. -/
def preserves_limit_of_evaluation (F : D ⥤ K ⥤ C) (G : J ⥤ D)
  (H : Π (k : K), preserves_limit G (F ⋙ (evaluation K C).obj k : D ⥤ C)) :
  preserves_limit G F := ⟨λ c hc,
begin
  apply evaluation_jointly_reflects_limits,
  intro X,
  haveI := H X,
  change is_limit ((F ⋙ (evaluation K C).obj X).map_cone c),
  exact preserves_limit.preserves hc,
end⟩

/-- `F : D ⥤ K ⥤ C` preserves limits of shape `J` if it does for each `k : K`. -/
def preserves_limits_of_shape_of_evaluation (F : D ⥤ K ⥤ C) (J : Type*) [category J]
  (H : Π (k : K), preserves_limits_of_shape J (F ⋙ (evaluation K C).obj k)) :
  preserves_limits_of_shape J F :=
⟨λ G, preserves_limit_of_evaluation F G (λ k, preserves_limits_of_shape.preserves_limit)⟩

/-- `F : D ⥤ K ⥤ C` preserves all limits if it does for each `k : K`. -/
def preserves_limits_of_evaluation (F : D ⥤ K ⥤ C)
  (H : Π (k : K), preserves_limits_of_size.{w' w} (F ⋙ (evaluation K C).obj k)) :
  preserves_limits_of_size.{w' w} F :=
⟨λ L hL, by exactI preserves_limits_of_shape_of_evaluation
    F L (λ k, preserves_limits_of_size.preserves_limits_of_shape)⟩

/-- The constant functor `C ⥤ (D ⥤ C)` preserves limits. -/
instance preserves_limits_const : preserves_limits_of_size.{w' w} (const D : C ⥤ _) :=
preserves_limits_of_evaluation _ $ λ X, preserves_limits_of_nat_iso $ iso.symm $
  const_comp_evaluation_obj _ _

instance evaluation_preserves_colimits [has_colimits C] (k : K) :
  preserves_colimits ((evaluation K C).obj k) :=
{ preserves_colimits_of_shape := λ J 𝒥, by resetI; apply_instance }

/-- `F : D ⥤ K ⥤ C` preserves the colimit of some `G : J ⥤ D` if it does for each `k : K`. -/
def preserves_colimit_of_evaluation (F : D ⥤ K ⥤ C) (G : J ⥤ D)
  (H : Π (k), preserves_colimit G (F ⋙ (evaluation K C).obj k)) : preserves_colimit G F := ⟨λ c hc,
begin
  apply evaluation_jointly_reflects_colimits,
  intro X,
  haveI := H X,
  change is_colimit ((F ⋙ (evaluation K C).obj X).map_cocone c),
  exact preserves_colimit.preserves hc,
end⟩

/-- `F : D ⥤ K ⥤ C` preserves all colimits of shape `J` if it does for each `k : K`. -/
def preserves_colimits_of_shape_of_evaluation (F : D ⥤ K ⥤ C) (J : Type*) [category J]
  (H : Π (k : K), preserves_colimits_of_shape J (F ⋙ (evaluation K C).obj k)) :
  preserves_colimits_of_shape J F :=
⟨λ G, preserves_colimit_of_evaluation F G (λ k, preserves_colimits_of_shape.preserves_colimit)⟩

/-- `F : D ⥤ K ⥤ C` preserves all colimits if it does for each `k : K`. -/
def preserves_colimits_of_evaluation (F : D ⥤ K ⥤ C)
  (H : Π (k : K), preserves_colimits_of_size.{w' w} (F ⋙ (evaluation K C).obj k)) :
  preserves_colimits_of_size.{w' w} F :=
⟨λ L hL, by exactI preserves_colimits_of_shape_of_evaluation
    F L (λ k, preserves_colimits_of_size.preserves_colimits_of_shape)⟩

/-- The constant functor `C ⥤ (D ⥤ C)` preserves colimits. -/
instance preserves_colimits_const : preserves_colimits_of_size.{w' w} (const D : C ⥤ _) :=
preserves_colimits_of_evaluation _ $ λ X, preserves_colimits_of_nat_iso $ iso.symm $
  const_comp_evaluation_obj _ _

open category_theory.prod

/-- The limit of a diagram `F : J ⥤ K ⥤ C` is isomorphic to the functor given by
the individual limits on objects. -/
@[simps]
def limit_iso_flip_comp_lim [has_limits_of_shape J C] (F : J ⥤ K ⥤ C) :
  limit F ≅ F.flip ⋙ lim :=
nat_iso.of_components (limit_obj_iso_limit_comp_evaluation F) $ by tidy

/-- A variant of `limit_iso_flip_comp_lim` where the arguemnts of `F` are flipped. -/
@[simps]
def limit_flip_iso_comp_lim [has_limits_of_shape J C] (F : K ⥤ J ⥤ C) :
  limit F.flip ≅ F ⋙ lim :=
nat_iso.of_components (λ k,
  limit_obj_iso_limit_comp_evaluation F.flip k ≪≫
  has_limit.iso_of_nat_iso (flip_comp_evaluation _ _)) $ by tidy

/--
For a functor `G : J ⥤ K ⥤ C`, its limit `K ⥤ C` is given by `(G' : K ⥤ J ⥤ C) ⋙ lim`.
Note that this does not require `K` to be small.
-/
@[simps] def limit_iso_swap_comp_lim [has_limits_of_shape J C] (G : J ⥤ K ⥤ C) :
  limit G ≅ curry.obj (swap K J ⋙ uncurry.obj G) ⋙ lim :=
limit_iso_flip_comp_lim G ≪≫ iso_whisker_right (flip_iso_curry_swap_uncurry _) _

/-- The colimit of a diagram `F : J ⥤ K ⥤ C` is isomorphic to the functor given by
the individual colimits on objects. -/
@[simps]
def colimit_iso_flip_comp_colim [has_colimits_of_shape J C] (F : J ⥤ K ⥤ C) :
  colimit F ≅ F.flip ⋙ colim :=
nat_iso.of_components (colimit_obj_iso_colimit_comp_evaluation F) $ by tidy

/-- A variant of `colimit_iso_flip_comp_colim` where the arguemnts of `F` are flipped. -/
@[simps]
def colimit_flip_iso_comp_colim [has_colimits_of_shape J C] (F : K ⥤ J ⥤ C) :
  colimit F.flip ≅ F ⋙ colim :=
nat_iso.of_components (λ k,
  colimit_obj_iso_colimit_comp_evaluation _ _ ≪≫
  has_colimit.iso_of_nat_iso (flip_comp_evaluation _ _)) $ by tidy

/--
For a functor `G : J ⥤ K ⥤ C`, its colimit `K ⥤ C` is given by `(G' : K ⥤ J ⥤ C) ⋙ colim`.
Note that this does not require `K` to be small.
-/
@[simps]
def colimit_iso_swap_comp_colim [has_colimits_of_shape J C] (G : J ⥤ K ⥤ C) :
  colimit G ≅ curry.obj (swap K J ⋙ uncurry.obj G) ⋙ colim :=
colimit_iso_flip_comp_colim G ≪≫ iso_whisker_right (flip_iso_curry_swap_uncurry _) _

end category_theory.limits


/-
Copyright (c) 2022 Jun Yoshida. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
-/

import Algdata.Init.Order
import Algdata.Data.KVChain.Basic

/-!
# Merge two `KVChain`s
-/

namespace KVChain

universe u v

variable {α : Type u} {r : α → α → Prop} [StrictLinearOrder r] [DecidableRel r] {β : α → Type v}

set_option autoImplicit false

/-!
## Insertion of an element to `KVChain`
-/

def insertWithAux (f : (a : α) → β a → β a → Option (β a)) (xs : KVChain (flip r) β) (ys : KVChain r β) (hxsys : xs.hingeable ys) (a : α) (b : β a) (hxsa : xs.boundLeft a) : {z : KVChain (flip r) β × KVChain r β // z.1.hingeable z.2} :=
  let rec loop : (xs : KVChain (flip r) β) → (ys : List (Sigma β)) → ys.Ascending (Sigma.relOnFst r) → ys.predHead (xs.boundLeft ∘ Sigma.fst) → xs.boundLeft a → {z : KVChain (flip r) β × KVChain r β // z.1.hingeable z.2}
  | xs, [], _, _, hxsa =>
    Subtype.mk (xs.cons a b hxsa, KVChain.nil) $ True.intro
  | xs, yys@(y::ys), hascend, hxsyys, hxsa =>
    if hya : r y.1 a then
      loop (xs.cons y.1 y.2 hxsyys) ys hascend.tail hascend.head hya
    else if hay : r a y.1 then
      Subtype.mk (xs.cons a b hxsa, ⟨yys, ‹yys=_› ▸ hascend⟩) (‹yys=_›.symm ▸ hay)
    else
      have heq : a = y.1 := Trichotomous.eq_of_incomp ⟨hay, hya⟩
      match f y.1 y.2 (heq▸b) with
      | none =>
        Subtype.mk (xs, ⟨ys,hascend.tail⟩) $ by
          apply hingeable_skip_right (xs:=xs) (a:=y.1) (b:=y.2) (ys:=⟨ys,hascend.tail⟩) (hays:=hascend.head)
          dsimp [hingeable]
          rw [List.relHead_eq_predHead_predHead]
          exact hxsyys
      | some z =>
        Subtype.mk (xs.cons y.1 z hxsyys, ⟨ys, hascend.tail⟩) $
          cons_hingeable (haxs:=hxsyys) ▸ hascend.head
  loop xs ys.toList ys.ascend (List.relHead_eq_predHead_predHead ▸ hxsys) hxsa

def insertWith (f : (a : α) → β a → β a → Option (β a)) (xs : KVChain r β) (a : α) (b : β a) : KVChain r β :=
  match insertWithAux f KVChain.nil xs True.intro a b True.intro with
  | Subtype.mk z hz => KVChain.hinge z.1 z.2 hz

def fromListWith (f : (a : α) → β a → β a → Option (β a)) (ys : List (Sigma β)) : KVChain r β :=
  ys.foldl (λ xs y => xs.insertWith f y.1 y.2) KVChain.nil

section Theorems

variable {f : (a : α) → β a → β a → Option (β a)}

@[simp]
theorem insertWithAux_nil {xs : KVChain (flip r) β} : ∀ {hxnil : xs.hingeable KVChain.nil} {a : α} {b : β a} {haxs : xs.boundLeft a}, insertWithAux f xs KVChain.nil hxnil a b haxs = ⟨(xs.cons a b haxs, KVChain.nil), True.intro⟩ := by
  intros; rfl

theorem insertWithAux_cons_rel {xs : KVChain (flip r) β} {a₁ : α} {b₁ : β a₁} {ys : KVChain r β} {ha₁ys : ys.boundLeft a₁} {ha₁xs : xs.hingeable (ys.cons a₁ b₁ ha₁ys)} {a : α} {b : β a} {haxs : xs.boundLeft a} : ∀ (ha₁a : r a₁ a), insertWithAux f xs (ys.cons a₁ b₁ ha₁ys) ha₁xs a b haxs = insertWithAux f (xs.cons a₁ b₁ (hingeable_cons ▸ ha₁xs)) ys (cons_hingeable.symm ▸ ha₁ys) a b ha₁a := by
  intro hbc
  unfold insertWithAux
  conv in KVChain.cons a₁ b₁ ys ha₁ys => unfold KVChain.cons
  dsimp [insertWithAux.loop]
  rw [dif_pos hbc]

theorem insertWithAux_cons_flip {xs : KVChain (flip r) β} {a₁ : α} {b₁ : β a₁} {ys : KVChain r β} {ha₁ys : ys.boundLeft a₁} {ha₁xs : xs.hingeable (ys.cons a₁ b₁ ha₁ys)} {a : α} {b : β a} {haxs : xs.boundLeft a} : ∀ (haa₁ : r a a₁), insertWithAux f xs (ys.cons a₁ b₁ ha₁ys) ha₁xs a b haxs = ⟨(xs.cons a b haxs, ys.cons a₁ b₁ ha₁ys), haa₁⟩ := by
  intro haa₁
  unfold insertWithAux
  conv in KVChain.cons a₁ b₁ ys ha₁ys => unfold KVChain.cons
  dsimp [insertWithAux.loop]
  rw [dif_neg (Asymmetry.asymm _ _ haa₁), dif_pos haa₁]

theorem insertWithAux_cons_rfl {xs : KVChain (flip r) β} {a : α} {b₁ : β a} {ys : KVChain r β} {hays : ys.boundLeft a} {haxs : xs.hingeable (ys.cons a b₁ hays)} {b : β a} {haxs' : xs.boundLeft a}: insertWithAux f xs (ys.cons a b₁ hays) haxs a b haxs' = (f a b₁ b).casesOn ⟨(xs, ys), hingeable_skip_right haxs⟩ (λ bf => ⟨(xs.cons a bf haxs', ys), Eq.symm (cons_hingeable (a:=a) (xs:=xs) (haxs:=haxs')) ▸ hays⟩) := by
  unfold insertWithAux
  conv in KVChain.cons a b₁ ys => unfold KVChain.cons
  dsimp [insertWithAux.loop]
  rw [dif_neg (Irreflective.irrefl (r:=r) _), dif_neg (Irreflective.irrefl (r:=r) _)]
  cases hf : f a b₁ b <;> rfl

theorem toList_fst_insertWithAux_eq_append {xs : KVChain (flip r) β} {ys : KVChain r β} {hxsys : xs.hingeable ys} {a : α} {b : β a} {haxs : xs.boundLeft a} : (insertWithAux f xs ys hxsys a b haxs).val.fst.toList = (insertWithAux f KVChain.nil ys True.intro a b True.intro).val.fst.toList ++ xs.toList := by
  revert xs
  apply ys.recOnList (motive:=λ ys=>∀ xs hxsys haxs, (insertWithAux f xs ys hxsys a b haxs).val.fst.toList = (insertWithAux f KVChain.nil ys True.intro a b True.intro).val.fst.toList ++ xs.toList)
  case nil => intros; rfl
  case cons =>
    intro a₁ b₁ ys ha₁ys h_ind xs ha₁xs haxs
    apply dite (r a₁ a) <;> intro ha₁a
    . rw [insertWithAux_cons_rel ha₁a]
      rw [insertWithAux_cons_rel ha₁a]
      rw [h_ind (xs.cons a₁ b₁ _), h_ind ⟨[⟨a₁,b₁⟩], _⟩]
      rw [KVChain.toList_cons]
      dsimp
      rw [List.append_cons]
    . apply dite (r a a₁) <;> intro haa₁
      . rw [insertWithAux_cons_flip haa₁]
        rw [insertWithAux_cons_flip haa₁]
        rfl
      . have : a = a₁ := Trichotomous.eq_of_incomp ⟨haa₁, ha₁a⟩
        cases this
        rw [insertWithAux_cons_rfl]
        rw [insertWithAux_cons_rfl]
        cases f a b₁ b <;> rfl

theorem toList_snd_insertWithAux_inv {xs : KVChain (flip r) β} {ys : KVChain r β} {hxsys : xs.hingeable ys} {a : α} {b : β a} {haxs : xs.boundLeft a} : (insertWithAux f xs ys hxsys a b haxs).val.snd = (insertWithAux f KVChain.nil ys True.intro a b True.intro).val.snd := by
  revert xs
  apply ys.recOnList (motive:=λ ys =>∀ xs hxsys haxs, (insertWithAux f xs ys hxsys a b haxs).val.snd = (insertWithAux f KVChain.nil ys True.intro a b True.intro).val.snd)
  case nil => intros; rfl
  case cons =>
    intro a₁ b₁ ys ha₁ys h_ind xs hxsys haxs
    apply dite (r a₁ a) <;> intro ha₁a
    . rw [insertWithAux_cons_rel ha₁a]
      rw [insertWithAux_cons_rel ha₁a]
      rw [h_ind, h_ind ⟨[⟨a₁,b₁⟩], _⟩]
    . apply dite (r a a₁) <;> intro haa₁
      . rw [insertWithAux_cons_flip haa₁]
        rw [insertWithAux_cons_flip haa₁]
      . have : a = a₁ := Trichotomous.eq_of_incomp ⟨haa₁, ha₁a⟩
        cases this
        rw [insertWithAux_cons_rfl]
        rw [insertWithAux_cons_rfl]
        cases f a b₁ b <;> rfl

theorem forAll_fst_insertWithAux {xs : KVChain (flip r) β} {ys : KVChain r β} {hxsys : xs.hingeable ys} {a : α} {b : β a} {haxs : xs.boundLeft a} : ∀ {p : α → Prop}, xs.toList.forAll (p ∘ Sigma.fst) → ys.toList.forAll (p ∘ Sigma.fst) → p a → (insertWithAux f xs ys hxsys a b haxs).val.fst.toList.forAll (p ∘ Sigma.fst) ∧ (insertWithAux f xs ys hxsys a b haxs).val.snd.toList.forAll (p ∘ Sigma.fst) := by
  intro p; revert xs;
  apply ys.recOnList (motive:=λ ys=>∀ xs hxsys haxs, xs.toList.forAll (p ∘ Sigma.fst) → ys.toList.forAll (p ∘ Sigma.fst) → p a → (insertWithAux f xs ys hxsys a b haxs).val.fst.toList.forAll (p ∘ Sigma.fst) ∧ (insertWithAux f xs ys hxsys a b haxs).val.snd.toList.forAll (p ∘ Sigma.fst))
  case nil =>
    intro xs hxsys haxs hpxs _ hpa
    dsimp [insertWithAux, insertWithAux.loop]
    exact ⟨⟨hpa, hpxs⟩, True.intro⟩
  case cons =>
    intro a₁ b₁ ys ha₁ys h_ind xs ha₁xs hzxs hpxs hpys hpa
    apply dite (r a₁ a) <;> intro ha₁a
    . rw [insertWithAux_cons_rel ha₁a]
      exact h_ind (xs.cons a₁ b₁ (hingeable_cons ▸ ha₁xs)) (cons_hingeable.symm ▸ ha₁ys) ha₁a ⟨hpys.left, hpxs⟩ hpys.right hpa
    . apply dite (r a a₁) <;> intro haa₁
      . rw [insertWithAux_cons_flip haa₁]
        dsimp
        exact ⟨⟨hpa,hpxs⟩,hpys⟩
      . have : a = a₁ := Trichotomous.eq_of_incomp ⟨haa₁, ha₁a⟩
        cases this
        rw [insertWithAux_cons_rfl]
        cases f a b₁ b
        case none => exact ⟨hpxs, hpys.right⟩
        case some bf => exact ⟨⟨hpys.left, hpxs⟩, hpys.right⟩

theorem boundLeft_insertWithAux_fst {xs : KVChain (flip r) β} {ys : KVChain r β} {hxsys : xs.hingeable ys} {a : α} {b : β a} {haxs : xs.boundLeft a} : ∀ {c : α}, r a c → (insertWithAux f xs ys hxsys a b haxs).val.fst.boundLeft c := by
  intro c hac
  revert xs
  apply ys.recOnList (motive:=λ ys=>∀ xs hxsys haxs, (insertWithAux f xs ys hxsys a b haxs).val.fst.boundLeft c)
  case nil =>
    intros; dsimp; exact hac
  case cons =>
    intro a₁ b₁ ys ha₁ys h_ind xs ha₁xs haxs
    apply dite (r a₁ a) <;> intro ha₁a
    . rw [insertWithAux_cons_rel ha₁a]
      exact h_ind _ (cons_hingeable.symm ▸ ha₁ys) (by dsimp; exact ha₁a)
    . apply dite (r a a₁) <;> intro haa₁
      . rw [insertWithAux_cons_flip haa₁]
        exact hac
      . have : a = a₁ := Trichotomous.eq_of_incomp ⟨haa₁, ha₁a⟩
        cases this
        rw [insertWithAux_cons_rfl]
        cases f a b₁ b
        case none =>
          apply boundLeft_descend _ haxs
          exact λ _ => flip (trans (r:=r) (s:=r) (t:=r)) hac
        case some bf => exact hac

@[simp]
theorem insertWith_nil : ∀ {a : α} {b : β a}, insertWith (r:=r) f KVChain.nil a b = ⟨[⟨a,b⟩], List.Ascending.singleton _⟩ := rfl

theorem boundLeft_insertWith_of_boundLeft {xs : KVChain r β} {a : α} {b : β a} : ∀ (d : α), xs.boundLeft d → r d a → (xs.insertWith f a b).boundLeft d := by
  apply xs.recOnList (motive:=λ xs=>∀ d, xs.boundLeft d → r d a → (xs.insertWith f a b).boundLeft d)
  case nil =>
    intro a _ hab
    rw [insertWith_nil]
    exact hab
  case cons =>
    intro a₁ b₁ xs ha₁xs _ d hdxs hda
    unfold insertWith
    dsimp [boundLeft]
    apply List.predHead_of_forAll
    rw [List.forAll_reverseAux]
    apply forAll_fst_insertWithAux
    . exact True.intro
    . apply (xs.cons a₁ b₁ ha₁xs).ascend.forAll_of_predHead
      . exact λ _ _ h₁ h₂ => trans (t:=r) h₁ h₂
      . exact hdxs
    . exact hda

theorem insertWith_cons_of_rel {a₁ : α} {b₁ : β a₁} {xs : KVChain r β} {ha₁xs : xs.boundLeft a₁} {a : α} {b : β a} : (ha₁a : r a₁ a) → insertWith f (xs.cons a₁ b₁ ha₁xs) a b = (insertWith f xs a b).cons a₁ b₁ (boundLeft_insertWith_of_boundLeft a₁ ha₁xs ha₁a) := by
  intro ha₁a
  cases xs
  conv => lhs; dsimp [insertWith]; rw [insertWithAux_cons_rel ha₁a]
  apply KVChain.eq_of_toList_eq
  dsimp
  rw [toList_fst_insertWithAux_eq_append]
  rw [toList_snd_insertWithAux_inv]
  dsimp
  rw [List.reverseAux_append_left]
  rfl

theorem insertWith_cons_of_flip {a₁ : α} {b₁ : β a₁} {xs : KVChain r β} {ha₁xs : xs.boundLeft a₁} {a : α} {b : β a} : ∀ (haa₁ : r a a₁), insertWith f (xs.cons a₁ b₁ ha₁xs) a b = (xs.cons a₁ b₁ ha₁xs).cons a b haa₁ := by
  intro haa₁
  unfold insertWith
  rw [insertWithAux_cons_flip haa₁]
  rfl

theorem insertWith_cons_of_eq {xs : KVChain r β} {a : α} {b₁ : β a} {haxs : xs.boundLeft a} {b : β a} : insertWith f (xs.cons a b₁ haxs) a b = (f a b₁ b).casesOn xs (λ bf => xs.cons a bf haxs) := by
  unfold insertWith
  rw [insertWithAux_cons_rfl]
  cases f a b₁ b <;> rfl

end Theorems

/-
## Merge two `KVChain`s
-/

--- Merge two `KVChain`s with an operation on collision.
def mergeWith (f : (a : α) → β a → β a → Option (β a)) (xs ys : KVChain r β) : KVChain r β :=
  let rec loop : (xs_r : KVChain (flip r) β) → (xs : KVChain r β) → xs_r.hingeable xs → (ys : List (Sigma β)) → ys.Ascending (Sigma.relOnFst r) → ys.predHead (xs_r.boundLeft ∘ Sigma.fst) → KVChain r β
  | xs_r, xs, hxs, [] => λ _ _ => xs_r.hinge xs hxs
  | xs_r, xs, hxs, yys@(y::ys) => λ hascendy hxyys =>
    match xs.toList with
    | [] => xs_r.hinge ⟨yys, (‹yys=_› ▸ hascendy)⟩ $ by
      dsimp [hingeable]
      rw [‹yys=_›, List.relHead_cons_right]
      exact hxyys
    | (_::_) =>
      match hmatch : insertWithAux f xs_r xs hxs y.1 y.2 hxyys with
      | Subtype.mk (xs_r', xs') h =>
          loop xs_r' xs' h ys hascendy.tail $ by
            cases ys
            case nil => exact True.intro
            case cons y₁ ys _ =>
              dsimp [List.predHead]
              have := boundLeft_insertWithAux_fst (r:=r) (β:=β) (f:=f) (xs:=xs_r) (ys:=xs) (hxsys:=hxs) (a:=y.1) (b:=y.2) (haxs:=hxyys) (c:=y₁.1)
              rw [hmatch] at this
              exact this hascendy.head
  loop KVChain.nil xs True.intro ys.toList ys.ascend $ by
    dsimp [boundLeft, List.predHead]
    cases ys.toList <;> exact True.intro

section Theorems

variable {f : (a : α) → β a → β a → Option (β a)}

@[simp]
theorem nil_mergeWith : ∀ (xs : KVChain r β), mergeWith f KVChain.nil xs = xs
| mk xs _ => by
  dsimp [KVChain.nil, mergeWith, mergeWith.loop]
  cases xs <;> rfl

@[simp]
theorem mergeWith_nil : ∀ (xs : KVChain r β), mergeWith f xs KVChain.nil = xs
| mk xs _ => by
  dsimp [KVChain.nil, mergeWith]
  rfl

theorem toList_mergeWith_loop_eq_reverseAux {xs_r : KVChain (flip r) β} {xs : KVChain r β} {hxs : xs_r.hingeable xs} : ∀ {ys : List (Sigma β)} {hascend : ys.Ascending (Sigma.relOnFst r)} {hxsys : ys.predHead (xs_r.boundLeft ∘ Sigma.fst)}, (mergeWith.loop f xs_r xs hxs ys hascend hxsys).toList = List.reverseAux xs_r.toList (mergeWith f xs ⟨ys, hascend⟩).toList := by
  intro ys; revert xs_r xs; induction ys <;> dsimp
  case nil => intros; rfl
  case cons y ys h_ind =>
    intro xs_r xs hxs hascend hyxs
    unfold mergeWith.loop
    revert hxs
    apply xs.recOnList (motive:=λ xs=> ∀ hxs, (mergeWith.loop f xs_r xs hxs (y::ys) hascend hyxs).toList = List.reverseAux xs_r.toList (mergeWith f xs ⟨(y::ys), hascend⟩).toList)
    case nil =>
      intro hxy; rfl
    case cons =>
      intro a b  xs haxs _ hxs
      dsimp [mergeWith.loop]
      rw [h_ind]
      rw [toList_fst_insertWithAux_eq_append]
      rw [toList_snd_insertWithAux_inv]
      rw [List.reverseAux_append_left]
      rw [List.reverseAux_eq_append (as:=xs_r.toList)]
      apply congrArg (xs_r.toList.reverse ++ ·)
      conv =>
        rhs
        unfold mergeWith
        unfold mergeWith.loop
        rw [h_ind]

theorem boundLeft_mergeWith (d : α) {xs ys : KVChain r β} : xs.boundLeft d → ys.boundLeft d → (mergeWith f xs ys).boundLeft d := by
  revert xs
  apply ys.recOnList (motive:=λ ys=> ∀ xs, xs.boundLeft d → ys.boundLeft d → (mergeWith f xs ys).boundLeft d)
  case nil =>
    intros; rw [mergeWith_nil]; assumption
  case cons =>
    intro a₂ b₂ ys ha₂ys h_ind_ys xs hdxs hda₂
    revert h_ind_ys hdxs
    apply xs.recOnList (motive:=λ xs=> (∀ xs₁, xs₁.boundLeft d → ys.boundLeft d → (mergeWith f xs₁ ys).boundLeft d) → xs.boundLeft d → (mergeWith f xs (ys.cons a₂ b₂ ha₂ys)).boundLeft d)
    case nil => rw [nil_mergeWith]; exact λ _ _=> hda₂
    case cons =>
      intro a₁ b₁ xs ha₁xs _ h_ind_ys hda₁
      dsimp [boundLeft, hingeable, mergeWith, mergeWith.loop]
      rw [toList_mergeWith_loop_eq_reverseAux]
      apply dite (r a₁ a₂) <;> intro ha₁a₂
      . rw [insertWithAux_cons_rel ha₁a₂]
        rw [toList_fst_insertWithAux_eq_append]
        rw [List.reverseAux_append_left]
        dsimp [List.reverse, List.reverseAux]
        exact hda₁
      . apply dite (r a₂ a₁) <;> intro ha₂a₁
        . rw [insertWithAux_cons_flip ha₂a₁]
          dsimp [List.reverseAux]
          exact hda₂
        . have : a₂ = a₁ := Trichotomous.eq_of_incomp ⟨ha₂a₁, ha₁a₂⟩
          cases this
          rw [insertWithAux_cons_rfl]
          cases f a₂ b₁ b₂ <;> dsimp
          case none =>
            dsimp [List.reverseAux]
            apply h_ind_ys
            . exact boundLeft_descend (λ _=> trans hda₂) ha₁xs
            . exact boundLeft_descend (λ _=> trans hda₁) ha₂ys
          case some bf =>
            dsimp [List.reverseAux, List.predHead]
            exact hda₂

theorem toList_mergeWith_cons_right {xs : KVChain r β} {a : α} {b : β a} {ys : KVChain r β} {hays : ys.boundLeft a} : (mergeWith f xs (ys.cons a b hays)).toList = List.reverseAux (insertWithAux f KVChain.nil xs True.intro a b True.intro).val.fst (mergeWith f (insertWithAux f KVChain.nil xs True.intro a b True.intro).val.snd ys).toList := by
  apply xs.recOnList (motive:=λ xs=>(mergeWith f xs (ys.cons a b hays)).toList=List.reverseAux (insertWithAux f KVChain.nil xs True.intro a b True.intro).val.fst.toList (mergeWith f (insertWithAux f KVChain.nil xs True.intro a b True.intro).val.snd ys).toList)
  case nil =>
    rw [nil_mergeWith]
    dsimp [List.reverseAux]
    rw [nil_mergeWith]
  case cons =>
    intro a x hax hpa _
    conv =>
      lhs
      unfold mergeWith; unfold mergeWith.loop
      simp
    rw [toList_mergeWith_loop_eq_reverseAux]

theorem cons_mergeWith_rel : ∀ {a : α} {b : β a} {xs : KVChain r β} {haxs : xs.boundLeft a} {ys : KVChain r β}, (hays : ys.boundLeft a) → mergeWith f (xs.cons a b haxs) ys = (mergeWith f xs ys).cons a b (boundLeft_mergeWith a haxs hays) := by
  intro a b xs haxs ys
  revert xs
  apply ys.recOnList (motive:=λ ys => ∀ xs haxs hays, mergeWith f (xs.cons a b haxs) ys = (mergeWith f xs ys).cons a b (boundLeft_mergeWith a haxs hays))
  case nil=> intros; rfl
  case cons =>
    intro b y hby hpb _ x hax hab
    apply KVChain.eq_of_toList_eq
    rw [toList_mergeWith_cons_right]
    rw [KVChain.toList_cons]
    rw [toList_mergeWith_cons_right]
    conv =>
      lhs
      rw [insertWithAux_cons_rel hab]
      rw [toList_fst_insertWithAux_eq_append]
      rw [toList_snd_insertWithAux_inv]
      rw [List.reverseAux_append_left]

theorem mergeWith_cons_flip : ∀ {xs : KVChain r β} {a : α} {b : β a} {ys : KVChain r β} {hays : ys.boundLeft a}, (haxs : xs.boundLeft a) → mergeWith f xs (ys.cons a b hays) = (mergeWith f xs ys).cons a b (boundLeft_mergeWith a haxs hays) := by
  intro xs a b ys hays haxs
  apply KVChain.eq_of_toList_eq
  rw [toList_mergeWith_cons_right]
  suffices (insertWithAux f KVChain.nil xs True.intro a b True.intro).val = (⟨[⟨a,b⟩],List.Ascending.singleton _⟩,xs) by
    rw [this]; rfl
  revert haxs
  apply xs.recOnList (motive:=λ xs=> xs.boundLeft a → (insertWithAux f KVChain.nil xs _ _ _ _).val=_)
  case a.nil => intros; rfl
  case a.cons =>
    intro a₁ b₁ xs ha₁xs _ haa₁
    dsimp [boundLeft, List.predHead] at haa₁
    rw [insertWithAux_cons_flip haa₁]

theorem cons_mergeWith_cons_rel {a₁ a₂ : α} {b₁ : β a₁} {b₂ : β a₂} {xs ys : KVChain r β} {ha₁xs : xs.boundLeft a₁} {ha₂ys : ys.boundLeft a₂} : (ha₁a₂ : r a₁ a₂) → mergeWith f (xs.cons a₁ b₁ ha₁xs) (ys.cons a₂ b₂ ha₂ys) = (mergeWith f xs (ys.cons a₂ b₂ ha₂ys)).cons a₁ b₁ (boundLeft_mergeWith a₁ ha₁xs ha₁a₂) :=
  cons_mergeWith_rel (ys:=ys.cons a₂ b₂ ha₂ys)

theorem cons_mergeWith_cons_flip {a₁ a₂ : α} {b₁ : β a₁} {b₂ : β a₂} {xs ys : KVChain r β} {ha₁xs : xs.boundLeft a₁} {ha₂ys : ys.boundLeft a₂} : (ha₂a₁ : r a₂ a₁) → mergeWith f (xs.cons a₁ b₁ ha₁xs) (ys.cons a₂ b₂ ha₂ys) = (mergeWith f (xs.cons a₁ b₁ ha₁xs) ys).cons a₂ b₂ (boundLeft_mergeWith a₂ ha₂a₁ ha₂ys) :=
  mergeWith_cons_flip (xs:=xs.cons a₁ b₁ ha₁xs)

theorem cons_mergeWith_cons_rfl {a : α} {b₁ b₂ : β a} {xs ys : KVChain r β} {haxs : xs.boundLeft a} {hays : ys.boundLeft a} : mergeWith f (xs.cons a b₁ haxs) (ys.cons a b₂ hays) = (f a b₁ b₂).casesOn (mergeWith f xs ys) (λ bf => (mergeWith f xs ys).cons a bf (boundLeft_mergeWith a haxs hays)) := by
  apply KVChain.eq_of_toList_eq
  rw [toList_mergeWith_cons_right]
  rw [insertWithAux_cons_rfl]
  cases f a b₁ b₂ <;> rfl

theorem mergeWith_flip {xs ys : KVChain r β} : mergeWith f xs ys = mergeWith (λ a => flip (f a)) ys xs :=
  xs.recOnListOn
    (λ _ => by simp)
    (λ x₁ x₂ xs hxs h_ind_xs ys =>
      ys.recOnListOn
        (by simp)
        (λ y₁ y₂ ys hys h_ind_ys => by
          apply eq_of_toList_eq
          apply dite (r x₁ y₁) <;> intro hx₁y₁
          . rw [cons_mergeWith_cons_rel hx₁y₁]
            rw [cons_mergeWith_cons_flip hx₁y₁]
            dsimp
            rw [h_ind_xs]
          . apply dite (r y₁ x₁) <;> intro hy₁x₁
            . rw [cons_mergeWith_cons_flip hy₁x₁]
              rw [cons_mergeWith_cons_rel hy₁x₁]
              dsimp
              rw [h_ind_ys]
            . have : x₁ = y₁ := Trichotomous.eq_of_incomp ⟨hx₁y₁, hy₁x₁⟩
              cases this
              rw [cons_mergeWith_cons_rfl, cons_mergeWith_cons_rfl]
              dsimp [flip] at *
              cases f x₁ x₂ y₂ <;> dsimp <;> rw [h_ind_xs]
        )
    ) ys

theorem mergeWith_congrFun {f g : (a : α) → β a → β a → Option (β a)} (hfg : ∀ (a : α) (b₁ b₂ : β a), f a b₁ b₂ = g a b₁ b₂) {xs ys : KVChain r β} : mergeWith f xs ys = mergeWith g xs ys :=
  xs.recOnListOn
    (λ _ => by rw [nil_mergeWith, nil_mergeWith])
    (λ x₁ x₂ xs hxs h_ind_xs ys =>
      ys.recOnListOn
        (by rw [mergeWith_nil, mergeWith_nil])
        (λ y₁ y₂ ys hys h_ind_ys => by
          apply eq_of_toList_eq
          apply dite (r x₁ y₁) <;> intro hx₁y₁
          . rw [cons_mergeWith_cons_rel hx₁y₁]
            rw [cons_mergeWith_cons_rel hx₁y₁]
            dsimp
            rw [h_ind_xs]
          apply dite (r y₁ x₁) <;> intro hy₁x₁
          . rw [cons_mergeWith_cons_flip hy₁x₁]
            rw [cons_mergeWith_cons_flip hy₁x₁]
            dsimp
            rw [h_ind_ys]
          have : x₁ = y₁ := Trichotomous.eq_of_incomp ⟨hx₁y₁, hy₁x₁⟩
          cases this
          rw [cons_mergeWith_cons_rfl, cons_mergeWith_cons_rfl]
          dsimp
          rw [hfg]
          cases g x₁ x₂ y₂ <;> dsimp <;> rw [h_ind_xs]
        )
    ) ys

theorem rklex_mergeWith_right {s : (a : α) → β a → β a → Prop} {f : (a : α) → β a → β a → β a} {xs ys zs : KVChain r β} (hsf_right : ∀ a b₁ b, s a b₁ (f a b b₁)) (hsf_stab : ∀ a b₁ b₂ b, s a b₁ b₂ → s a (f a b₁ b) (f a b₂ b)) : KVChain.rklex s xs ys → KVChain.rklex s (xs.mergeWith (λ a b₁ b₂ => some (f a b₁ b₂)) zs) (ys.mergeWith (λ a b₁ b₂ => some (f a b₁ b₂)) zs) :=
  zs.recOnListOn (motive:=λ zs=>∀ xs ys, KVChain.rklex s xs ys → KVChain.rklex s (xs.mergeWith (λ a b₁ b₂ => some (f a b₁ b₂)) zs) (ys.mergeWith (λ a b₁ b₂ => some (f a b₁ b₂)) zs))
    (λ _ _ => by rw [mergeWith_nil]; exact id)
    (λ z₁ z₂ zs hzs h_ind_zs xs ys h =>
      h.recOn
        (λ a b ys hays => by
          have h_ind_zs := h_ind_zs KVChain.nil
          dsimp at *
          rw [nil_mergeWith] at *
          apply dite (r a z₁) <;> intro haz₁
          . rw [cons_mergeWith_cons_rel haz₁]
            exact KVChain.rklex.headFst haz₁
          apply dite (r z₁ a) <;> intro hz₁a
          . rw [cons_mergeWith_cons_flip hz₁a]
            exact KVChain.rklex.tail (h_ind_zs _ KVChain.rklex.nil)
          have : a = z₁ := Trichotomous.eq_of_incomp ⟨haz₁, hz₁a⟩
          cases this
          rw [cons_mergeWith_cons_rfl]
          exact KVChain.rklex.headSnd $ hsf_right _ _ _
        )
        (λ a₁ a₂ b₁ b₂ xs ys haxs hays ha₂a₁=> by
          dsimp
          apply dite (r z₁ a₂) <;> intro hz₁a₂
          . rw [cons_mergeWith_cons_flip hz₁a₂]
            rw [cons_mergeWith_cons_flip (trans hz₁a₂ ha₂a₁)]
            apply KVChain.rklex.tail
            exact h_ind_zs _ _ (KVChain.rklex.headFst ha₂a₁)
          apply dite (r a₂ z₁) <;> intro ha₂z₁
          . rw [cons_mergeWith_cons_rel ha₂z₁]
            apply dite (r z₁ a₁) <;> intro hz₁a₁
            . rw [cons_mergeWith_cons_flip hz₁a₁]
              exact KVChain.rklex.headFst ha₂z₁
            apply dite (r a₁ z₁) <;> intro ha₁z₁
            . rw [cons_mergeWith_cons_rel ha₁z₁]
              exact KVChain.rklex.headFst ha₂a₁
            have : z₁ = a₁ := Trichotomous.eq_of_incomp ⟨hz₁a₁, ha₁z₁⟩
            cases this
            rw [cons_mergeWith_cons_rfl]
            exact KVChain.rklex.headFst ha₂a₁
          have : z₁ = a₂ := Trichotomous.eq_of_incomp ⟨hz₁a₂, ha₂z₁⟩
          cases this
          rw [cons_mergeWith_cons_rfl]
          rw [cons_mergeWith_cons_flip ha₂a₁]
          dsimp
          exact KVChain.rklex.headSnd $ hsf_right _ _ _
        )
        (λ a b₁ b₂ xs ys haxs hays hb₁b₂ => by
          apply dite (r a z₁) <;> intro haz₁
          . rw [cons_mergeWith_cons_rel haz₁]
            rw [cons_mergeWith_cons_rel haz₁]
            exact KVChain.rklex.headSnd hb₁b₂
          apply dite (r z₁ a) <;> intro hz₁a
          . rw [cons_mergeWith_cons_flip hz₁a]
            rw [cons_mergeWith_cons_flip hz₁a]
            apply KVChain.rklex.tail (h_ind_zs _ _ $ KVChain.rklex.headSnd hb₁b₂)
          have : a = z₁ := Trichotomous.eq_of_incomp ⟨haz₁, hz₁a⟩
          cases this
          rw [cons_mergeWith_cons_rfl]
          rw [cons_mergeWith_cons_rfl]
          dsimp
          exact KVChain.rklex.headSnd $ hsf_stab _ _ _ _ hb₁b₂
        )
        (λ a b xs ys haxs hays htail h_ind => by
          apply dite (r a z₁) <;> intro haz₁
          . rw [cons_mergeWith_cons_rel haz₁]
            rw [cons_mergeWith_cons_rel haz₁]
            exact KVChain.rklex.tail h_ind
          apply dite (r z₁ a) <;> intro hz₁a
          . rw [cons_mergeWith_cons_flip hz₁a]
            rw [cons_mergeWith_cons_flip hz₁a]
            exact KVChain.rklex.tail (h_ind_zs _ _ $ KVChain.rklex.tail htail)
          have : a = z₁ := Trichotomous.eq_of_incomp ⟨haz₁, hz₁a⟩
          cases this
          rw [cons_mergeWith_cons_rfl]
          rw [cons_mergeWith_cons_rfl]
          exact KVChain.rklex.tail (h_ind_zs _ _ htail)
        )
    )
    xs ys

end Theorems

end KVChain


inductive States | s0 | s1 | s2 | s3 | s4 | s5 | s6 | s7
open States
def f : States → States → States
| s0, s0 => s0
| s0, s1 => s0
| s0, s2 => s0
| s0, s3 => s0
| s0, s4 => s0
| s0, s5 => s0
| s0, s6 => s0
| s0, s7 => s0
| s1, s0 => s0
| s1, s1 => s0
| s1, s2 => s0
| s1, s3 => s0
| s1, s4 => s0
| s1, s5 => s0
| s1, s6 => s0
| s1, s7 => s0
| s2, s0 => s0
| s2, s1 => s0
| s2, s2 => s0
| s2, s3 => s0
| s2, s4 => s0
| s2, s5 => s0
| s2, s6 => s0
| s2, s7 => s0
| s3, s0 => s0
| s3, s1 => s0
| s3, s2 => s0
| s3, s3 => s0
| s3, s4 => s0
| s3, s5 => s0
| s3, s6 => s0
| s3, s7 => s0
| s4, s0 => s0
| s4, s1 => s0
| s4, s2 => s0
| s4, s3 => s0
| s4, s4 => s0
| s4, s5 => s0
| s4, s6 => s0
| s4, s7 => s0
| s5, s0 => s0
| s5, s1 => s0
| s5, s2 => s0
| s5, s3 => s0
| s5, s4 => s0
| s5, s5 => s0
| s5, s6 => s0
| s5, s7 => s0
| s6, s0 => s0
| s6, s1 => s0
| s6, s2 => s0
| s6, s3 => s0
| s6, s4 => s0
| s6, s5 => s0
| s6, s6 => s0
| s6, s7 => s0
| s7, s0 => s0
| s7, s1 => s0
| s7, s2 => s0
| s7, s3 => s0
| s7, s4 => s0
| s7, s5 => s0
| s7, s6 => s0
| s7, s7 => s0
set_option maxHeartbeats 0
example : ∀ x y z, f (f (f s0 x) y) z = f (f x z) (f y z) := by
 intros x y z
 cases x <;> cases y <;> cases z <;> rfl


/-
Copyright (c) 2020 Markus Himmel. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Markus Himmel
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.algebra.group.hom
import Mathlib.category_theory.limits.shapes.kernels
import Mathlib.algebra.big_operators.basic
import Mathlib.PostPort

universes v u l u_1

namespace Mathlib

/-!
# Preadditive categories

A preadditive category is a category in which `X ⟶ Y` is an abelian group in such a way that
composition of morphisms is linear in both variables.

This file contains a definition of preadditive category that directly encodes the definition given
above. The definition could also be phrased as follows: A preadditive category is a category
enriched over the category of Abelian groups. Once the general framework to state this in Lean is
available, the contents of this file should become obsolete.

## Main results

* Definition of preadditive categories and basic properties
* In a preadditive category, `f : Q ⟶ R` is mono if and only if `g ≫ f = 0 → g = 0` for all
  composable `g`.
* A preadditive category with kernels has equalizers.

## Implementation notes

The simp normal form for negation and composition is to push negations as far as possible to
the outside. For example, `f ≫ (-g)` and `(-f) ≫ g` both become `-(f ≫ g)`, and `(-f) ≫ (-g)`
is simplified to `f ≫ g`.

## References

* [F. Borceux, *Handbook of Categorical Algebra 2*][borceux-vol2]

## Tags

additive, preadditive, Hom group, Ab-category, Ab-enriched
-/

namespace category_theory

/-- A category is called preadditive if `P ⟶ Q` is an abelian group such that composition is
    linear in both variables. -/
class preadditive (C : Type u) [category C]
where
  hom_group : autoParam ((P Q : C) → add_comm_group (P ⟶ Q))
  (Lean.Syntax.ident Lean.SourceInfo.none (String.toSubstring "Mathlib.tactic.apply_instance")
    (Lean.Name.mkStr (Lean.Name.mkStr (Lean.Name.mkStr Lean.Name.anonymous "Mathlib") "tactic") "apply_instance") [])
  add_comp' : autoParam (∀ (P Q R : C) (f f' : P ⟶ Q) (g : Q ⟶ R), (f + f') ≫ g = f ≫ g + f' ≫ g)
  (Lean.Syntax.ident Lean.SourceInfo.none (String.toSubstring "Mathlib.obviously")
    (Lean.Name.mkStr (Lean.Name.mkStr Lean.Name.anonymous "Mathlib") "obviously") [])
  comp_add' : autoParam (∀ (P Q R : C) (f : P ⟶ Q) (g g' : Q ⟶ R), f ≫ (g + g') = f ≫ g + f ≫ g')
  (Lean.Syntax.ident Lean.SourceInfo.none (String.toSubstring "Mathlib.obviously")
    (Lean.Name.mkStr (Lean.Name.mkStr Lean.Name.anonymous "Mathlib") "obviously") [])

@[simp] theorem preadditive.add_comp {C : Type u} [category C] [c : preadditive C] (P : C) (Q : C) (R : C) (f : P ⟶ Q) (f' : P ⟶ Q) (g : Q ⟶ R) : (f + f') ≫ g = f ≫ g + f' ≫ g := sorry

@[simp] theorem preadditive.comp_add {C : Type u} [category C] [c : preadditive C] (P : C) (Q : C) (R : C) (f : P ⟶ Q) (g : Q ⟶ R) (g' : Q ⟶ R) : f ≫ (g + g') = f ≫ g + f ≫ g' := sorry

@[simp] theorem preadditive.add_comp_assoc {C : Type u} [category C] [c : preadditive C] (P : C) (Q : C) (R : C) (f : P ⟶ Q) (f' : P ⟶ Q) (g : Q ⟶ R) {X' : C} : ∀ (f'_1 : R ⟶ X'), (f + f') ≫ g ≫ f'_1 = (f ≫ g + f' ≫ g) ≫ f'_1 := sorry

theorem preadditive.comp_add_assoc {C : Type u} [category C] [c : preadditive C] (P : C) (Q : C) (R : C) (f : P ⟶ Q) (g : Q ⟶ R) (g' : Q ⟶ R) {X' : C} (f' : R ⟶ X') : f ≫ (g + g') ≫ f' = (f ≫ g + f ≫ g') ≫ f' := sorry

end category_theory

namespace category_theory.preadditive

/-- Composition by a fixed left argument as a group homomorphism -/
def left_comp {C : Type u} [category C] [preadditive C] {P : C} {Q : C} (R : C) (f : P ⟶ Q) : (Q ⟶ R) →+ (P ⟶ R) :=
  add_monoid_hom.mk' (fun (g : Q ⟶ R) => f ≫ g) sorry

/-- Composition by a fixed right argument as a group homomorphism -/
def right_comp {C : Type u} [category C] [preadditive C] (P : C) {Q : C} {R : C} (g : Q ⟶ R) : (P ⟶ Q) →+ (P ⟶ R) :=
  add_monoid_hom.mk' (fun (f : P ⟶ Q) => f ≫ g) sorry

@[simp] theorem sub_comp_assoc {C : Type u} [category C] [preadditive C] {P : C} {Q : C} {R : C} (f : P ⟶ Q) (f' : P ⟶ Q) (g : Q ⟶ R) {X' : C} : ∀ (f'_1 : R ⟶ X'), (f - f') ≫ g ≫ f'_1 = (f ≫ g - f' ≫ g) ≫ f'_1 := sorry

-- The redundant simp lemma linter says that simp can prove the reassoc version of this lemma.

@[simp] theorem comp_sub {C : Type u} [category C] [preadditive C] {P : C} {Q : C} {R : C} (f : P ⟶ Q) (g : Q ⟶ R) (g' : Q ⟶ R) : f ≫ (g - g') = f ≫ g - f ≫ g' :=
  add_monoid_hom.map_sub (left_comp R f) g g'

@[simp] theorem neg_comp {C : Type u} [category C] [preadditive C] {P : C} {Q : C} {R : C} (f : P ⟶ Q) (g : Q ⟶ R) : (-f) ≫ g = -f ≫ g :=
  add_monoid_hom.map_neg (right_comp P g) f

/- The redundant simp lemma linter says that simp can prove the reassoc version of this lemma. -/

theorem comp_neg_assoc {C : Type u} [category C] [preadditive C] {P : C} {Q : C} {R : C} (f : P ⟶ Q) (g : Q ⟶ R) {X' : C} (f' : R ⟶ X') : f ≫ (-g) ≫ f' = (-f ≫ g) ≫ f' := sorry

theorem neg_comp_neg {C : Type u} [category C] [preadditive C] {P : C} {Q : C} {R : C} (f : P ⟶ Q) (g : Q ⟶ R) : (-f) ≫ (-g) = f ≫ g := sorry

theorem comp_sum {C : Type u} [category C] [preadditive C] {P : C} {Q : C} {R : C} {J : Type u_1} {s : finset J} (f : P ⟶ Q) (g : J → (Q ⟶ R)) : (f ≫ finset.sum s fun (j : J) => g j) = finset.sum s fun (j : J) => f ≫ g j := sorry

theorem sum_comp_assoc {C : Type u} [category C] [preadditive C] {P : C} {Q : C} {R : C} {J : Type u_1} {s : finset J} (f : J → (P ⟶ Q)) (g : Q ⟶ R) {X' : C} (f' : R ⟶ X') : finset.sum s f ≫ g ≫ f' = (finset.sum s fun (j : J) => f j ≫ g) ≫ f' := sorry

protected instance has_neg.neg.category_theory.epi {C : Type u} [category C] [preadditive C] {P : C} {Q : C} {f : P ⟶ Q} [epi f] : epi (-f) :=
  epi.mk
    fun (R : C) (g g' : Q ⟶ R) (H : (-f) ≫ g = (-f) ≫ g') =>
      eq.mp (Eq._oldrec (Eq.refl (-g = -g')) (propext neg_inj))
        (eq.mp (Eq._oldrec (Eq.refl (f ≫ (-g) = f ≫ (-g'))) (propext (cancel_epi f)))
          (eq.mp (Eq._oldrec (Eq.refl (f ≫ (-g) = -f ≫ g')) (Eq.symm (comp_neg f g')))
            (eq.mp (Eq._oldrec (Eq.refl (-f ≫ g = -f ≫ g')) (Eq.symm (comp_neg f g)))
              (eq.mp (Eq._oldrec (Eq.refl (-f ≫ g = (-f) ≫ g')) (neg_comp f g'))
                (eq.mp (Eq._oldrec (Eq.refl ((-f) ≫ g = (-f) ≫ g')) (neg_comp f g)) H)))))

protected instance has_neg.neg.category_theory.mono {C : Type u} [category C] [preadditive C] {P : C} {Q : C} {f : P ⟶ Q} [mono f] : mono (-f) :=
  mono.mk
    fun (R : C) (g g' : R ⟶ P) (H : g ≫ (-f) = g' ≫ (-f)) =>
      eq.mp (Eq._oldrec (Eq.refl (-g = -g')) (propext neg_inj))
        (eq.mp (Eq._oldrec (Eq.refl ((-g) ≫ f = (-g') ≫ f)) (propext (cancel_mono f)))
          (eq.mp (Eq._oldrec (Eq.refl ((-g) ≫ f = -g' ≫ f)) (Eq.symm (neg_comp g' f)))
            (eq.mp (Eq._oldrec (Eq.refl (-g ≫ f = -g' ≫ f)) (Eq.symm (neg_comp g f)))
              (eq.mp (Eq._oldrec (Eq.refl (-g ≫ f = g' ≫ (-f))) (comp_neg g' f))
                (eq.mp (Eq._oldrec (Eq.refl (g ≫ (-f) = g' ≫ (-f))) (comp_neg g f)) H)))))

protected instance preadditive_has_zero_morphisms {C : Type u} [category C] [preadditive C] : limits.has_zero_morphisms C :=
  limits.has_zero_morphisms.mk

theorem mono_of_cancel_zero {C : Type u} [category C] [preadditive C] {Q : C} {R : C} (f : Q ⟶ R) (h : ∀ {P : C} (g : P ⟶ Q), g ≫ f = 0 → g = 0) : mono f :=
  mono.mk
    fun (P : C) (g g' : P ⟶ Q) (hg : g ≫ f = g' ≫ f) =>
      iff.mp sub_eq_zero (h (g - g') (Eq.trans (add_monoid_hom.map_sub (right_comp P f) g g') (iff.mpr sub_eq_zero hg)))

theorem mono_iff_cancel_zero {C : Type u} [category C] [preadditive C] {Q : C} {R : C} (f : Q ⟶ R) : mono f ↔ ∀ (P : C) (g : P ⟶ Q), g ≫ f = 0 → g = 0 :=
  { mp := fun (m : mono f) (P : C) (g : P ⟶ Q) => limits.zero_of_comp_mono f, mpr := mono_of_cancel_zero f }

theorem mono_of_kernel_zero {C : Type u} [category C] [preadditive C] {X : C} {Y : C} {f : X ⟶ Y} [limits.has_limit (limits.parallel_pair f 0)] (w : limits.kernel.ι f = 0) : mono f := sorry

theorem epi_of_cancel_zero {C : Type u} [category C] [preadditive C] {P : C} {Q : C} (f : P ⟶ Q) (h : ∀ {R : C} (g : Q ⟶ R), f ≫ g = 0 → g = 0) : epi f :=
  epi.mk
    fun (R : C) (g g' : Q ⟶ R) (hg : f ≫ g = f ≫ g') =>
      iff.mp sub_eq_zero (h (g - g') (Eq.trans (add_monoid_hom.map_sub (left_comp R f) g g') (iff.mpr sub_eq_zero hg)))

theorem epi_iff_cancel_zero {C : Type u} [category C] [preadditive C] {P : C} {Q : C} (f : P ⟶ Q) : epi f ↔ ∀ (R : C) (g : Q ⟶ R), f ≫ g = 0 → g = 0 :=
  { mp := fun (e : epi f) (R : C) (g : Q ⟶ R) => limits.zero_of_epi_comp f, mpr := epi_of_cancel_zero f }

theorem epi_of_cokernel_zero {C : Type u} [category C] [preadditive C] {X : C} {Y : C} (f : X ⟶ Y) [limits.has_colimit (limits.parallel_pair f 0)] (w : limits.cokernel.π f = 0) : epi f := sorry

end preadditive

/-- A kernel of `f - g` is an equalizer of `f` and `g`. -/
theorem preadditive.has_limit_parallel_pair {C : Type u} [category C] [preadditive C] {X : C} {Y : C} (f : X ⟶ Y) (g : X ⟶ Y) [limits.has_kernel (f - g)] : limits.has_limit (limits.parallel_pair f g) := sorry

/-- If a preadditive category has all kernels, then it also has all equalizers. -/
theorem preadditive.has_equalizers_of_has_kernels {C : Type u} [category C] [preadditive C] [limits.has_kernels C] : limits.has_equalizers C :=
  limits.has_equalizers_of_has_limit_parallel_pair C

/-- A cokernel of `f - g` is a coequalizer of `f` and `g`. -/
theorem preadditive.has_colimit_parallel_pair {C : Type u} [category C] [preadditive C] {X : C} {Y : C} (f : X ⟶ Y) (g : X ⟶ Y) [limits.has_cokernel (f - g)] : limits.has_colimit (limits.parallel_pair f g) := sorry

/-- If a preadditive category has all cokernels, then it also has all coequalizers. -/
theorem preadditive.has_coequalizers_of_has_cokernels {C : Type u} [category C] [preadditive C] [limits.has_cokernels C] : limits.has_coequalizers C :=
  limits.has_coequalizers_of_has_colimit_parallel_pair C


import .basic

/-!
 * Hom group of binary_modules.
 -/

namespace binary_module

local attribute [instance] has_binary_add

--- The predicator `is_morphism` is invariant in the type `α → β` under the pointwise operations of binary_modules.
definition inv_is_morphism (α β : Type _) [model binary_module α] [model binary_module β] : inv_pred binary_module (α → β) :=
{
  p := is_morphism binary_module,
  hinv :=
    begin
      intros _ μ fs hfs,
      dunfold is_morphism,
      cases μ,
      case ops.zero {
        cases fs,
        intros _ μ as,
        dunfold premodel.act,
        dsimp *,
        dsimp [vect.unzip_fam],
        rw [vect.map_const],
        let hfix := @model.fixed_op binary_module binary_module.has_trivial_init β _,
        dsimp [model.fixed_element,model.has_trivial_init.init_unit,unit_is_initial,morphism.zero,binary_module.zero] at hfix,
        rw [←hfix]
      },
      case ops.add {
        cases fs with _ f fs, cases fs with _ g gs, cases gs,
        dunfold vect.is_all at hfs,
        unfold premodel.act,
        intros _ μ as,
        dsimp *,
        cases μ,
        case ops.zero {
          cases as,
          rw [vect.unzip_fam_eval],
          dsimp [vect.map],
          rw [hfs.left,hfs.right.left],
          dsimp [vect.map],
          exact binary_module.add_self _
        },
        case ops.add {
          cases as with _ a as; cases as with _ b bs; cases bs,
          dsimp [vect.map],
          repeat {rw [vect.unzip_fam_eval]},
          dsimp [vect.map],
          rw [hfs.left,hfs.right.left]; dsimp [vect.map],
          let hassoc := @binary_module.add_assoc β _,
          let hcomm := @binary_module.add_comm β _,
          dsimp [binary_module.add] at hassoc hcomm,
          rw [hassoc (f a) (f b) _, ←hassoc (f b) (g a) (g b)],
          rw [hcomm (f b) (g a)],
          repeat { rw [hassoc] }
        }
      }
    end
}

#print axioms inv_is_morphism

--- The hom-set between binary_modules forms a binary_module.
@[reducible,inline]
definition hom (α β : Type _) [model binary_module α] [model binary_module β] := submodel binary_module (inv_is_morphism α β)

namespace hom

--- Composition of homomorphisms.
@[reducible,inline]
protected
definition comp {α β γ: Type _} [model binary_module α] [model binary_module β] [model binary_module γ] : hom β γ → hom α β → hom α γ := morphism.comp

--- Evaluation at `a : α` defines a homomorphism from `hom α β` to `β`.
@[reducible]
protected
definition eval (α β : Type _) [model binary_module α] [model binary_module β] (a : α) : morphism binary_module (hom α β) β :=
{
  val := λ f, f.val a,
  property :=
    begin
      intros _ μ fs,
      dsimp *,
      let hj := (@submodel.sub_incl binary_module (α → β) _ (inv_is_morphism α β)).property,
      unfold is_morphism at hj,
      dsimp [submodel.sub_incl] at hj,
      rw [hj],
      unfold premodel.act,
      rw [vect.unzip_fam_eval,←vect.map_comp]
    end
}

#print axioms hom.eval

--- For every pair of `binary_module`s `α` and `β`, the type of homomorphisms `hom α β` is point-wisely a model of `binary_module`; i.e. up to `funext`.
definition is_model_ptwise (α β : Type _) [model binary_module α] [model binary_module β] : ∀ {n : ℕ} (r : binary_module.rel n) (var : finord n → hom α β) (a : α), ((binary_module.rel_lhs r).elim (@premodel.act binary_module (hom α β) _) var).val a = ((binary_module.rel_rhs r).elim (@premodel.act binary_module (hom α β) _) var).val a :=
  begin
    intros n r var a,
    let hp := @optree.elim_funap binary_module.ops (finord n) (hom α β) β (@premodel.act binary_module (hom α β) _) (@premodel.act binary_module β _) var (hom.eval α β a).val (hom.eval α β a).property,
    delta hom.eval at hp,
    dsimp [subtype.val,function.comp] at hp,
    rw [hp,hp],
    rw [model.axiom_eq],
  end

#print axioms hom.is_model_ptwise

namespace unsafe

--- For every pair of `binary_module`s `α` and `β`, the type of homomorphisms `hom α β` is a model of `binary_module`.
definition is_model (α β : Type _) [model binary_module α] [model binary_module β] : model binary_module (hom α β) :=
{
  haxiom := λ _ r var, subtype.eq (funext (@is_model_ptwise α β _ _ _ r var))
}

#print axioms hom.unsafe.is_model

end unsafe

section

local infixl `●`:100 := hom.comp
local attribute [instance] binary_module.has_binary_add

--- Composition is linear in the right operand.
theorem comp_bilinear_right_ptwise (α β γ: Type _) [model binary_module α] [model binary_module β] [model binary_module γ] (g : hom β γ) (f₁ f₂ : hom α β) : ∀ (a : α), (g ● (f₁+ f₂)).val a = ((g ● f₁) + (g ● f₂)).val a :=
  begin
    intros a,
    dsimp [has_add.add,binary_module.add,hom.comp,morphism.comp],
    dsimp [premodel.act,vect.map,subtype.val],
    csimp only [vect.unzip_fam_eval,vect.map],
    rw [g.property],
    dsimp [vect.map,function.comp],
    refl
  end

#print axioms comp_bilinear_right_ptwise

--- Composition is linear in the left operand.
theorem comp_bilinear_left_ptwise (α β γ: Type _) [model binary_module α] [model binary_module β] [model binary_module γ] (g₁ g₂ : hom β γ) (f : hom α β) : ∀ (a : α), ((g₁+g₂) ● f).val a = ((g₁ ● f) + (g₂ ● f)).val a :=
  begin
    intros a,
    dsimp [has_add.add,binary_module.add,hom.comp,morphism.comp],
    dsimp [premodel.act,vect.map,subtype.val],
    csimp only [vect.unzip_fam_eval,vect.map],
  end

#print axioms comp_bilinear_left_ptwise

end

end hom

end binary_module


import tactic
import order.filter.partial
import algebra.support
import convergence_space.basic

noncomputable theory
open set filter classical convergence_space
open_locale classical filter

variables {α β : Type*}

/-!
### Definition
-/

@[ext] class kent_convergence_space (α : Type*) extends convergence_space α :=
(kent_converges : ∀ {f x}, converges f x → converges (f ⊔ pure x) x)

open kent_convergence_space

namespace kent_convergence_space

instance : has_coe (kent_convergence_space α) (convergence_space α) :=
{ coe := λ p, p.to_convergence_space }

@[simp, norm_cast] theorem coe_inj {p q : kent_convergence_space α} :
  (↑p : convergence_space α)= ↑q ↔ p = q :=
by { rw kent_convergence_space.ext_iff, tauto }

lemma coe_injective : function.injective (coe : kent_convergence_space α → convergence_space α) :=
λ s t, coe_inj.1

end kent_convergence_space

@[simp] def kent_converges_ {α : Type*} (p : kent_convergence_space α)
  {f : filter α} {x : α} (h : converges_ ↑p f x) : converges_ ↑p (f ⊔ pure x) x
:= @kent_converges _ p _ _ h

/-!
### Ordering
-/

/-- The ordering is the one inherited from convergence spaces. -/

instance : has_le (kent_convergence_space α) := ⟨λ p q, ↑p ≤ (↑q : convergence_space α)⟩

instance : partial_order (kent_convergence_space α) :=
  partial_order.lift coe kent_convergence_space.coe_injective

/-!
### Lattice of Kent convergence structures
-/

/-- Just like convergence structures, Kent convergence structures also
  form a complete lattice. The infimum/supremum are formed in the same
  manner as convergence spaces. -/

instance : has_bot (kent_convergence_space α) :=
{ bot :=
  { kent_converges :=
    begin
      intros f x hconv,
      unfold converges at *,
      have : f ⊔ pure x ≤ pure x, from calc
        f ⊔ pure x ≤ pure x ⊔ pure x : sup_le_sup_right hconv (pure x)
        ... = pure x : sup_idem,
      assumption
    end,
    ..convergence_space.has_bot.bot }}

instance : has_top (kent_convergence_space α) :=
{ top := { kent_converges := by tauto, ..convergence_space.has_top.top }}

instance : has_inf (kent_convergence_space α) :=
{ inf := λ p q, let super : convergence_space α := ↑p ⊓ ↑q in
  { converges := converges_ super,
    pure_converges := pure_converges_ super,
    le_converges := le_converges_ super,
    kent_converges := λ f x hconv,
    ⟨kent_converges_ p hconv.1, kent_converges_ q hconv.2⟩ }}

instance : has_sup (kent_convergence_space α) :=
{ sup := λ p q, let super : convergence_space α := ↑p ⊔ ↑q in
  { converges := converges_ super,
    pure_converges := pure_converges_ super,
    le_converges := le_converges_ super,
    kent_converges :=
    begin
      intros f x hconv,
      cases hconv,
      { exact or.inl (kent_converges_ p hconv) },
      { exact or.inr (kent_converges_ q hconv) }
    end }}

instance : has_Inf (kent_convergence_space α) :=
{ Inf := λ ps, let super : convergence_space α := Inf (coe '' ps) in
  { converges := converges_ super,
    pure_converges := pure_converges_ super,
    le_converges := le_converges_ super,
    kent_converges :=
    begin
      intros f x hconv p hp,
      obtain ⟨q, hq, heq⟩ := mem_image_iff_bex.mp hp,
      rw ← heq at *,
      exact kent_converges_ q (hconv hp)
    end }}

instance : has_Sup (kent_convergence_space α) :=
{ Sup := λ ps, let super : convergence_space α := Sup (coe '' ps) in
  { converges := converges_ super,
    pure_converges := pure_converges_ super,
    le_converges := le_converges_ super,
    kent_converges :=
    begin
      intros f x hconv,
      cases hconv,
      { rw sup_of_le_right hconv,
        exact pure_converges_ super x },
      { obtain ⟨p, hp, hconv'⟩ := hconv,
        refine or.inr ⟨p, hp, _⟩,
        obtain ⟨q, hq, heq⟩ := mem_image_iff_bex.mp hp,
        rw ← heq at *,
        exact kent_converges_ q hconv' }
    end }}

instance : semilattice_inf (kent_convergence_space α) :=
by { refine function.injective.semilattice_inf coe kent_convergence_space.coe_injective _, tauto }

instance : semilattice_sup (kent_convergence_space α) :=
by { refine function.injective.semilattice_sup coe kent_convergence_space.coe_injective _, tauto }

lemma kent_convergence_space.coe_Inf (ps : set (kent_convergence_space α)) :
  (↑(Inf ps) : convergence_space α) = Inf (coe '' ps) :=
by { ext, tauto }

lemma kent_convergence_space.coe_Sup (ps : set (kent_convergence_space α)) :
  (↑(Sup ps) : convergence_space α) = Sup (coe '' ps) :=
by { ext, tauto }

instance : complete_semilattice_Inf (kent_convergence_space α) :=
{ Inf_le :=
  begin
    intros ps p hmem f x hconv,
    rw kent_convergence_space.coe_Inf at hconv,
    exact hconv (mem_image_of_mem coe hmem),
  end,
  le_Inf :=
  begin
    intros ps q hle,
    change ↑q ≤ ↑(Inf ps),
    rw kent_convergence_space.coe_Inf,
    intros f x hconv p hp,
    obtain ⟨r, hr, heq⟩ := mem_image_iff_bex.mp hp,
    rw ← heq,
    exact hle r hr hconv,
  end,
  ..kent_convergence_space.partial_order,
  ..kent_convergence_space.has_Inf }

instance : complete_semilattice_Sup (kent_convergence_space α) :=
{ le_Sup :=
  begin
    intros ps p hmem f x hconv,
    rw kent_convergence_space.coe_Sup,
    unfold Sup, simp,
    exact or.inr ⟨p, hmem, hconv⟩,
  end,
  Sup_le :=
  begin
    intros qs p hle f x hconv,
    cases hconv,
    { exact le_converges_ ↑p hconv (pure_converges_ ↑p x) },
    { obtain ⟨q, hq, hconv'⟩ := hconv,
      obtain ⟨r, hr, heq⟩ := mem_image_iff_bex.mp hq,
      rw ← heq at hconv',
      exact (hle r hr) hconv',
      }
  end,
  ..kent_convergence_space.partial_order,
  ..kent_convergence_space.has_Sup }

instance : lattice (kent_convergence_space α) :=
{ ..kent_convergence_space.semilattice_sup,
  ..kent_convergence_space.semilattice_inf }

instance : complete_lattice (kent_convergence_space α) :=
{ bot_le := λ p f x hconv, le_converges_ p hconv (pure_converges_ p x),
  le_top := by intros; tauto,
  ..kent_convergence_space.has_bot,
  ..kent_convergence_space.has_top,
  ..kent_convergence_space.lattice,
  ..kent_convergence_space.complete_semilattice_Inf,
  ..kent_convergence_space.complete_semilattice_Sup }

/-!
### Induced Kent convergence space
-/

def kent_convergence_space.induced (m : α → β) [kent_convergence_space β] : kent_convergence_space α :=
let ind := convergence_space.induced m in
{ kent_converges :=
  begin
    assume f : filter α,
    assume x : α,
    assume h : converges (map m f) (m x),
    let f₁ := map m f,
    let f₂ := f ⊔ pure x,
    let y := m x,
    show converges (map m f₂) y,
    begin
      rw [filter.map_sup, filter.map_pure],
      simp [kent_converges h],
    end,
  end,
  ..ind }

/-!
### Coinduced Kent convergence space
-/

def kent_convergence_space.coinduced (m : α → β) [kent_convergence_space α] : kent_convergence_space β :=
let coind := convergence_space.coinduced m in
{ kent_converges :=
  begin
    assume g : filter β,
    assume y  : β,
    assume hconv : converges_ coind g y,
    cases hconv,
      case or.inl
      begin
        have : g ⊔ pure y = pure y, from calc
          g ⊔ pure y  = pure y ⊔ g : sup_comm
          ... = pure y : by rw sup_of_le_left hconv,
        have : converges_ coind (pure y) y, from pure_converges_ coind y,
        show converges_ coind (g ⊔ pure y) y,
        begin
          rw (by assumption : g ⊔ pure y = pure y),
          assumption,
        end,
      end,
      case or.inr : hex
      begin
        obtain ⟨f, x, hle, heq, hconv⟩ := hex,
        let f' := f ⊔ pure x,
        have hle' : g ⊔ pure y ≤ map m f', from calc
          g ⊔ pure y ≤ map m f ⊔ pure y : sup_le_sup_right hle (pure y)
          ... = map m f ⊔ pure (m x) : by rw heq
          ... = map m f ⊔ map m (pure x) : by rw filter.map_pure
          ... = map m (f ⊔ pure x) : map_sup,
        have hconv' : converges f' x,
        begin
          apply kent_converges,
          assumption
        end,
        exact or.inr ⟨f', x, hle', heq, hconv'⟩,
      end,
  end,
  ..coind }

/-!
### Constructions
-/

def kent_modification (p : convergence_space α) : kent_convergence_space α :=
  Inf { q : kent_convergence_space α | p ≤ q }

instance {p : α → Prop} [kent_convergence_space α] : kent_convergence_space (subtype p) :=
kent_convergence_space.induced (coe : subtype p → α)

instance {r : α → α → Prop} [kent_convergence_space α] : kent_convergence_space (quot r) :=
kent_convergence_space.coinduced (quot.mk r)

instance [kent_convergence_space α] [kent_convergence_space β] : kent_convergence_space (α × β) :=
kent_convergence_space.induced prod.fst ⊓ kent_convergence_space.induced prod.snd