/-
Copyright (c) 2020 Bhavik Mehta. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Bhavik Mehta
-/
import category_theory.limits.preserves.basic

/-!
# Creating (co)limits

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

We say that `F` creates limits of `K` if, given any limit cone `c` for `K ⋙ F`
(i.e. below) we can lift it to a cone "above", and further that `F` reflects
limits for `K`.
-/

open category_theory category_theory.limits

noncomputable theory

namespace category_theory

universes w' w v₁ v₂ v₃ u₁ u₂ u₃

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

section creates
variables {D : Type u₂} [category.{v₂} D]

variables {J : Type w} [category.{w'} J] {K : J ⥤ C}

/--
Define the lift of a cone: For a cone `c` for `K ⋙ F`, give a cone for `K`
which is a lift of `c`, i.e. the image of it under `F` is (iso) to `c`.

We will then use this as part of the definition of creation of limits:
every limit cone has a lift.

Note this definition is really only useful when `c` is a limit already.
-/
structure liftable_cone (K : J ⥤ C) (F : C ⥤ D) (c : cone (K ⋙ F)) :=
(lifted_cone : cone K)
(valid_lift : F.map_cone lifted_cone ≅ c)

/--
Define the lift of a cocone: For a cocone `c` for `K ⋙ F`, give a cocone for
`K` which is a lift of `c`, i.e. the image of it under `F` is (iso) to `c`.

We will then use this as part of the definition of creation of colimits:
every limit cocone has a lift.

Note this definition is really only useful when `c` is a colimit already.
-/
structure liftable_cocone (K : J ⥤ C) (F : C ⥤ D) (c : cocone (K ⋙ F)) :=
(lifted_cocone : cocone K)
(valid_lift : F.map_cocone lifted_cocone ≅ c)

/--
Definition 3.3.1 of [Riehl].
We say that `F` creates limits of `K` if, given any limit cone `c` for `K ⋙ F`
(i.e. below) we can lift it to a cone "above", and further that `F` reflects
limits for `K`.

If `F` reflects isomorphisms, it suffices to show only that the lifted cone is
a limit - see `creates_limit_of_reflects_iso`.
-/
class creates_limit (K : J ⥤ C) (F : C ⥤ D) extends reflects_limit K F :=
(lifts : Π c, is_limit c → liftable_cone K F c)

/--
`F` creates limits of shape `J` if `F` creates the limit of any diagram
`K : J ⥤ C`.
-/
class creates_limits_of_shape (J : Type w) [category.{w'} J] (F : C ⥤ D) :=
(creates_limit : Π {K : J ⥤ C}, creates_limit K F . tactic.apply_instance)

/-- `F` creates limits if it creates limits of shape `J` for any `J`. -/
@[nolint check_univs] -- This should be used with explicit universe variables.
class creates_limits_of_size (F : C ⥤ D) :=
(creates_limits_of_shape : Π {J : Type w} [category.{w'} J],
  creates_limits_of_shape J F . tactic.apply_instance)

/-- `F` creates small limits if it creates limits of shape `J` for any small `J`. -/
abbreviation creates_limits (F : C ⥤ D) := creates_limits_of_size.{v₂ v₂} F

/--
Dual of definition 3.3.1 of [Riehl].
We say that `F` creates colimits of `K` if, given any limit cocone `c` for
`K ⋙ F` (i.e. below) we can lift it to a cocone "above", and further that `F`
reflects limits for `K`.

If `F` reflects isomorphisms, it suffices to show only that the lifted cocone is
a limit - see `creates_limit_of_reflects_iso`.
-/
class creates_colimit (K : J ⥤ C) (F : C ⥤ D) extends reflects_colimit K F :=
(lifts : Π c, is_colimit c → liftable_cocone K F c)

/--
`F` creates colimits of shape `J` if `F` creates the colimit of any diagram
`K : J ⥤ C`.
-/
class creates_colimits_of_shape (J : Type w) [category.{w'} J] (F : C ⥤ D) :=
(creates_colimit : Π {K : J ⥤ C}, creates_colimit K F . tactic.apply_instance)

/-- `F` creates colimits if it creates colimits of shape `J` for any small `J`. -/
@[nolint check_univs] -- This should be used with explicit universe variables.
class creates_colimits_of_size (F : C ⥤ D) :=
(creates_colimits_of_shape : Π {J : Type w} [category.{w'} J],
  creates_colimits_of_shape J F . tactic.apply_instance)

/-- `F` creates small colimits if it creates colimits of shape `J` for any small `J`. -/
abbreviation creates_colimits (F : C ⥤ D) := creates_colimits_of_size.{v₂ v₂} F

attribute [instance, priority 100] -- see Note [lower instance priority]
  creates_limits_of_shape.creates_limit creates_limits_of_size.creates_limits_of_shape
  creates_colimits_of_shape.creates_colimit creates_colimits_of_size.creates_colimits_of_shape

/- Interface to the `creates_limit` class. -/

/-- `lift_limit t` is the cone for `K` given by lifting the limit `t` for `K ⋙ F`. -/
def lift_limit {K : J ⥤ C} {F : C ⥤ D} [creates_limit K F] {c : cone (K ⋙ F)} (t : is_limit c) :
  cone K :=
(creates_limit.lifts c t).lifted_cone

/-- The lifted cone has an image isomorphic to the original cone. -/
def lifted_limit_maps_to_original {K : J ⥤ C} {F : C ⥤ D}
  [creates_limit K F] {c : cone (K ⋙ F)} (t : is_limit c) :
  F.map_cone (lift_limit t) ≅ c :=
(creates_limit.lifts c t).valid_lift

/-- The lifted cone is a limit. -/
def lifted_limit_is_limit {K : J ⥤ C} {F : C ⥤ D}
  [creates_limit K F] {c : cone (K ⋙ F)} (t : is_limit c) :
  is_limit (lift_limit t) :=
reflects_limit.reflects (is_limit.of_iso_limit t (lifted_limit_maps_to_original t).symm)

/-- If `F` creates the limit of `K` and `K ⋙ F` has a limit, then `K` has a limit. -/
lemma has_limit_of_created (K : J ⥤ C) (F : C ⥤ D)
  [has_limit (K ⋙ F)] [creates_limit K F] : has_limit K :=
has_limit.mk { cone := lift_limit (limit.is_limit (K ⋙ F)),
  is_limit := lifted_limit_is_limit _ }

/--
If `F` creates limits of shape `J`, and `D` has limits of shape `J`, then
`C` has limits of shape `J`.
-/
lemma has_limits_of_shape_of_has_limits_of_shape_creates_limits_of_shape (F : C ⥤ D)
  [has_limits_of_shape J D] [creates_limits_of_shape J F] : has_limits_of_shape J C :=
⟨λ G, has_limit_of_created G F⟩

/-- If `F` creates limits, and `D` has all limits, then `C` has all limits. -/
lemma has_limits_of_has_limits_creates_limits (F : C ⥤ D) [has_limits_of_size.{w w'} D]
  [creates_limits_of_size.{w w'} F] : has_limits_of_size.{w w'} C :=
⟨λ J I, by exactI has_limits_of_shape_of_has_limits_of_shape_creates_limits_of_shape F⟩

/- Interface to the `creates_colimit` class. -/

/-- `lift_colimit t` is the cocone for `K` given by lifting the colimit `t` for `K ⋙ F`. -/
def lift_colimit {K : J ⥤ C} {F : C ⥤ D} [creates_colimit K F] {c : cocone (K ⋙ F)}
  (t : is_colimit c) :
  cocone K :=
(creates_colimit.lifts c t).lifted_cocone

/-- The lifted cocone has an image isomorphic to the original cocone. -/
def lifted_colimit_maps_to_original {K : J ⥤ C} {F : C ⥤ D}
  [creates_colimit K F] {c : cocone (K ⋙ F)} (t : is_colimit c) :
  F.map_cocone (lift_colimit t) ≅ c :=
(creates_colimit.lifts c t).valid_lift

/-- The lifted cocone is a colimit. -/
def lifted_colimit_is_colimit {K : J ⥤ C} {F : C ⥤ D}
  [creates_colimit K F] {c : cocone (K ⋙ F)} (t : is_colimit c) :
  is_colimit (lift_colimit t) :=
reflects_colimit.reflects (is_colimit.of_iso_colimit t (lifted_colimit_maps_to_original t).symm)

/-- If `F` creates the limit of `K` and `K ⋙ F` has a limit, then `K` has a limit. -/
lemma has_colimit_of_created (K : J ⥤ C) (F : C ⥤ D)
  [has_colimit (K ⋙ F)] [creates_colimit K F] : has_colimit K :=
has_colimit.mk { cocone := lift_colimit (colimit.is_colimit (K ⋙ F)),
  is_colimit := lifted_colimit_is_colimit _ }

/--
If `F` creates colimits of shape `J`, and `D` has colimits of shape `J`, then
`C` has colimits of shape `J`.
-/
lemma has_colimits_of_shape_of_has_colimits_of_shape_creates_colimits_of_shape (F : C ⥤ D)
  [has_colimits_of_shape J D] [creates_colimits_of_shape J F] : has_colimits_of_shape J C :=
⟨λ G, has_colimit_of_created G F⟩

/-- If `F` creates colimits, and `D` has all colimits, then `C` has all colimits. -/
lemma has_colimits_of_has_colimits_creates_colimits (F : C ⥤ D) [has_colimits_of_size.{w w'} D]
  [creates_colimits_of_size.{w w'} F] : has_colimits_of_size.{w w'} C :=
⟨λ J I, by exactI has_colimits_of_shape_of_has_colimits_of_shape_creates_colimits_of_shape F⟩

@[priority 10] instance reflects_limits_of_shape_of_creates_limits_of_shape (F : C ⥤ D)
  [creates_limits_of_shape J F] : reflects_limits_of_shape J F := {}
@[priority 10] instance reflects_limits_of_creates_limits (F : C ⥤ D)
  [creates_limits_of_size.{w w'} F] : reflects_limits_of_size.{w w'} F := {}
@[priority 10] instance reflects_colimits_of_shape_of_creates_colimits_of_shape (F : C ⥤ D)
  [creates_colimits_of_shape J F] : reflects_colimits_of_shape J F := {}
@[priority 10] instance reflects_colimits_of_creates_colimits (F : C ⥤ D)
  [creates_colimits_of_size.{w w'} F] : reflects_colimits_of_size.{w w'} F := {}

/--
A helper to show a functor creates limits. In particular, if we can show
that for any limit cone `c` for `K ⋙ F`, there is a lift of it which is
a limit and `F` reflects isomorphisms, then `F` creates limits.
Usually, `F` creating limits says that _any_ lift of `c` is a limit, but
here we only need to show that our particular lift of `c` is a limit.
-/
structure lifts_to_limit (K : J ⥤ C) (F : C ⥤ D) (c : cone (K ⋙ F)) (t : is_limit c)
  extends liftable_cone K F c :=
(makes_limit : is_limit lifted_cone)

/--
A helper to show a functor creates colimits. In particular, if we can show
that for any limit cocone `c` for `K ⋙ F`, there is a lift of it which is
a limit and `F` reflects isomorphisms, then `F` creates colimits.
Usually, `F` creating colimits says that _any_ lift of `c` is a colimit, but
here we only need to show that our particular lift of `c` is a colimit.
-/
structure lifts_to_colimit (K : J ⥤ C) (F : C ⥤ D) (c : cocone (K ⋙ F)) (t : is_colimit c)
  extends liftable_cocone K F c :=
(makes_colimit : is_colimit lifted_cocone)

/--
If `F` reflects isomorphisms and we can lift any limit cone to a limit cone,
then `F` creates limits.
In particular here we don't need to assume that F reflects limits.
-/
def creates_limit_of_reflects_iso {K : J ⥤ C} {F : C ⥤ D} [reflects_isomorphisms F]
  (h : Π c t, lifts_to_limit K F c t) :
  creates_limit K F :=
{ lifts := λ c t, (h c t).to_liftable_cone,
  to_reflects_limit :=
  { reflects := λ (d : cone K) (hd : is_limit (F.map_cone d)),
    begin
      let d' : cone K := (h (F.map_cone d) hd).to_liftable_cone.lifted_cone,
      let i : F.map_cone d' ≅ F.map_cone d := (h (F.map_cone d) hd).to_liftable_cone.valid_lift,
      let hd' : is_limit d' := (h (F.map_cone d) hd).makes_limit,
      let f : d ⟶ d' := hd'.lift_cone_morphism d,
      have : (cones.functoriality K F).map f = i.inv := (hd.of_iso_limit i.symm).uniq_cone_morphism,
      haveI : is_iso ((cones.functoriality K F).map f) := (by { rw this, apply_instance }),
      haveI : is_iso f := is_iso_of_reflects_iso f (cones.functoriality K F),
      exact is_limit.of_iso_limit hd' (as_iso f).symm,
    end } }

/--
When `F` is fully faithful, to show that `F` creates the limit for `K` it suffices to exhibit a lift
of a limit cone for `K ⋙ F`.
-/
-- Notice however that even if the isomorphism is `iso.refl _`,
-- this construction will insert additional identity morphisms in the cone maps,
-- so the constructed limits may not be ideal, definitionally.
def creates_limit_of_fully_faithful_of_lift' {K : J ⥤ C} {F : C ⥤ D} [full F] [faithful F]
  {l : cone (K ⋙ F)} (hl : is_limit l) (c : cone K) (i : F.map_cone c ≅ l) : creates_limit K F :=
creates_limit_of_reflects_iso (λ c' t,
{ lifted_cone := c,
  valid_lift := i ≪≫ is_limit.unique_up_to_iso hl t,
  makes_limit := is_limit.of_faithful F (is_limit.of_iso_limit hl i.symm) _
    (λ s, F.image_preimage _) })

/--
When `F` is fully faithful, and `has_limit (K ⋙ F)`, to show that `F` creates the limit for `K`
it suffices to exhibit a lift of the chosen limit cone for `K ⋙ F`.
-/
-- Notice however that even if the isomorphism is `iso.refl _`,
-- this construction will insert additional identity morphisms in the cone maps,
-- so the constructed limits may not be ideal, definitionally.
def creates_limit_of_fully_faithful_of_lift {K : J ⥤ C} {F : C ⥤ D}
  [full F] [faithful F] [has_limit (K ⋙ F)]
  (c : cone K) (i : F.map_cone c ≅ limit.cone (K ⋙ F)) : creates_limit K F :=
creates_limit_of_fully_faithful_of_lift' (limit.is_limit _) c i

/--
When `F` is fully faithful, to show that `F` creates the limit for `K` it suffices to show that a
limit point is in the essential image of `F`.
-/
-- Notice however that even if the isomorphism is `iso.refl _`,
-- this construction will insert additional identity morphisms in the cone maps,
-- so the constructed limits may not be ideal, definitionally.
def creates_limit_of_fully_faithful_of_iso' {K : J ⥤ C} {F : C ⥤ D} [full F] [faithful F]
  {l : cone (K ⋙ F)} (hl : is_limit l) (X : C) (i : F.obj X ≅ l.X) : creates_limit K F :=
creates_limit_of_fully_faithful_of_lift' hl
({ X := X,
  π :=
  { app := λ j, F.preimage (i.hom ≫ l.π.app j),
    naturality' := λ Y Z f, F.map_injective $ by { dsimp, simpa using (l.w f).symm } } })
(cones.ext i (λ j, by simp only [functor.image_preimage, functor.map_cone_π_app]))

/--
When `F` is fully faithful, and `has_limit (K ⋙ F)`, to show that `F` creates the limit for `K`
it suffices to show that the chosen limit point is in the essential image of `F`.
-/
-- Notice however that even if the isomorphism is `iso.refl _`,
-- this construction will insert additional identity morphisms in the cone maps,
-- so the constructed limits may not be ideal, definitionally.
def creates_limit_of_fully_faithful_of_iso {K : J ⥤ C} {F : C ⥤ D}
  [full F] [faithful F] [has_limit (K ⋙ F)]
  (X : C) (i : F.obj X ≅ limit (K ⋙ F)) : creates_limit K F :=
creates_limit_of_fully_faithful_of_iso' (limit.is_limit _) X i

/-- `F` preserves the limit of `K` if it creates the limit and `K ⋙ F` has the limit. -/
@[priority 100] -- see Note [lower instance priority]
instance preserves_limit_of_creates_limit_and_has_limit (K : J ⥤ C) (F : C ⥤ D)
  [creates_limit K F] [has_limit (K ⋙ F)] :
  preserves_limit K F :=
{ preserves := λ c t, is_limit.of_iso_limit (limit.is_limit _)
    ((lifted_limit_maps_to_original (limit.is_limit _)).symm ≪≫
      ((cones.functoriality K F).map_iso
        ((lifted_limit_is_limit (limit.is_limit _)).unique_up_to_iso t))) }

/-- `F` preserves the limit of shape `J` if it creates these limits and `D` has them. -/
@[priority 100] -- see Note [lower instance priority]
instance preserves_limit_of_shape_of_creates_limits_of_shape_and_has_limits_of_shape (F : C ⥤ D)
  [creates_limits_of_shape J F] [has_limits_of_shape J D] :
  preserves_limits_of_shape J F := {}

/-- `F` preserves limits if it creates limits and `D` has limits. -/
@[priority 100] -- see Note [lower instance priority]
instance preserves_limits_of_creates_limits_and_has_limits (F : C ⥤ D)
  [creates_limits_of_size.{w w'} F]
  [has_limits_of_size.{w w'} D] :
  preserves_limits_of_size.{w w'} F := {}

/--
If `F` reflects isomorphisms and we can lift any colimit cocone to a colimit cocone,
then `F` creates colimits.
In particular here we don't need to assume that F reflects colimits.
-/
def creates_colimit_of_reflects_iso {K : J ⥤ C} {F : C ⥤ D} [reflects_isomorphisms F]
  (h : Π c t, lifts_to_colimit K F c t) :
  creates_colimit K F :=
{ lifts := λ c t, (h c t).to_liftable_cocone,
  to_reflects_colimit :=
  { reflects := λ (d : cocone K) (hd : is_colimit (F.map_cocone d)),
    begin
      let d' : cocone K := (h (F.map_cocone d) hd).to_liftable_cocone.lifted_cocone,
      let i : F.map_cocone d' ≅ F.map_cocone d :=
        (h (F.map_cocone d) hd).to_liftable_cocone.valid_lift,
      let hd' : is_colimit d' := (h (F.map_cocone d) hd).makes_colimit,
      let f : d' ⟶ d := hd'.desc_cocone_morphism d,
      have : (cocones.functoriality K F).map f = i.hom :=
        (hd.of_iso_colimit i.symm).uniq_cocone_morphism,
      haveI : is_iso ((cocones.functoriality K F).map f) := (by { rw this, apply_instance }),
      haveI := is_iso_of_reflects_iso f (cocones.functoriality K F),
      exact is_colimit.of_iso_colimit hd' (as_iso f),
    end } }

/--
When `F` is fully faithful, to show that `F` creates the colimit for `K` it suffices to exhibit a
lift of a colimit cocone for `K ⋙ F`.
-/
-- Notice however that even if the isomorphism is `iso.refl _`,
-- this construction will insert additional identity morphisms in the cocone maps,
-- so the constructed colimits may not be ideal, definitionally.
def creates_colimit_of_fully_faithful_of_lift' {K : J ⥤ C} {F : C ⥤ D} [full F] [faithful F]
  {l : cocone (K ⋙ F)} (hl : is_colimit l) (c : cocone K) (i : F.map_cocone c ≅ l) :
  creates_colimit K F :=
creates_colimit_of_reflects_iso (λ c' t,
{ lifted_cocone := c,
  valid_lift := i ≪≫ is_colimit.unique_up_to_iso hl t,
  makes_colimit := is_colimit.of_faithful F (is_colimit.of_iso_colimit hl i.symm) _
    (λ s, F.image_preimage _) })

/--
When `F` is fully faithful, and `has_colimit (K ⋙ F)`, to show that `F` creates the colimit for `K`
it suffices to exhibit a lift of the chosen colimit cocone for `K ⋙ F`.
-/
-- Notice however that even if the isomorphism is `iso.refl _`,
-- this construction will insert additional identity morphisms in the cocone maps,
-- so the constructed colimits may not be ideal, definitionally.
def creates_colimit_of_fully_faithful_of_lift {K : J ⥤ C} {F : C ⥤ D}
  [full F] [faithful F] [has_colimit (K ⋙ F)]
  (c : cocone K) (i : F.map_cocone c ≅ colimit.cocone (K ⋙ F)) : creates_colimit K F :=
creates_colimit_of_fully_faithful_of_lift' (colimit.is_colimit _) c i

/--
When `F` is fully faithful, to show that `F` creates the colimit for `K` it suffices to show that
a colimit point is in the essential image of `F`.
-/
-- Notice however that even if the isomorphism is `iso.refl _`,
-- this construction will insert additional identity morphisms in the cocone maps,
-- so the constructed colimits may not be ideal, definitionally.
def creates_colimit_of_fully_faithful_of_iso' {K : J ⥤ C} {F : C ⥤ D} [full F] [faithful F]
  {l : cocone (K ⋙ F)} (hl : is_colimit l) (X : C) (i : F.obj X ≅ l.X) : creates_colimit K F :=
creates_colimit_of_fully_faithful_of_lift' hl
({ X := X,
  ι :=
  { app := λ j, F.preimage (l.ι.app j ≫ i.inv),
  naturality' := λ Y Z f, F.map_injective $
    by { dsimp, simpa [← cancel_mono i.hom] using (l.w f) } } })
(cocones.ext i (λ j, by simp))

/--
When `F` is fully faithful, and `has_colimit (K ⋙ F)`, to show that `F` creates the colimit for `K`
it suffices to show that the chosen colimit point is in the essential image of `F`.
-/
-- Notice however that even if the isomorphism is `iso.refl _`,
-- this construction will insert additional identity morphisms in the cocone maps,
-- so the constructed colimits may not be ideal, definitionally.
def creates_colimit_of_fully_faithful_of_iso {K : J ⥤ C} {F : C ⥤ D}
  [full F] [faithful F] [has_colimit (K ⋙ F)]
  (X : C) (i : F.obj X ≅ colimit (K ⋙ F)) : creates_colimit K F :=
creates_colimit_of_fully_faithful_of_iso' (colimit.is_colimit _) X i

/-- `F` preserves the colimit of `K` if it creates the colimit and `K ⋙ F` has the colimit. -/
@[priority 100] -- see Note [lower instance priority]
instance preserves_colimit_of_creates_colimit_and_has_colimit (K : J ⥤ C) (F : C ⥤ D)
  [creates_colimit K F] [has_colimit (K ⋙ F)] :
  preserves_colimit K F :=
{ preserves := λ c t, is_colimit.of_iso_colimit (colimit.is_colimit _)
    ((lifted_colimit_maps_to_original (colimit.is_colimit _)).symm ≪≫
      ((cocones.functoriality K F).map_iso
        ((lifted_colimit_is_colimit (colimit.is_colimit _)).unique_up_to_iso t))) }

/-- `F` preserves the colimit of shape `J` if it creates these colimits and `D` has them. -/
@[priority 100] -- see Note [lower instance priority]
instance preserves_colimit_of_shape_of_creates_colimits_of_shape_and_has_colimits_of_shape
  (F : C ⥤ D) [creates_colimits_of_shape J F] [has_colimits_of_shape J D] :
  preserves_colimits_of_shape J F := {}

/-- `F` preserves limits if it creates limits and `D` has limits. -/
@[priority 100] -- see Note [lower instance priority]
instance preserves_colimits_of_creates_colimits_and_has_colimits (F : C ⥤ D)
  [creates_colimits_of_size.{w w'} F] [has_colimits_of_size.{w w'} D] :
  preserves_colimits_of_size.{w w'} F := {}

/-- Transfer creation of limits along a natural isomorphism in the diagram. -/
def creates_limit_of_iso_diagram {K₁ K₂ : J ⥤ C} (F : C ⥤ D) (h : K₁ ≅ K₂)
  [creates_limit K₁ F] : creates_limit K₂ F :=
{ lifts := λ c t,
  let t' := (is_limit.postcompose_inv_equiv (iso_whisker_right h F : _) c).symm t in
  { lifted_cone := (cones.postcompose h.hom).obj (lift_limit t'),
    valid_lift :=
        F.map_cone_postcompose ≪≫
        (cones.postcompose (iso_whisker_right h F).hom).map_iso
            (lifted_limit_maps_to_original t') ≪≫
        cones.ext (iso.refl _) (λ j, by { dsimp, rw [category.assoc, ←F.map_comp], simp }) }
  ..reflects_limit_of_iso_diagram F h }

/-- If `F` creates the limit of `K` and `F ≅ G`, then `G` creates the limit of `K`. -/
def creates_limit_of_nat_iso {F G : C ⥤ D} (h : F ≅ G) [creates_limit K F] :
  creates_limit K G :=
{ lifts := λ c t,
  { lifted_cone :=
      lift_limit ((is_limit.postcompose_inv_equiv (iso_whisker_left K h : _) c).symm t),
    valid_lift :=
    begin
      refine (is_limit.map_cone_equiv h _).unique_up_to_iso t,
      apply is_limit.of_iso_limit _ ((lifted_limit_maps_to_original _).symm),
      apply (is_limit.postcompose_inv_equiv _ _).symm t,
    end },
  to_reflects_limit := reflects_limit_of_nat_iso _ h }

/-- If `F` creates limits of shape `J` and `F ≅ G`, then `G` creates limits of shape `J`. -/
def creates_limits_of_shape_of_nat_iso {F G : C ⥤ D} (h : F ≅ G) [creates_limits_of_shape J F] :
  creates_limits_of_shape J G :=
{ creates_limit := λ K, creates_limit_of_nat_iso h }

/-- If `F` creates limits and `F ≅ G`, then `G` creates limits. -/
def creates_limits_of_nat_iso {F G : C ⥤ D} (h : F ≅ G) [creates_limits_of_size.{w w'} F] :
  creates_limits_of_size.{w w'} G :=
{ creates_limits_of_shape := λ J 𝒥₁, by exactI creates_limits_of_shape_of_nat_iso h }

/-- Transfer creation of colimits along a natural isomorphism in the diagram. -/
def creates_colimit_of_iso_diagram {K₁ K₂ : J ⥤ C} (F : C ⥤ D) (h : K₁ ≅ K₂)
  [creates_colimit K₁ F] : creates_colimit K₂ F :=
{ lifts := λ c t,
  let t' := (is_colimit.precompose_hom_equiv (iso_whisker_right h F : _) c).symm t in
  { lifted_cocone := (cocones.precompose h.inv).obj (lift_colimit t'),
    valid_lift :=
        F.map_cocone_precompose ≪≫
        (cocones.precompose (iso_whisker_right h F).inv).map_iso
            (lifted_colimit_maps_to_original t') ≪≫
        cocones.ext (iso.refl _) (λ j, by { dsimp, rw ←F.map_comp_assoc, simp }) },
  ..reflects_colimit_of_iso_diagram F h }

/-- If `F` creates the colimit of `K` and `F ≅ G`, then `G` creates the colimit of `K`. -/
def creates_colimit_of_nat_iso {F G : C ⥤ D} (h : F ≅ G) [creates_colimit K F] :
  creates_colimit K G :=
{ lifts := λ c t,
  { lifted_cocone :=
      lift_colimit ((is_colimit.precompose_hom_equiv (iso_whisker_left K h : _) c).symm t),
    valid_lift :=
    begin
      refine (is_colimit.map_cocone_equiv h _).unique_up_to_iso t,
      apply is_colimit.of_iso_colimit _ ((lifted_colimit_maps_to_original _).symm),
      apply (is_colimit.precompose_hom_equiv _ _).symm t,
    end },
  to_reflects_colimit := reflects_colimit_of_nat_iso _ h }

/-- If `F` creates colimits of shape `J` and `F ≅ G`, then `G` creates colimits of shape `J`. -/
def creates_colimits_of_shape_of_nat_iso {F G : C ⥤ D} (h : F ≅ G)
  [creates_colimits_of_shape J F] : creates_colimits_of_shape J G :=
{ creates_colimit := λ K, creates_colimit_of_nat_iso h }

/-- If `F` creates colimits and `F ≅ G`, then `G` creates colimits. -/
def creates_colimits_of_nat_iso {F G : C ⥤ D} (h : F ≅ G) [creates_colimits_of_size.{w w'} F] :
  creates_colimits_of_size.{w w'} G :=
{ creates_colimits_of_shape := λ J 𝒥₁, by exactI creates_colimits_of_shape_of_nat_iso h }

-- For the inhabited linter later.
/-- If F creates the limit of K, any cone lifts to a limit. -/
def lifts_to_limit_of_creates (K : J ⥤ C) (F : C ⥤ D)
  [creates_limit K F] (c : cone (K ⋙ F)) (t : is_limit c) :
  lifts_to_limit K F c t :=
{ lifted_cone := lift_limit t,
  valid_lift := lifted_limit_maps_to_original t,
  makes_limit := lifted_limit_is_limit t }

-- For the inhabited linter later.
/-- If F creates the colimit of K, any cocone lifts to a colimit. -/
def lifts_to_colimit_of_creates (K : J ⥤ C) (F : C ⥤ D)
  [creates_colimit K F] (c : cocone (K ⋙ F)) (t : is_colimit c) :
  lifts_to_colimit K F c t :=
{ lifted_cocone := lift_colimit t,
  valid_lift := lifted_colimit_maps_to_original t,
  makes_colimit := lifted_colimit_is_colimit t }

/-- Any cone lifts through the identity functor. -/
def id_lifts_cone (c : cone (K ⋙ 𝟭 C)) : liftable_cone K (𝟭 C) c :=
{ lifted_cone :=
  { X := c.X,
    π := c.π ≫ K.right_unitor.hom },
  valid_lift := cones.ext (iso.refl _) (by tidy) }

/-- The identity functor creates all limits. -/
instance id_creates_limits : creates_limits_of_size.{w w'} (𝟭 C) :=
{ creates_limits_of_shape := λ J 𝒥, by exactI
  { creates_limit := λ F, { lifts := λ c t, id_lifts_cone c } } }

/-- Any cocone lifts through the identity functor. -/
def id_lifts_cocone (c : cocone (K ⋙ 𝟭 C)) : liftable_cocone K (𝟭 C) c :=
{ lifted_cocone :=
  { X := c.X,
    ι := K.right_unitor.inv ≫ c.ι },
  valid_lift := cocones.ext (iso.refl _) (by tidy) }

/-- The identity functor creates all colimits. -/
instance id_creates_colimits : creates_colimits_of_size.{w w'} (𝟭 C) :=
{ creates_colimits_of_shape := λ J 𝒥, by exactI
  { creates_colimit := λ F, { lifts := λ c t, id_lifts_cocone c } } }

/-- Satisfy the inhabited linter -/
instance inhabited_liftable_cone (c : cone (K ⋙ 𝟭 C)) :
  inhabited (liftable_cone K (𝟭 C) c) :=
⟨id_lifts_cone c⟩
instance inhabited_liftable_cocone (c : cocone (K ⋙ 𝟭 C)) :
  inhabited (liftable_cocone K (𝟭 C) c) :=
⟨id_lifts_cocone c⟩

/-- Satisfy the inhabited linter -/
instance inhabited_lifts_to_limit (K : J ⥤ C) (F : C ⥤ D)
  [creates_limit K F] (c : cone (K ⋙ F)) (t : is_limit c) :
  inhabited (lifts_to_limit _ _ _ t) :=
⟨lifts_to_limit_of_creates K F c t⟩
instance inhabited_lifts_to_colimit (K : J ⥤ C) (F : C ⥤ D)
  [creates_colimit K F] (c : cocone (K ⋙ F)) (t : is_colimit c) :
  inhabited (lifts_to_colimit _ _ _ t) :=
⟨lifts_to_colimit_of_creates K F c t⟩

section comp

variables {E : Type u₃} [ℰ : category.{v₃} E]
variables (F : C ⥤ D) (G : D ⥤ E)

instance comp_creates_limit [creates_limit K F] [creates_limit (K ⋙ F) G] :
  creates_limit K (F ⋙ G) :=
{ lifts := λ c t,
  { lifted_cone := lift_limit (lifted_limit_is_limit t),
    valid_lift := (cones.functoriality (K ⋙ F) G).map_iso
      (lifted_limit_maps_to_original (lifted_limit_is_limit t)) ≪≫
      (lifted_limit_maps_to_original t) } }

instance comp_creates_limits_of_shape [creates_limits_of_shape J F] [creates_limits_of_shape J G] :
  creates_limits_of_shape J (F ⋙ G) :=
{ creates_limit := infer_instance }

instance comp_creates_limits [creates_limits_of_size.{w w'} F] [creates_limits_of_size.{w w'} G] :
  creates_limits_of_size.{w w'} (F ⋙ G) :=
{ creates_limits_of_shape := infer_instance }

instance comp_creates_colimit [creates_colimit K F] [creates_colimit (K ⋙ F) G] :
  creates_colimit K (F ⋙ G) :=
{ lifts := λ c t,
  { lifted_cocone := lift_colimit (lifted_colimit_is_colimit t),
    valid_lift := (cocones.functoriality (K ⋙ F) G).map_iso
      (lifted_colimit_maps_to_original (lifted_colimit_is_colimit t)) ≪≫
      (lifted_colimit_maps_to_original t) } }

instance comp_creates_colimits_of_shape
  [creates_colimits_of_shape J F] [creates_colimits_of_shape J G] :
  creates_colimits_of_shape J (F ⋙ G) :=
{ creates_colimit := infer_instance }

instance comp_creates_colimits [creates_colimits_of_size.{w w'} F]
  [creates_colimits_of_size.{w w'} G] : creates_colimits_of_size.{w w'} (F ⋙ G) :=
{ creates_colimits_of_shape := infer_instance }

end comp

end creates

end category_theory


import data.set.basic
import data.list
import logic.relator

#check list.forall₂

namespace MCL_untyped

inductive type
| int
| float

open type

instance : decidable_eq type := sorry

@[reducible]
def type_map : type → Type
| int := ℕ
| float := ℕ

prefix ▸ := type_map

@[reducible]
def untyped_value := ℕ

@[reducible]
def var_map : Type := Π t : type, string → list ℕ → ▸t

def var_map.update (t : type) (n : string) (n_idx : list ℕ) (v : ▸t) (s : var_map) :=
    λ t' m m_idx, if c : (n = m ∧ n_idx = m_idx ∧ t = t') then (begin
        rw [and.right (and.right c)] at v,
        exact v,
    end) else s t' m m_idx

@[simp]
lemma var_map_update_get {t n idx v} {a : var_map} : a.update t n idx v t n idx = v := begin
    unfold var_map.update,
    simp,
    refl,
end

structure state := (global : var_map)
def state.updateGloabl (g : var_map) (s : state) : state := {global := g, ..s}

structure declaration := (scope : ℕ)(type : type)(nridx : ℕ)
def signature := string → option declaration

inductive expression : Type
| var (n : string) (idx : list expression) : expression
| add : expression → expression → expression
| literal_int {} (n : ℕ) : expression

instance : has_add expression := ⟨expression.add⟩
instance : has_zero expression := ⟨expression.literal_int 0⟩
instance : has_one expression := ⟨expression.literal_int 1⟩
open expression

inductive compute_typed_expression (sig : signature) (s : state) : Π t : type, expression → ▸t → Prop
| global_var (n : string) (d) {t : type} {idx_expr idx_evaled} (hs : sig n = some d) (ht : t = d.type) (hi : list.forall₂ (compute_typed_expression int) idx_expr idx_evaled) :
    compute_typed_expression t (var n idx_expr) (s.global t n idx_evaled) -- equality as hypthoses allows to to call cases on h₂ in compute_typed_expression_unique
| add {e₁ e₂ n₁ n₂} (h₁ : compute_typed_expression int e₁ n₁) (h₂ : compute_typed_expression int e₂ n₂) : compute_typed_expression int (add e₁ e₂) (n₁ + n₂)
| literal {n} : compute_typed_expression int (literal_int n) n

#check compute_typed_expression.literal

@[simp] -- causes the empty list to be simplified immediately (no unfold required)
def compute_expr_list (t sig s) (idx_expr : list expression) (idx_evaled : list (▸t)) := list.forall₂ (λ expr eval, compute_typed_expression sig s t expr eval) idx_expr idx_evaled

@[simp]
def compute_idx_expr := compute_expr_list int

inductive program
| assign (n : string) : list (expression) → expression → program
| seq : program → program → program
| loop (n : string) : expression → program → program
| skip : program

infixr ` ;; `:90 := program.seq
open program

inductive big_step : (program × signature × state) → state → Prop
| assign_global {t : type} {n expr d} {sig : signature} {val} {s : state} {idx_expr : list expression} {idx_evaled : list ℕ}
    (ht : sig n = some d)
    (h_eval : compute_typed_expression sig s d.type expr val)
    (h_idx : compute_idx_expr sig s idx_expr idx_evaled) :
    big_step ((assign n idx_expr expr), sig, s) { global := s.global.update d.type n idx_evaled val , ..s }
| seq {s u v sig p₁ p₂} (hp₁ : big_step (p₁, sig, s) u) (hp₂ : big_step (p₂, sig, u) v) :
    big_step (seq p₁ p₂, sig, s) v

infix ` ⟹ `:110 := big_step

lemma compute_typed_expression_unique {sig s t expr r₁ r₂} (h₂ : compute_typed_expression sig s t expr r₂) (h₁ : compute_typed_expression sig s t expr r₁) :
    r₁ = r₂ := begin
    induction h₁,
    {
        cases h₂,
        have : h₁_idx_evaled = h₁_idx_evaled := begin
            have : relator.right_unique (compute_typed_expression sig s int) := begin
                unfold relator.right_unique,
                intros expr val₁ val₂ h₁ h₂,
                -- PROBLEM: i don't get IH for (list.forall₂ (compute_typed_expression)) because the recursor does not support it
                sorry
            end,
            sorry,
            --apply list.right_unique_forall₂,
        end,
        sorry,
        -- refl,
    },
    {
        cases h₂,
        have : h₁_n₁ = h₂_n₁ := by apply h₁_x h₂_h₁,
        rw this,
        have : h₁_n₂ = h₂_n₂ := by apply h₁_x_1 h₂_h₂,
        rw this,
        refl,
    }, {
        cases h₂,
        refl,
    }
end

lemma compute_typed_expression_right_unique {sig s t} : relator.right_unique (compute_typed_expression sig s t) := begin
    unfold relator.right_unique,
    intros expr val₁ val₂ h₁ h₂,
    apply compute_typed_expression_unique,
    repeat { assumption },
end

lemma compute_expr_list_unique {sig s} {t : type} {idx_expr : list expression}  {eval₁ eval₂}
    (h₁ : compute_expr_list t sig s idx_expr eval₁) (h₂ : compute_expr_list t sig s idx_expr eval₂) : eval₁ = eval₂ :=
begin
    -- rw ← list.forall₂_eq_eq_eq, -- does rewrite perform funext here?
    apply list.right_unique_forall₂ (@compute_typed_expression_right_unique sig s t),
    repeat { assumption },
end

@[simp]
lemma big_step_assign {sig s u expr n idx_expr idx_evaled} {d : declaration} {val : ▸(d.type)}
    (hp : ((assign n idx_expr expr), sig, s) ⟹ u) (hi : compute_idx_expr sig s idx_expr idx_evaled)
    (hd : sig n = some d) (he : compute_typed_expression sig s (d.type) expr val) :
    s.global.update (d.type) n idx_evaled val = u.global :=
begin
    cases hp,
    simp,
    have : hp_idx_evaled = idx_evaled := by apply compute_expr_list_unique hp_h_idx hi,
    subst this,
    rw hd at hp_ht,
    simp at hp_ht,
    subst hp_ht,
    have : val = hp_val := by apply compute_typed_expression_unique he hp_h_eval,
    subst this,
end

lemma big_step_assign' {sig s u expr n idx_expr}
    (hp : ((assign n idx_expr expr), sig, s) ⟹ u) :
    ∃ (d : declaration) idx_evaled val, s.global.update (d.type) n idx_evaled val = u.global := begin
    cases hp,
    apply Exists.intro hp_d,
    apply Exists.intro hp_idx_evaled,
    apply Exists.intro hp_val,
    simp,
end

-- lemma big_step_seq {s} () : := begin

def s₁ : signature
| "n" := some {scope := 1, type := int, nridx := 0}
| _ := none

def p : program :=
    assign "n" [] (literal_int 1)

set_option trace.simplify.rewrite true

example {s u} (hp : (p, s₁, s) ⟹ u) : u.global int "n" [] = 1 := begin
    cases hp,
    simp at hp_ht,
    cases hp_ht,
    simp,
    cases hp_h_eval,
    sorry,
    -- apply var_map_update_get,
    -- simp,
end

end MCL_untyped


import rigid_elements.basic

variables {K : Type*} [field K]
structure rigid_pair (T H : mul_subgroup K) : Prop :=
(pos [] : ∀ x : K, x ∉ H → T.rigid x)
(neg [] : ∀ x : K, x ∉ H → T.rigid (-x))

namespace rigid_pair

variables {T H : mul_subgroup K}

lemma mk_of_le (T H : mul_subgroup K) :
  T ≤ H →
  (-1 : K) ∈ T →
  (∀ (x : K), x ≠ 0 → x ∉ H → 1 + x ∈ T ∨ x⁻¹ + 1 ∈ T) →
  rigid_pair T H :=
begin
  intros h1 h2 h3,
  constructor,
  { intros x hx a b ha hb hh,
    cases h3 (x * b * a⁻¹) _ _,
    left,
    { convert T.mul_mem ha h,
      field_simp [T.ne_zero_of_mem ha], ring },
    right,
    { convert T.mul_mem h hb,
      field_simp [T.ne_zero_of_mem hb], ring },
    { simp only [ne.def, mul_eq_zero, inv_eq_zero],
      push_neg,
      refine ⟨⟨hh, T.ne_zero_of_mem hb⟩, T.ne_zero_of_mem ha⟩ },
    { intro c, apply hx,
      convert H.mul_mem (H.mul_mem c (h1 ha)) (H.inv_mem (h1 hb)),
      field_simp [T.ne_zero_of_mem ha, T.ne_zero_of_mem hb] } },
  { intros x hx a b ha hb hh,
    cases h3 (-x * b * a⁻¹) _ _,
    left,
    { convert T.mul_mem h ha,
      field_simp [T.ne_zero_of_mem ha] },
    right,
    { convert T.mul_mem h hb,
      simp only [ne.def, neg_eq_zero] at hh,
      field_simp [T.ne_zero_of_mem hb, hh], ring },
    { simp only [ne.def, neg_eq_zero, mul_eq_zero, inv_eq_zero],
      push_neg,
      refine ⟨⟨by simpa using hh, T.ne_zero_of_mem hb⟩, T.ne_zero_of_mem ha⟩ },
    { intro c, apply hx,
      rw neg_eq_neg_one_mul at c,
      have : x = ((-1) * x * b * a⁻¹) * ((-1) * b⁻¹ * a),
      { field_simp [T.ne_zero_of_mem ha, T.ne_zero_of_mem hb] },
      rw this,
      apply H.mul_mem c,
      apply H.mul_mem,
      apply H.mul_mem,
      apply h1, apply h2,
      apply H.inv_mem, apply h1, apply hb,
      apply h1, apply ha } }
end

lemma of_le (rp : rigid_pair T H)
  (H' : mul_subgroup K) (h : H ≤ H') : rigid_pair T H' :=
begin
  constructor,
  { intros x hx,
    exact rp.pos x (λ c, hx (h c)) },
  { intros x hx,
    exact rp.neg x (λ c, hx (h c)) }
end

lemma le (rp : rigid_pair T H) : T ≤ H :=
begin
  intros t ht,
  by_contra c,
  have hh := rp.neg t c,
  specialize hh t 1 ht T.one_mem (by simpa using T.ne_zero_of_mem ht),
  cases hh,
  { apply T.zero_nmem, convert hh, simp },
  { apply T.zero_nmem, convert hh,
    field_simp [(show (-t) ≠ 0, by simpa using T.ne_zero_of_mem ht)] }
end

lemma le_neg (rp : rigid_pair T H) {t : K} (ht : t ∈ T) :
  -t ∈ H :=
begin
  by_contra c,
  have hh := rp.pos (-t) c,
  specialize hh t 1 ht T.one_mem (by simpa using T.ne_zero_of_mem ht),
  cases hh,
  { apply T.zero_nmem, convert hh, simp },
  { apply T.zero_nmem, convert hh,
    field_simp [(show (-t) ≠ 0, by simpa using T.ne_zero_of_mem ht)] }
end

lemma neg_one_mem (rp : rigid_pair T H) : (-1 : K) ∈ H :=
rp.le_neg T.one_mem

lemma neg_mem_of_mem (rp : rigid_pair T H) (x : K) (hx : x ∈ H) : (-x) ∈ H :=
begin
  rw neg_eq_neg_one_mul,
  exact H.mul_mem rp.neg_one_mem hx,
end

lemma mem_of_neg_mem (rp : rigid_pair T H) (x : K) (hx : (-x) ∈ H) : x ∈ H :=
begin
  rw (show x = (-1) * (-x), by ring),
  exact H.mul_mem rp.neg_one_mem hx
end

def OO_m (rp : rigid_pair T H) : set K :=
{ x | x ∉ H ∧ 1 + x ∈ T }

def OO_p (rp : rigid_pair T H) : set K :=
{ x | x ∈ H ∧ ∀ y : K, y ∈ rp.OO_m → x * y ∈ rp.OO_m }

def OO (rp : rigid_pair T H) : set K := rp.OO_m ∪ rp.OO_p

def UU (rp : rigid_pair T H) : set K :=
{ x | x ∈ rp.OO_p ∧ x⁻¹ ∈ rp.OO_p }

-- Observation 2.3 (1), part 1
lemma OO_p_one_mem (rp : rigid_pair T H) : (1 : K) ∈ rp.OO_p :=
begin
  refine ⟨H.one_mem, _⟩,
  intros y hy, rwa one_mul
end

-- Observation 2.3 (1), part 2
lemma OO_p_mul_mem (rp : rigid_pair T H) {x y : K} : x ∈ rp.OO_p → y ∈ rp.OO_p →
  x * y ∈ rp.OO_p :=
begin
  rintros ⟨h1,h1'⟩ ⟨h2,h2'⟩,
  refine ⟨H.mul_mem h1 h2, _⟩,
  intros z hz, rw mul_assoc,
  apply h1', apply h2', exact hz
end

-- Observation 2.3 (1), part 3
lemma UU_one_mem (rp : rigid_pair T H) : (1 : K) ∈ rp.UU :=
⟨rp.OO_p_one_mem, by { rw inv_one, exact rp.OO_p_one_mem }⟩

-- Observation 2.3 (1), part 4
lemma UU_mul_mem (rp : rigid_pair T H) {x y : K} :
  x ∈ rp.UU  → y ∈ rp.UU → x * y ∈ rp.UU :=
begin
  rintros ⟨hx,hx'⟩ ⟨hy,hy'⟩,
  split,
  { exact rp.OO_p_mul_mem hx hy },
  { rw mul_inv, exact rp.OO_p_mul_mem hx' hy' },
end

-- Observation 2.3 (1), part 5
lemma UU_inv_mem (rp : rigid_pair T H) {x : K} :
  x ∈ rp.UU → x⁻¹ ∈ rp.UU :=
begin
  rintros ⟨h1,h2⟩, refine ⟨h2, by simpa⟩
end

-- Observation 2.3 (1), part 6
lemma UU_ne_zero_of_mem (rp : rigid_pair T H) (x : K) (hx : x ∈ rp.UU) :
  x ≠ 0 :=
H.ne_zero_of_mem hx.1.1

-- Observation 2.3 (2)
lemma OO_m_zero_mem (rp : rigid_pair T H) : (0 : K) ∈ rp.OO_m :=
begin
  refine ⟨H.zero_nmem,_⟩,
  simpa using T.one_mem,
end

-- Observation 2.3 (3)
lemma OO_m_mem_iff_inv_nmem (rp : rigid_pair T H) (x : K) (hx : x ≠ 0) (hxH : x ∉ H) :
  x ∈ rp.OO_m ↔ x⁻¹ ∉ rp.OO_m :=
begin
  split,
  { intro h, dsimp [OO_m], push_neg, intros hx' c,
    apply hx', apply rp.le,
    have : 1 + x⁻¹ = x⁻¹ * (1 + x), by { field_simp, ring },
    rw this at c,
    have : 1 + x ≠ 0 := ne_zero_right (T.ne_zero_of_mem c),
    convert T.mul_mem c (T.inv_mem h.2),
    field_simp, ring },
  { intros c, dsimp [OO_m] at c, push_neg at c, specialize c _,
    { intro cc, apply hxH, rw ← inv_inv x, exact H.inv_mem cc },
    refine ⟨hxH,_⟩,
    cases rp.pos _ hxH 1 1 T.one_mem T.one_mem hx,
    { simpa using h },
    { exfalso, apply c, convert h using 1, ring } }
end

-- Observation 2.3 (4)
lemma exists_inv_eq_mul (rp : rigid_pair T H)
  (x : K) (hx : x ∈ H) (hx' : x ∉ rp.OO_p) :
  ∃ (y z : K) (hy : y ∈ rp.OO_m) (hz : z ∈ rp.OO_m), x⁻¹ = y * z :=
begin
  dsimp [OO_p] at hx', push_neg at hx', specialize hx' hx,
  obtain ⟨y,hy1,hy2⟩ := hx',
  use [y, (x * y)⁻¹, hy1],
  have : y ≠ 0,
  { contrapose! hy2, rw [hy2, mul_zero], exact rp.OO_m_zero_mem },
  split,
  { rw rp.OO_m_mem_iff_inv_nmem,
    { rwa inv_inv },
    { apply inv_ne_zero, exact mul_ne_zero (H.ne_zero_of_mem hx) this },
    have hhy := hy1.1,
    contrapose! hhy,
    rw mul_inv at hhy,
    rw ← inv_inv y,
    apply H.inv_mem,
    convert H.mul_mem hx hhy,
    field_simp [mul_ne_zero (H.ne_zero_of_mem hx) this] },
  { field_simp [mul_ne_zero (H.ne_zero_of_mem hx) this,
      H.ne_zero_of_mem hx], rw mul_comm }
end

-- Observation 2.3 (5) -- setup
lemma OO_m_one_plus_ne_zero_of_mem (rp : rigid_pair T H) (x : K) (hx : x ∈ rp.OO_m) :
  1 + x ≠ 0 :=
T.ne_zero_of_mem $ hx.2

-- Observation 2.3 (5)
lemma OO_m_neg_div_one_plus_mem_of_mem (rp : rigid_pair T H) (x : K)
  (hx : x ∈ rp.OO_m) : -x * (1 + x)⁻¹ ∈ rp.OO_m :=
begin
  split,
  { intro c, apply hx.1,
    convert H.mul_mem (rp.neg_one_mem) (H.mul_mem c (rp.le hx.2)),
    field_simp [rp.OO_m_one_plus_ne_zero_of_mem x hx] },
  { rw (show 1 + -x * (1 + x)⁻¹ = (1+x)⁻¹,
      by field_simp [rp.OO_m_one_plus_ne_zero_of_mem x hx]),
    apply T.inv_mem, exact hx.2 }
end

def preadditive (rp : rigid_pair T H) : Prop :=
  ∀ (x : K) (hx : x ∈ rp.OO_m), 1 + x ∈ rp.OO_p

variables {T H}

lemma preadditive_iff_aux (rp : rigid_pair T H) :
  rp.preadditive ↔
  (∀ (x y : K) (hx : x ∈ rp.OO_m) (hy : y ∈ rp.OO_m), 1 + (1 + x) * y ∈ T) :=
begin
  split,
  { introsI h x y hx hy,
    apply (((h x hx).2) y hy).2 },
  { intros h,
    intros x hx,
    split,
    { apply rp.le, exact hx.2 },
    { intros y hy, split,
      { intros c, apply hy.1,
        convert H.mul_mem (H.inv_mem (rp.le hx.2)) c,
        field_simp [T.ne_zero_of_mem hx.2], ring },
      { apply h, assumption' } } }
end

-- Lemma 2.6 (1)↔(2)
lemma preadditive_iff (rp : rigid_pair T H) :
  rp.preadditive ↔
  (∀ (x y : K) (hx : x ∈ rp.OO_m) (hy : y ∈ rp.OO_m), 1 - x * y ∈ T) :=
begin
  rw preadditive_iff_aux,
  split,
  { intros h x y hx hy,
    have : 1 - x * y = (1 + y) * (1 + (1 + x) * ((-y * (1 + y)⁻¹))),
    { field_simp [rp.OO_m_one_plus_ne_zero_of_mem y hy], ring },
    rw this, clear this,
    apply T.mul_mem hy.2,
    apply h _ _ hx,
    apply rp.OO_m_neg_div_one_plus_mem_of_mem _ hy },
  { intros h x y hx hy,
    let z := -y * (1 + y)⁻¹,
    have hz : z ∈ rp.OO_m := rp.OO_m_neg_div_one_plus_mem_of_mem _ hy,
    have : y = - z * (1 + z)⁻¹,
    { dsimp [z],
      field_simp [rp.OO_m_one_plus_ne_zero_of_mem z hz,
        rp.OO_m_one_plus_ne_zero_of_mem y hy] },
    rw this, clear this,
    suffices : (1 + z) * (1 + (1 + x) * (-z * (1+z)⁻¹)) ∈ T,
    { convert T.mul_mem this (T.inv_mem hz.2),
      field_simp [rp.OO_m_one_plus_ne_zero_of_mem z hz], ring },
    have : (1 + z) * (1 + (1 + x) * (-z * (1 + z)⁻¹)) = 1 - x * z,
    { field_simp [rp.OO_m_one_plus_ne_zero_of_mem z hz], ring },
    rw this,
    apply h, assumption' }
end

-- Lemma 2.6 (3)
lemma preadditive.one_sub_mul_mem {rp : rigid_pair T H} (h : rp.preadditive) :
  (∀ (x y : K), x ≠ 0 → 1 + x ∈ rp.OO_p → y ∈ rp.OO_m →
    1 - x * y ∈ T ∧ 1 - x * y ∈ rp.OO_p) :=
begin
  intros x y hxz hx hy,
  have : 1 - x * y = (1 + y) * (1 + (1 + x) * (-y * (1+y)⁻¹)),
  { field_simp [rp.OO_m_one_plus_ne_zero_of_mem y hy], ring },
  rw this, clear this,
  have hy' : -y * (1 + y)⁻¹ ∈ rp.OO_m := rp.OO_m_neg_div_one_plus_mem_of_mem y hy,
  have := hx.2 _ hy',
  split,
  { apply T.mul_mem hy.2 this.2 },
  { apply rp.OO_p_mul_mem (h _ hy) (h _ this) }
end

-- Lemma 2.9 (1)
lemma preadditive.mul_mem_of_mem {rp : rigid_pair T H} (h : rp.preadditive) :
  ∀ (x y : K), x ∈ rp.OO_m → y ∈ rp.OO_m → x * y ∈ H → x * y ∈ rp.OO_p :=
begin
  intros x y hx hy hxy,
  refine ⟨hxy,_⟩,
  intros z hz, split,
  { intros c,
    apply hz.1, convert H.mul_mem (H.inv_mem hxy) c,
    field_simp [H.ne_zero_of_mem hxy], ring },
  have : 1 - x * y ∈ T ∧ 1 - x * y ∈ rp.OO_p,
  { apply h.one_sub_mul_mem,
    { intro c, apply H.ne_zero_of_mem hxy, rw [c, zero_mul] },
    { apply h _ hx },
    { exact hy } },
  rw (show (1 + x * y * z = 1 - (- (x * y) * z)), by ring),
  apply (h.one_sub_mul_mem _ _ _ _ _).1,
  { rw neg_ne_zero, exact H.ne_zero_of_mem hxy },
  { convert this.2, ring },
  { exact hz },
end

-- Lemma 2.9 (2)
lemma preadditive.inv_mem_of_nmem {rp : rigid_pair T H} (h : rp.preadditive) :
  ∀ x : K, x ∉ rp.OO → x⁻¹ ∈ rp.OO :=
begin
  intros x hx,
  by_cases hxz : x = 0, { left, rw [hxz, inv_zero], apply rp.OO_m_zero_mem },
  by_cases hxH : x ∈ H, swap,
  { by_contra c, dsimp only [OO] at c,
    simp only [set.mem_union] at c, push_neg at c,
    replace c := c.1,
    rw ← rp.OO_m_mem_iff_inv_nmem at c,
    { apply hx, left, exact c },
    assumption' },
  dsimp only [OO, set.mem_union] at hx,
  push_neg at hx, cases hx with hx1 hx2,
  obtain ⟨y,z,hy,hz,hyz⟩ := rp.exists_inv_eq_mul x hxH hx2,
  rw hyz, right, apply h.mul_mem_of_mem _ _ hy hz,
  rw ← hyz, apply H.inv_mem, exact hxH
end

-- Lemma 2.9 (3)
lemma preadditive.neg_one_mem {rp : rigid_pair T H} (h : rp.preadditive) :
  (-1 : K) ∈ rp.OO_p :=
begin
  suffices : (-1 : K) ∈ rp.OO,
  { cases this, swap, assumption,
    exfalso, apply this.1, apply rp.neg_one_mem },
  by_contra c, apply c,
  convert h.inv_mem_of_nmem _ c using 1,
  ring,
end

end rigid_pair