/-
Copyright (c) 2019 Reid Barton. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Reid Barton, Johan Commelin
-/
import category_theory.adjunction.basic
import category_theory.limits.creates

/-!
# Adjunctions and limits

A left adjoint preserves colimits (`category_theory.adjunction.left_adjoint_preserves_colimits`),
and a right adjoint preserves limits (`category_theory.adjunction.right_adjoint_preserves_limits`).

Equivalences create and reflect (co)limits.
(`category_theory.adjunction.is_equivalence_creates_limits`,
`category_theory.adjunction.is_equivalence_creates_colimits`,
`category_theory.adjunction.is_equivalence_reflects_limits`,
`category_theory.adjunction.is_equivalence_reflects_colimits`,)

In `category_theory.adjunction.cocones_iso` we show that
when `F ⊣ G`,
the functor associating to each `Y` the cocones over `K ⋙ F` with cone point `Y`
is naturally isomorphic to
the functor associating to each `Y` the cocones over `K` with cone point `G.obj Y`.
-/

open opposite

namespace category_theory.adjunction
open category_theory
open category_theory.functor
open category_theory.limits

universes v u v₁ v₂ v₀ u₁ u₂

section arbitrary_universe

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

variables {F : C ⥤ D} {G : D ⥤ C} (adj : F ⊣ G)
include adj

section preservation_colimits
variables {J : Type u} [category.{v} J] (K : J ⥤ C)

/--
The right adjoint of `cocones.functoriality K F : cocone K ⥤ cocone (K ⋙ F)`.

Auxiliary definition for `functoriality_is_left_adjoint`.
-/
def functoriality_right_adjoint : cocone (K ⋙ F) ⥤ cocone K :=
(cocones.functoriality _ G) ⋙
  (cocones.precompose (K.right_unitor.inv ≫ (whisker_left K adj.unit) ≫ (associator _ _ _).inv))

local attribute [reducible] functoriality_right_adjoint

/--
The unit for the adjunction for `cocones.functoriality K F : cocone K ⥤ cocone (K ⋙ F)`.

Auxiliary definition for `functoriality_is_left_adjoint`.
-/
@[simps] def functoriality_unit :
  𝟭 (cocone K) ⟶ cocones.functoriality _ F ⋙ functoriality_right_adjoint adj K :=
{ app := λ c, { hom := adj.unit.app c.X } }

/--
The counit for the adjunction for `cocones.functoriality K F : cocone K ⥤ cocone (K ⋙ F)`.

Auxiliary definition for `functoriality_is_left_adjoint`.
-/
@[simps] def functoriality_counit :
  functoriality_right_adjoint adj K ⋙ cocones.functoriality _ F ⟶ 𝟭 (cocone (K ⋙ F)) :=
{ app := λ c, { hom := adj.counit.app c.X } }

/-- The functor `cocones.functoriality K F : cocone K ⥤ cocone (K ⋙ F)` is a left adjoint. -/
def functoriality_is_left_adjoint :
  is_left_adjoint (cocones.functoriality K F) :=
{ right := functoriality_right_adjoint adj K,
  adj := mk_of_unit_counit
  { unit := functoriality_unit adj K,
    counit := functoriality_counit adj K } }

/--
A left adjoint preserves colimits.

See https://stacks.math.columbia.edu/tag/0038.
-/
def left_adjoint_preserves_colimits : preserves_colimits_of_size.{v u} F :=
{ preserves_colimits_of_shape := λ J 𝒥,
  { preserves_colimit := λ F,
    by exactI
    { preserves := λ c hc, is_colimit.iso_unique_cocone_morphism.inv
        (λ s, @equiv.unique _ _ (is_colimit.iso_unique_cocone_morphism.hom hc _)
          (((adj.functoriality_is_left_adjoint _).adj).hom_equiv _ _)) } } }.

omit adj

@[priority 100] -- see Note [lower instance priority]
instance is_equivalence_preserves_colimits (E : C ⥤ D) [is_equivalence E] :
  preserves_colimits_of_size.{v u} E :=
left_adjoint_preserves_colimits E.adjunction

@[priority 100] -- see Note [lower instance priority]
instance is_equivalence_reflects_colimits (E : D ⥤ C) [is_equivalence E] :
  reflects_colimits_of_size.{v u} E :=
{ reflects_colimits_of_shape := λ J 𝒥, by exactI
  { reflects_colimit := λ K,
    { reflects := λ c t,
      begin
        have l := (is_colimit_of_preserves E.inv t).map_cocone_equiv E.as_equivalence.unit_iso.symm,
        refine (((is_colimit.precompose_inv_equiv K.right_unitor _).symm) l).of_iso_colimit _,
        tidy,
      end } } }

@[priority 100] -- see Note [lower instance priority]
instance is_equivalence_creates_colimits (H : D ⥤ C) [is_equivalence H] :
  creates_colimits_of_size.{v u} H :=
{ creates_colimits_of_shape := λ J 𝒥, by exactI
  { creates_colimit := λ F,
    { lifts := λ c t,
      { lifted_cocone := H.map_cocone_inv c,
        valid_lift := H.map_cocone_map_cocone_inv c } } } }

-- verify the preserve_colimits instance works as expected:
example (E : C ⥤ D) [is_equivalence E]
  (c : cocone K) (h : is_colimit c) : is_colimit (E.map_cocone c) :=
preserves_colimit.preserves h

lemma has_colimit_comp_equivalence (E : C ⥤ D) [is_equivalence E] [has_colimit K] :
  has_colimit (K ⋙ E) :=
has_colimit.mk
{ cocone := E.map_cocone (colimit.cocone K),
  is_colimit := preserves_colimit.preserves (colimit.is_colimit K) }

lemma has_colimit_of_comp_equivalence (E : C ⥤ D) [is_equivalence E] [has_colimit (K ⋙ E)] :
  has_colimit K :=
@has_colimit_of_iso _ _ _ _ (K ⋙ E ⋙ inv E) K
(@has_colimit_comp_equivalence _ _ _ _ _ _ (K ⋙ E) (inv E) _ _)
((functor.right_unitor _).symm ≪≫ iso_whisker_left K (E.as_equivalence.unit_iso))

/-- Transport a `has_colimits_of_shape` instance across an equivalence. -/
lemma has_colimits_of_shape_of_equivalence (E : C ⥤ D) [is_equivalence E]
  [has_colimits_of_shape J D] : has_colimits_of_shape J C :=
⟨λ F, by exactI has_colimit_of_comp_equivalence F E⟩

/-- Transport a `has_colimits` instance across an equivalence. -/
lemma has_colimits_of_equivalence (E : C ⥤ D) [is_equivalence E] [has_colimits_of_size.{v u} D] :
  has_colimits_of_size.{v u} C :=
⟨λ J hJ, by { exactI has_colimits_of_shape_of_equivalence E }⟩

end preservation_colimits

section preservation_limits
variables {J : Type u} [category.{v} J] (K : J ⥤ D)

/--
The left adjoint of `cones.functoriality K G : cone K ⥤ cone (K ⋙ G)`.

Auxiliary definition for `functoriality_is_right_adjoint`.
-/
def functoriality_left_adjoint : cone (K ⋙ G) ⥤ cone K :=
(cones.functoriality _ F) ⋙ (cones.postcompose
    ((associator _ _ _).hom ≫ (whisker_left K adj.counit) ≫ K.right_unitor.hom))

local attribute [reducible] functoriality_left_adjoint

/--
The unit for the adjunction for`cones.functoriality K G : cone K ⥤ cone (K ⋙ G)`.

Auxiliary definition for `functoriality_is_right_adjoint`.
-/
@[simps] def functoriality_unit' :
  𝟭 (cone (K ⋙ G)) ⟶ functoriality_left_adjoint adj K ⋙ cones.functoriality _ G :=
{ app := λ c, { hom := adj.unit.app c.X, } }

/--
The counit for the adjunction for`cones.functoriality K G : cone K ⥤ cone (K ⋙ G)`.

Auxiliary definition for `functoriality_is_right_adjoint`.
-/
@[simps] def functoriality_counit' :
  cones.functoriality _ G ⋙ functoriality_left_adjoint adj K ⟶ 𝟭 (cone K) :=
{ app := λ c, { hom := adj.counit.app c.X, } }

/-- The functor `cones.functoriality K G : cone K ⥤ cone (K ⋙ G)` is a right adjoint. -/
def functoriality_is_right_adjoint :
  is_right_adjoint (cones.functoriality K G) :=
{ left := functoriality_left_adjoint adj K,
  adj := mk_of_unit_counit
  { unit := functoriality_unit' adj K,
    counit := functoriality_counit' adj K } }

/--
A right adjoint preserves limits.

See https://stacks.math.columbia.edu/tag/0038.
-/
def right_adjoint_preserves_limits : preserves_limits_of_size.{v u} G :=
{ preserves_limits_of_shape := λ J 𝒥,
  { preserves_limit := λ K,
    by exactI
    { preserves := λ c hc, is_limit.iso_unique_cone_morphism.inv
        (λ s, @equiv.unique _ _ (is_limit.iso_unique_cone_morphism.hom hc _)
          (((adj.functoriality_is_right_adjoint _).adj).hom_equiv _ _).symm) } } }.

omit adj

@[priority 100] -- see Note [lower instance priority]
instance is_equivalence_preserves_limits (E : D ⥤ C) [is_equivalence E] :
  preserves_limits_of_size.{v u} E :=
right_adjoint_preserves_limits E.inv.adjunction

@[priority 100] -- see Note [lower instance priority]
instance is_equivalence_reflects_limits (E : D ⥤ C) [is_equivalence E] :
  reflects_limits_of_size.{v u} E :=
{ reflects_limits_of_shape := λ J 𝒥, by exactI
  { reflects_limit := λ K,
    { reflects := λ c t,
      begin
        have := (is_limit_of_preserves E.inv t).map_cone_equiv E.as_equivalence.unit_iso.symm,
        refine (((is_limit.postcompose_hom_equiv K.left_unitor _).symm) this).of_iso_limit _,
        tidy,
      end } } }

@[priority 100] -- see Note [lower instance priority]
instance is_equivalence_creates_limits (H : D ⥤ C) [is_equivalence H] :
  creates_limits_of_size.{v u} H :=
{ creates_limits_of_shape := λ J 𝒥, by exactI
  { creates_limit := λ F,
    { lifts := λ c t,
      { lifted_cone := H.map_cone_inv c,
        valid_lift := H.map_cone_map_cone_inv c } } } }

-- verify the preserve_limits instance works as expected:
example (E : D ⥤ C) [is_equivalence E]
  (c : cone K) [h : is_limit c] : is_limit (E.map_cone c) :=
preserves_limit.preserves h

lemma has_limit_comp_equivalence (E : D ⥤ C) [is_equivalence E] [has_limit K] :
  has_limit (K ⋙ E) :=
has_limit.mk
{ cone := E.map_cone (limit.cone K),
  is_limit := preserves_limit.preserves (limit.is_limit K) }

lemma has_limit_of_comp_equivalence (E : D ⥤ C) [is_equivalence E] [has_limit (K ⋙ E)] :
  has_limit K :=
@has_limit_of_iso _ _ _ _ (K ⋙ E ⋙ inv E) K
(@has_limit_comp_equivalence _ _ _ _ _ _ (K ⋙ E) (inv E) _ _)
((iso_whisker_left K E.as_equivalence.unit_iso.symm) ≪≫ (functor.right_unitor _))

/-- Transport a `has_limits_of_shape` instance across an equivalence. -/
lemma has_limits_of_shape_of_equivalence (E : D ⥤ C) [is_equivalence E] [has_limits_of_shape J C] :
  has_limits_of_shape J D :=
⟨λ F, by exactI has_limit_of_comp_equivalence F E⟩

/-- Transport a `has_limits` instance across an equivalence. -/
lemma has_limits_of_equivalence (E : D ⥤ C) [is_equivalence E] [has_limits_of_size.{v u} C] :
  has_limits_of_size.{v u} D :=
⟨λ J hJ, by exactI has_limits_of_shape_of_equivalence E⟩

end preservation_limits

/-- auxiliary construction for `cocones_iso` -/
@[simps]
def cocones_iso_component_hom {J : Type u} [category.{v} J] {K : J ⥤ C}
  (Y : D) (t : ((cocones J D).obj (op (K ⋙ F))).obj Y) :
  (G ⋙ (cocones J C).obj (op K)).obj Y :=
{ app := λ j, (adj.hom_equiv (K.obj j) Y) (t.app j),
  naturality' := λ j j' f, by { erw [← adj.hom_equiv_naturality_left, t.naturality], dsimp, simp } }

/-- auxiliary construction for `cocones_iso` -/
@[simps]
def cocones_iso_component_inv {J : Type u} [category.{v} J] {K : J ⥤ C}
  (Y : D) (t : (G ⋙ (cocones J C).obj (op K)).obj Y) :
  ((cocones J D).obj (op (K ⋙ F))).obj Y :=
{ app := λ j, (adj.hom_equiv (K.obj j) Y).symm (t.app j),
  naturality' := λ j j' f,
  begin
    erw [← adj.hom_equiv_naturality_left_symm, ← adj.hom_equiv_naturality_right_symm, t.naturality],
    dsimp, simp
  end }

/-- auxiliary construction for `cones_iso` -/
@[simps]
def cones_iso_component_hom {J : Type u} [category.{v} J] {K : J ⥤ D}
  (X : Cᵒᵖ) (t : (functor.op F ⋙ (cones J D).obj K).obj X) :
  ((cones J C).obj (K ⋙ G)).obj X :=
{ app := λ j, (adj.hom_equiv (unop X) (K.obj j)) (t.app j),
  naturality' := λ j j' f,
  begin
    erw [← adj.hom_equiv_naturality_right, ← t.naturality, category.id_comp, category.id_comp],
    refl
  end }

/-- auxiliary construction for `cones_iso` -/
@[simps]
def cones_iso_component_inv {J : Type u} [category.{v} J] {K : J ⥤ D}
  (X : Cᵒᵖ) (t : ((cones J C).obj (K ⋙ G)).obj X) :
  (functor.op F ⋙ (cones J D).obj K).obj X :=
{ app := λ j, (adj.hom_equiv (unop X) (K.obj j)).symm (t.app j),
  naturality' := λ j j' f,
  begin
    erw [← adj.hom_equiv_naturality_right_symm, ← t.naturality, category.id_comp, category.id_comp]
  end }

end arbitrary_universe

variables {C : Type u₁} [category.{v₀} C] {D : Type u₂} [category.{v₀} D]
{F : C ⥤ D} {G : D ⥤ C} (adj : F ⊣ G)

/--
When `F ⊣ G`,
the functor associating to each `Y` the cocones over `K ⋙ F` with cone point `Y`
is naturally isomorphic to
the functor associating to each `Y` the cocones over `K` with cone point `G.obj Y`.
-/
-- Note: this is natural in K, but we do not yet have the tools to formulate that.
def cocones_iso {J : Type u} [category.{v} J] {K : J ⥤ C} :
  (cocones J D).obj (op (K ⋙ F)) ≅ G ⋙ (cocones J C).obj (op K) :=
nat_iso.of_components (λ Y,
{ hom := cocones_iso_component_hom adj Y,
  inv := cocones_iso_component_inv adj Y, })
(by tidy)

-- Note: this is natural in K, but we do not yet have the tools to formulate that.
/--
When `F ⊣ G`,
the functor associating to each `X` the cones over `K` with cone point `F.op.obj X`
is naturally isomorphic to
the functor associating to each `X` the cones over `K ⋙ G` with cone point `X`.
-/
def cones_iso {J : Type u} [category.{v} J] {K : J ⥤ D} :
  F.op ⋙ (cones J D).obj K ≅ (cones J C).obj (K ⋙ G) :=
nat_iso.of_components (λ X,
{ hom := cones_iso_component_hom adj X,
  inv := cones_iso_component_inv adj X, } )
(by tidy)

end category_theory.adjunction


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

! This file was ported from Lean 3 source module topology.order.hom.esakia
! leanprover-community/mathlib commit 9822b65bfc4ac74537d77ae318d27df1df662471
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.Order.Hom.Bounded
import Mathbin.Topology.Order.Hom.Basic

/-!
# Esakia morphisms

This file defines pseudo-epimorphisms and Esakia morphisms.

We use the `fun_like` design, so each type of morphisms has a companion typeclass which is meant to
be satisfied by itself and all stricter types.

## Types of morphisms

* `pseudo_epimorphism`: Pseudo-epimorphisms. Maps `f` such that `f a ≤ b` implies the existence of
  `a'` such that `a ≤ a'` and `f a' = b`.
* `esakia_hom`: Esakia morphisms. Continuous pseudo-epimorphisms.

## Typeclasses

* `pseudo_epimorphism_class`
* `esakia_hom_class`

## References

* [Wikipedia, *Esakia space*](https://en.wikipedia.org/wiki/Esakia_space)
-/

open Function

variable {F α β γ δ : Type _}

/-- The type of pseudo-epimorphisms, aka p-morphisms, aka bounded maps, from `α` to `β`. -/
structure PseudoEpimorphism (α β : Type _) [Preorder α] [Preorder β] extends α →o β where
  exists_map_eq_of_map_le' ⦃a : α⦄ ⦃b : β⦄ : to_fun a ≤ b → ∃ c, a ≤ c ∧ to_fun c = b
#align pseudo_epimorphism PseudoEpimorphism

/-- The type of Esakia morphisms, aka continuous pseudo-epimorphisms, from `α` to `β`. -/
structure EsakiaHom (α β : Type _) [TopologicalSpace α] [Preorder α] [TopologicalSpace β]
  [Preorder β] extends α →Co β where
  exists_map_eq_of_map_le' ⦃a : α⦄ ⦃b : β⦄ : to_fun a ≤ b → ∃ c, a ≤ c ∧ to_fun c = b
#align esakia_hom EsakiaHom

section

/-- `pseudo_epimorphism_class F α β` states that `F` is a type of `⊔`-preserving morphisms.

You should extend this class when you extend `pseudo_epimorphism`. -/
class PseudoEpimorphismClass (F : Type _) (α β : outParam <| Type _) [Preorder α]
  [Preorder β] extends RelHomClass F ((· ≤ ·) : α → α → Prop) ((· ≤ ·) : β → β → Prop) where
  exists_map_eq_of_map_le (f : F) ⦃a : α⦄ ⦃b : β⦄ : f a ≤ b → ∃ c, a ≤ c ∧ f c = b
#align pseudo_epimorphism_class PseudoEpimorphismClass

/-- `esakia_hom_class F α β` states that `F` is a type of lattice morphisms.

You should extend this class when you extend `esakia_hom`. -/
class EsakiaHomClass (F : Type _) (α β : outParam <| Type _) [TopologicalSpace α] [Preorder α]
  [TopologicalSpace β] [Preorder β] extends ContinuousOrderHomClass F α β where
  exists_map_eq_of_map_le (f : F) ⦃a : α⦄ ⦃b : β⦄ : f a ≤ b → ∃ c, a ≤ c ∧ f c = b
#align esakia_hom_class EsakiaHomClass

end

export PseudoEpimorphismClass (exists_map_eq_of_map_le)

-- See note [lower instance priority]
instance (priority := 100) PseudoEpimorphismClass.toTopHomClass [PartialOrder α] [OrderTop α]
    [Preorder β] [OrderTop β] [PseudoEpimorphismClass F α β] : TopHomClass F α β :=
  { ‹PseudoEpimorphismClass F α β› with
    map_top := fun f =>
      by
      let ⟨b, h⟩ := exists_map_eq_of_map_le f (@le_top _ _ _ <| f ⊤)
      rw [← top_le_iff.1 h.1, h.2] }
#align pseudo_epimorphism_class.to_top_hom_class PseudoEpimorphismClass.toTopHomClass

-- See note [lower instance priority]
instance (priority := 100) OrderIsoClass.toPseudoEpimorphismClass [Preorder α] [Preorder β]
    [OrderIsoClass F α β] : PseudoEpimorphismClass F α β :=
  { OrderIsoClass.toOrderHomClass with
    exists_map_eq_of_map_le := fun f a b h =>
      ⟨EquivLike.inv f b, (le_map_inv_iff f).2 h, EquivLike.right_inv _ _⟩ }
#align order_iso_class.to_pseudo_epimorphism_class OrderIsoClass.toPseudoEpimorphismClass

-- See note [lower instance priority]
instance (priority := 100) EsakiaHomClass.toPseudoEpimorphismClass [TopologicalSpace α] [Preorder α]
    [TopologicalSpace β] [Preorder β] [EsakiaHomClass F α β] : PseudoEpimorphismClass F α β :=
  { ‹EsakiaHomClass F α β› with }
#align esakia_hom_class.to_pseudo_epimorphism_class EsakiaHomClass.toPseudoEpimorphismClass

instance [Preorder α] [Preorder β] [PseudoEpimorphismClass F α β] :
    CoeTC F (PseudoEpimorphism α β) :=
  ⟨fun f => ⟨f, exists_map_eq_of_map_le f⟩⟩

instance [TopologicalSpace α] [Preorder α] [TopologicalSpace β] [Preorder β]
    [EsakiaHomClass F α β] : CoeTC F (EsakiaHom α β) :=
  ⟨fun f => ⟨f, exists_map_eq_of_map_le f⟩⟩

/-! ### Pseudo-epimorphisms -/

namespace PseudoEpimorphism

variable [Preorder α] [Preorder β] [Preorder γ] [Preorder δ]

instance : PseudoEpimorphismClass (PseudoEpimorphism α β) α β
    where
  coe f := f.toFun
  coe_injective' f g h := by
    obtain ⟨⟨_, _⟩, _⟩ := f
    obtain ⟨⟨_, _⟩, _⟩ := g
    congr
  map_rel f := f.monotone'
  exists_map_eq_of_map_le := PseudoEpimorphism.exists_map_eq_of_map_le'

/-- Helper instance for when there's too many metavariables to apply `fun_like.has_coe_to_fun`
directly. -/
instance : CoeFun (PseudoEpimorphism α β) fun _ => α → β :=
  FunLike.hasCoeToFun

@[simp]
theorem toFun_eq_coe {f : PseudoEpimorphism α β} : f.toFun = (f : α → β) :=
  rfl
#align pseudo_epimorphism.to_fun_eq_coe PseudoEpimorphism.toFun_eq_coe

@[ext]
theorem ext {f g : PseudoEpimorphism α β} (h : ∀ a, f a = g a) : f = g :=
  FunLike.ext f g h
#align pseudo_epimorphism.ext PseudoEpimorphism.ext

/-- Copy of a `pseudo_epimorphism` with a new `to_fun` equal to the old one. Useful to fix
definitional equalities. -/
protected def copy (f : PseudoEpimorphism α β) (f' : α → β) (h : f' = f) : PseudoEpimorphism α β :=
  ⟨f.toOrderHom.copy f' h, by simpa only [h.symm, to_fun_eq_coe] using f.exists_map_eq_of_map_le'⟩
#align pseudo_epimorphism.copy PseudoEpimorphism.copy

@[simp]
theorem coe_copy (f : PseudoEpimorphism α β) (f' : α → β) (h : f' = f) : ⇑(f.copy f' h) = f' :=
  rfl
#align pseudo_epimorphism.coe_copy PseudoEpimorphism.coe_copy

theorem copy_eq (f : PseudoEpimorphism α β) (f' : α → β) (h : f' = f) : f.copy f' h = f :=
  FunLike.ext' h
#align pseudo_epimorphism.copy_eq PseudoEpimorphism.copy_eq

variable (α)

/-- `id` as a `pseudo_epimorphism`. -/
protected def id : PseudoEpimorphism α α :=
  ⟨OrderHom.id, fun a b h => ⟨b, h, rfl⟩⟩
#align pseudo_epimorphism.id PseudoEpimorphism.id

instance : Inhabited (PseudoEpimorphism α α) :=
  ⟨PseudoEpimorphism.id α⟩

@[simp]
theorem coe_id : ⇑(PseudoEpimorphism.id α) = id :=
  rfl
#align pseudo_epimorphism.coe_id PseudoEpimorphism.coe_id

@[simp]
theorem coe_id_orderHom : (PseudoEpimorphism.id α : α →o α) = OrderHom.id :=
  rfl
#align pseudo_epimorphism.coe_id_order_hom PseudoEpimorphism.coe_id_orderHom

variable {α}

@[simp]
theorem id_apply (a : α) : PseudoEpimorphism.id α a = a :=
  rfl
#align pseudo_epimorphism.id_apply PseudoEpimorphism.id_apply

/-- Composition of `pseudo_epimorphism`s as a `pseudo_epimorphism`. -/
def comp (g : PseudoEpimorphism β γ) (f : PseudoEpimorphism α β) : PseudoEpimorphism α γ :=
  ⟨g.toOrderHom.comp f.toOrderHom, fun a b h₀ =>
    by
    obtain ⟨b, h₁, rfl⟩ := g.exists_map_eq_of_map_le' h₀
    obtain ⟨b, h₂, rfl⟩ := f.exists_map_eq_of_map_le' h₁
    exact ⟨b, h₂, rfl⟩⟩
#align pseudo_epimorphism.comp PseudoEpimorphism.comp

@[simp]
theorem coe_comp (g : PseudoEpimorphism β γ) (f : PseudoEpimorphism α β) :
    (g.comp f : α → γ) = g ∘ f :=
  rfl
#align pseudo_epimorphism.coe_comp PseudoEpimorphism.coe_comp

@[simp]
theorem coe_comp_orderHom (g : PseudoEpimorphism β γ) (f : PseudoEpimorphism α β) :
    (g.comp f : α →o γ) = (g : β →o γ).comp f :=
  rfl
#align pseudo_epimorphism.coe_comp_order_hom PseudoEpimorphism.coe_comp_orderHom

@[simp]
theorem comp_apply (g : PseudoEpimorphism β γ) (f : PseudoEpimorphism α β) (a : α) :
    (g.comp f) a = g (f a) :=
  rfl
#align pseudo_epimorphism.comp_apply PseudoEpimorphism.comp_apply

@[simp]
theorem comp_assoc (h : PseudoEpimorphism γ δ) (g : PseudoEpimorphism β γ)
    (f : PseudoEpimorphism α β) : (h.comp g).comp f = h.comp (g.comp f) :=
  rfl
#align pseudo_epimorphism.comp_assoc PseudoEpimorphism.comp_assoc

@[simp]
theorem comp_id (f : PseudoEpimorphism α β) : f.comp (PseudoEpimorphism.id α) = f :=
  ext fun a => rfl
#align pseudo_epimorphism.comp_id PseudoEpimorphism.comp_id

@[simp]
theorem id_comp (f : PseudoEpimorphism α β) : (PseudoEpimorphism.id β).comp f = f :=
  ext fun a => rfl
#align pseudo_epimorphism.id_comp PseudoEpimorphism.id_comp

theorem cancel_right {g₁ g₂ : PseudoEpimorphism β γ} {f : PseudoEpimorphism α β}
    (hf : Surjective f) : g₁.comp f = g₂.comp f ↔ g₁ = g₂ :=
  ⟨fun h => ext <| hf.forall.2 <| FunLike.ext_iff.1 h, congr_arg _⟩
#align pseudo_epimorphism.cancel_right PseudoEpimorphism.cancel_right

theorem cancel_left {g : PseudoEpimorphism β γ} {f₁ f₂ : PseudoEpimorphism α β} (hg : Injective g) :
    g.comp f₁ = g.comp f₂ ↔ f₁ = f₂ :=
  ⟨fun h => ext fun a => hg <| by rw [← comp_apply, h, comp_apply], congr_arg _⟩
#align pseudo_epimorphism.cancel_left PseudoEpimorphism.cancel_left

end PseudoEpimorphism

/-! ### Esakia morphisms -/

namespace EsakiaHom

variable [TopologicalSpace α] [Preorder α] [TopologicalSpace β] [Preorder β] [TopologicalSpace γ]
  [Preorder γ] [TopologicalSpace δ] [Preorder δ]

/-- Reinterpret an `esakia_hom` as a `pseudo_epimorphism`. -/
def toPseudoEpimorphism (f : EsakiaHom α β) : PseudoEpimorphism α β :=
  { f with }
#align esakia_hom.to_pseudo_epimorphism EsakiaHom.toPseudoEpimorphism

instance : EsakiaHomClass (EsakiaHom α β) α β
    where
  coe f := f.toFun
  coe_injective' f g h := by
    obtain ⟨⟨⟨_, _⟩, _⟩, _⟩ := f
    obtain ⟨⟨⟨_, _⟩, _⟩, _⟩ := g
    congr
  map_rel f := f.monotone'
  map_continuous f := f.continuous_toFun
  exists_map_eq_of_map_le f := f.exists_map_eq_of_map_le'

/-- Helper instance for when there's too many metavariables to apply `fun_like.has_coe_to_fun`
directly. -/
instance : CoeFun (EsakiaHom α β) fun _ => α → β :=
  FunLike.hasCoeToFun

@[simp]
theorem toFun_eq_coe {f : EsakiaHom α β} : f.toFun = (f : α → β) :=
  rfl
#align esakia_hom.to_fun_eq_coe EsakiaHom.toFun_eq_coe

@[ext]
theorem ext {f g : EsakiaHom α β} (h : ∀ a, f a = g a) : f = g :=
  FunLike.ext f g h
#align esakia_hom.ext EsakiaHom.ext

/-- Copy of an `esakia_hom` with a new `to_fun` equal to the old one. Useful to fix definitional
equalities. -/
protected def copy (f : EsakiaHom α β) (f' : α → β) (h : f' = f) : EsakiaHom α β :=
  ⟨f.toContinuousOrderHom.copy f' h, by
    simpa only [h.symm, to_fun_eq_coe] using f.exists_map_eq_of_map_le'⟩
#align esakia_hom.copy EsakiaHom.copy

@[simp]
theorem coe_copy (f : EsakiaHom α β) (f' : α → β) (h : f' = f) : ⇑(f.copy f' h) = f' :=
  rfl
#align esakia_hom.coe_copy EsakiaHom.coe_copy

theorem copy_eq (f : EsakiaHom α β) (f' : α → β) (h : f' = f) : f.copy f' h = f :=
  FunLike.ext' h
#align esakia_hom.copy_eq EsakiaHom.copy_eq

variable (α)

/-- `id` as an `esakia_hom`. -/
protected def id : EsakiaHom α α :=
  ⟨ContinuousOrderHom.id α, fun a b h => ⟨b, h, rfl⟩⟩
#align esakia_hom.id EsakiaHom.id

instance : Inhabited (EsakiaHom α α) :=
  ⟨EsakiaHom.id α⟩

@[simp]
theorem coe_id : ⇑(EsakiaHom.id α) = id :=
  rfl
#align esakia_hom.coe_id EsakiaHom.coe_id

@[simp]
theorem coe_id_continuousOrderHom : (EsakiaHom.id α : α →Co α) = ContinuousOrderHom.id α :=
  rfl
#align esakia_hom.coe_id_continuous_order_hom EsakiaHom.coe_id_continuousOrderHom

@[simp]
theorem coe_id_pseudoEpimorphism :
    (EsakiaHom.id α : PseudoEpimorphism α α) = PseudoEpimorphism.id α :=
  rfl
#align esakia_hom.coe_id_pseudo_epimorphism EsakiaHom.coe_id_pseudoEpimorphism

variable {α}

@[simp]
theorem id_apply (a : α) : EsakiaHom.id α a = a :=
  rfl
#align esakia_hom.id_apply EsakiaHom.id_apply

/-- Composition of `esakia_hom`s as an `esakia_hom`. -/
def comp (g : EsakiaHom β γ) (f : EsakiaHom α β) : EsakiaHom α γ :=
  ⟨g.toContinuousOrderHom.comp f.toContinuousOrderHom, fun a b h₀ =>
    by
    obtain ⟨b, h₁, rfl⟩ := g.exists_map_eq_of_map_le' h₀
    obtain ⟨b, h₂, rfl⟩ := f.exists_map_eq_of_map_le' h₁
    exact ⟨b, h₂, rfl⟩⟩
#align esakia_hom.comp EsakiaHom.comp

@[simp]
theorem coe_comp (g : EsakiaHom β γ) (f : EsakiaHom α β) : (g.comp f : α → γ) = g ∘ f :=
  rfl
#align esakia_hom.coe_comp EsakiaHom.coe_comp

@[simp]
theorem comp_apply (g : EsakiaHom β γ) (f : EsakiaHom α β) (a : α) : (g.comp f) a = g (f a) :=
  rfl
#align esakia_hom.comp_apply EsakiaHom.comp_apply

@[simp]
theorem coe_comp_continuousOrderHom (g : EsakiaHom β γ) (f : EsakiaHom α β) :
    (g.comp f : α →Co γ) = (g : β →Co γ).comp f :=
  rfl
#align esakia_hom.coe_comp_continuous_order_hom EsakiaHom.coe_comp_continuousOrderHom

@[simp]
theorem coe_comp_pseudoEpimorphism (g : EsakiaHom β γ) (f : EsakiaHom α β) :
    (g.comp f : PseudoEpimorphism α γ) = (g : PseudoEpimorphism β γ).comp f :=
  rfl
#align esakia_hom.coe_comp_pseudo_epimorphism EsakiaHom.coe_comp_pseudoEpimorphism

@[simp]
theorem comp_assoc (h : EsakiaHom γ δ) (g : EsakiaHom β γ) (f : EsakiaHom α β) :
    (h.comp g).comp f = h.comp (g.comp f) :=
  rfl
#align esakia_hom.comp_assoc EsakiaHom.comp_assoc

@[simp]
theorem comp_id (f : EsakiaHom α β) : f.comp (EsakiaHom.id α) = f :=
  ext fun a => rfl
#align esakia_hom.comp_id EsakiaHom.comp_id

@[simp]
theorem id_comp (f : EsakiaHom α β) : (EsakiaHom.id β).comp f = f :=
  ext fun a => rfl
#align esakia_hom.id_comp EsakiaHom.id_comp

theorem cancel_right {g₁ g₂ : EsakiaHom β γ} {f : EsakiaHom α β} (hf : Surjective f) :
    g₁.comp f = g₂.comp f ↔ g₁ = g₂ :=
  ⟨fun h => ext <| hf.forall.2 <| FunLike.ext_iff.1 h, congr_arg _⟩
#align esakia_hom.cancel_right EsakiaHom.cancel_right

theorem cancel_left {g : EsakiaHom β γ} {f₁ f₂ : EsakiaHom α β} (hg : Injective g) :
    g.comp f₁ = g.comp f₂ ↔ f₁ = f₂ :=
  ⟨fun h => ext fun a => hg <| by rw [← comp_apply, h, comp_apply], congr_arg _⟩
#align esakia_hom.cancel_left EsakiaHom.cancel_left

end EsakiaHom


import fol.language

open language

universe u

structure Structure (S : Signature) :=
(dom : Type u)
(const : Const S → dom)
(func : Func S → dom → dom)
(op : Op S → dom → dom → dom)
(rel : Rel S → dom → dom → Prop)

instance {S : Signature} : has_coe_to_sort (Structure S) (Type u) := ⟨Structure.dom⟩

variables {S : Signature}

structure assignment (A : Structure S) :=
(ass : var → A)

section assignment

variable {A : Structure S}

def subs_assignment (β : assignment A) (a : A) (x : var) : assignment A :=
⟨λ v, ite (v = x) a (β.ass v)⟩

notation _[_ / _] := subs_assignment

def interp (β : assignment A) : Term S → A :=
λ t,
begin
  induction t with v c f t a o t₁ t₂ a₁ a₂,
  exact β.ass v,
  exact A.const c,
  exact A.func f a,
  exact A.op o a₁ a₂
end

instance : has_coe_to_fun (assignment A) (λ _, Term S → A) :=
⟨λ β, interp β⟩

def eval : ∀ (β : assignment A) (φ : Formula S), Prop
| β (Formula.Eq t₁ t₂) := β t₁ = β t₂
| β (Formula.RelF R t₁ t₂) := A.rel R (β t₁) (β t₂)
| β (Formula.Not φ) := ¬eval β φ
| β (Formula.OpL LogicalOp.To φ₁ φ₂) := (eval β φ₁) → (eval β φ₂)
| β (Formula.QuantifierL Quantifier.All v φ) := ∀ (a : A), eval (subs_assignment β a v) φ

end assignment

namespace semantics

variable {A : Structure S}

section interp

lemma interp_var {β : assignment A} {v : var} : β v = β.ass v := rfl

lemma interp_const {β : assignment A} {c : Const S} : β c = A.const c := rfl

lemma interp_func {β : assignment A} {f : Func S} {t : Term S} :
interp β (f t) = A.func f (β t) := rfl

lemma interp_op {β : assignment A} {o : Op S} {t₁ t₂ : Term S} :
interp β (o t₁ t₂) = A.op o (β t₁) (β t₂) := rfl

end interp

section eval

lemma eval_eq {β : assignment A} {t₁ t₂ : Term S}

end eval

end semantics


/-
Copyright (c) 2019 Reid Barton. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Reid Barton, Johan Commelin
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.category_theory.adjunction.basic
import Mathlib.category_theory.limits.creates
import Mathlib.PostPort

universes u₁ u₂ v

namespace Mathlib

namespace category_theory.adjunction

/--
The right adjoint of `cocones.functoriality K F : cocone K ⥤ cocone (K ⋙ F)`.

Auxiliary definition for `functoriality_is_left_adjoint`.
-/
def functoriality_right_adjoint {C : Type u₁} [category C] {D : Type u₂} [category D] {F : C ⥤ D}
    {G : D ⥤ C} (adj : F ⊣ G) {J : Type v} [small_category J] (K : J ⥤ C) :
    limits.cocone (K ⋙ F) ⥤ limits.cocone K :=
  limits.cocones.functoriality (K ⋙ F) G ⋙
    limits.cocones.precompose
      (iso.inv (functor.right_unitor K) ≫
        whisker_left K (unit adj) ≫ iso.inv (functor.associator K F G))

/--
The unit for the adjunction for `cocones.functoriality K F : cocone K ⥤ cocone (K ⋙ F)`.

Auxiliary definition for `functoriality_is_left_adjoint`.
-/
def functoriality_unit {C : Type u₁} [category C] {D : Type u₂} [category D] {F : C ⥤ D} {G : D ⥤ C}
    (adj : F ⊣ G) {J : Type v} [small_category J] (K : J ⥤ C) :
    𝟭 ⟶ limits.cocones.functoriality K F ⋙ functoriality_right_adjoint adj K :=
  nat_trans.mk
    fun (c : limits.cocone K) =>
      limits.cocone_morphism.mk (nat_trans.app (unit adj) (limits.cocone.X c))

/--
The counit for the adjunction for `cocones.functoriality K F : cocone K ⥤ cocone (K ⋙ F)`.

Auxiliary definition for `functoriality_is_left_adjoint`.
-/
def functoriality_counit {C : Type u₁} [category C] {D : Type u₂} [category D] {F : C ⥤ D}
    {G : D ⥤ C} (adj : F ⊣ G) {J : Type v} [small_category J] (K : J ⥤ C) :
    functoriality_right_adjoint adj K ⋙ limits.cocones.functoriality K F ⟶ 𝟭 :=
  nat_trans.mk
    fun (c : limits.cocone (K ⋙ F)) =>
      limits.cocone_morphism.mk (nat_trans.app (counit adj) (limits.cocone.X c))

/-- The functor `cocones.functoriality K F : cocone K ⥤ cocone (K ⋙ F)` is a left adjoint. -/
def functoriality_is_left_adjoint {C : Type u₁} [category C] {D : Type u₂} [category D] {F : C ⥤ D}
    {G : D ⥤ C} (adj : F ⊣ G) {J : Type v} [small_category J] (K : J ⥤ C) :
    is_left_adjoint (limits.cocones.functoriality K F) :=
  is_left_adjoint.mk (functoriality_right_adjoint adj K)
    (mk_of_unit_counit
      (core_unit_counit.mk (functoriality_unit adj K) (functoriality_counit adj K)))

/--
A left adjoint preserves colimits.

See https://stacks.math.columbia.edu/tag/0038.
-/
def left_adjoint_preserves_colimits {C : Type u₁} [category C] {D : Type u₂} [category D]
    {F : C ⥤ D} {G : D ⥤ C} (adj : F ⊣ G) : limits.preserves_colimits F :=
  limits.preserves_colimits.mk
    fun (J : Type v) (𝒥 : small_category J) =>
      limits.preserves_colimits_of_shape.mk
        fun (F_1 : J ⥤ C) =>
          limits.preserves_colimit.mk
            fun (c : limits.cocone F_1) (hc : limits.is_colimit c) =>
              iso.inv limits.is_colimit.iso_unique_cocone_morphism
                fun (s : limits.cocone (F_1 ⋙ F)) =>
                  equiv.unique (hom_equiv is_left_adjoint.adj c s)

protected instance is_equivalence_preserves_colimits {C : Type u₁} [category C] {D : Type u₂}
    [category D] (E : C ⥤ D) [is_equivalence E] : limits.preserves_colimits E :=
  left_adjoint_preserves_colimits (functor.adjunction E)

protected instance is_equivalence_reflects_colimits {C : Type u₁} [category C] {D : Type u₂}
    [category D] (E : D ⥤ C) [is_equivalence E] : limits.reflects_colimits E :=
  limits.reflects_colimits.mk
    fun (J : Type v) (𝒥 : small_category J) =>
      limits.reflects_colimits_of_shape.mk
        fun (K : J ⥤ D) =>
          limits.reflects_colimit.mk
            fun (c : limits.cocone K) (t : limits.is_colimit (functor.map_cocone E c)) =>
              limits.is_colimit.of_iso_colimit
                (coe_fn
                  (equiv.symm
                    (limits.is_colimit.precompose_inv_equiv (functor.right_unitor K)
                      (functor.map_cocone 𝟭 c)))
                  (limits.is_colimit.map_cocone_equiv (functor.fun_inv_id E)
                    (limits.is_colimit_of_preserves (functor.inv E) t)))
                (limits.cocones.ext sorry sorry)

protected instance is_equivalence_creates_colimits {C : Type u₁} [category C] {D : Type u₂}
    [category D] (H : D ⥤ C) [is_equivalence H] : creates_colimits H :=
  creates_colimits.mk
    fun (J : Type v) (𝒥 : small_category J) =>
      creates_colimits_of_shape.mk
        fun (F : J ⥤ D) =>
          creates_colimit.mk
            fun (c : limits.cocone (F ⋙ H)) (t : limits.is_colimit c) =>
              liftable_cocone.mk (functor.map_cocone_inv H c)
                (functor.map_cocone_map_cocone_inv H c)

-- verify the preserve_colimits instance works as expected:

protected instance has_colimit_comp_equivalence {C : Type u₁} [category C] {D : Type u₂}
    [category D] {J : Type v} [small_category J] (K : J ⥤ C) (E : C ⥤ D) [is_equivalence E]
    [limits.has_colimit K] : limits.has_colimit (K ⋙ E) :=
  limits.has_colimit.mk
    (limits.colimit_cocone.mk (functor.map_cocone E (limits.colimit.cocone K))
      (limits.preserves_colimit.preserves (limits.colimit.is_colimit K)))

theorem has_colimit_of_comp_equivalence {C : Type u₁} [category C] {D : Type u₂} [category D]
    {J : Type v} [small_category J] (K : J ⥤ C) (E : C ⥤ D) [is_equivalence E]
    [limits.has_colimit (K ⋙ E)] : limits.has_colimit K :=
  limits.has_colimit_of_iso
    (iso.symm (functor.right_unitor K) ≪≫ iso.symm (iso_whisker_left K (functor.fun_inv_id E)))

/--
The left adjoint of `cones.functoriality K G : cone K ⥤ cone (K ⋙ G)`.

Auxiliary definition for `functoriality_is_right_adjoint`.
-/
def functoriality_left_adjoint {C : Type u₁} [category C] {D : Type u₂} [category D] {F : C ⥤ D}
    {G : D ⥤ C} (adj : F ⊣ G) {J : Type v} [small_category J] (K : J ⥤ D) :
    limits.cone (K ⋙ G) ⥤ limits.cone K :=
  limits.cones.functoriality (K ⋙ G) F ⋙
    limits.cones.postcompose
      (iso.hom (functor.associator K G F) ≫
        whisker_left K (counit adj) ≫ iso.hom (functor.right_unitor K))

/--
The unit for the adjunction for`cones.functoriality K G : cone K ⥤ cone (K ⋙ G)`.

Auxiliary definition for `functoriality_is_right_adjoint`.
-/
@[simp] theorem functoriality_unit'_app_hom {C : Type u₁} [category C] {D : Type u₂} [category D]
    {F : C ⥤ D} {G : D ⥤ C} (adj : F ⊣ G) {J : Type v} [small_category J] (K : J ⥤ D)
    (c : limits.cone (K ⋙ G)) :
    limits.cone_morphism.hom (nat_trans.app (functoriality_unit' adj K) c) =
        nat_trans.app (unit adj) (limits.cone.X c) :=
  Eq.refl (limits.cone_morphism.hom (nat_trans.app (functoriality_unit' adj K) c))

/--
The counit for the adjunction for`cones.functoriality K G : cone K ⥤ cone (K ⋙ G)`.

Auxiliary definition for `functoriality_is_right_adjoint`.
-/
@[simp] theorem functoriality_counit'_app_hom {C : Type u₁} [category C] {D : Type u₂} [category D]
    {F : C ⥤ D} {G : D ⥤ C} (adj : F ⊣ G) {J : Type v} [small_category J] (K : J ⥤ D)
    (c : limits.cone K) :
    limits.cone_morphism.hom (nat_trans.app (functoriality_counit' adj K) c) =
        nat_trans.app (counit adj) (limits.cone.X c) :=
  Eq.refl (limits.cone_morphism.hom (nat_trans.app (functoriality_counit' adj K) c))

/-- The functor `cones.functoriality K G : cone K ⥤ cone (K ⋙ G)` is a right adjoint. -/
def functoriality_is_right_adjoint {C : Type u₁} [category C] {D : Type u₂} [category D] {F : C ⥤ D}
    {G : D ⥤ C} (adj : F ⊣ G) {J : Type v} [small_category J] (K : J ⥤ D) :
    is_right_adjoint (limits.cones.functoriality K G) :=
  is_right_adjoint.mk (functoriality_left_adjoint adj K)
    (mk_of_unit_counit
      (core_unit_counit.mk (functoriality_unit' adj K) (functoriality_counit' adj K)))

/--
A right adjoint preserves limits.

See https://stacks.math.columbia.edu/tag/0038.
-/
def right_adjoint_preserves_limits {C : Type u₁} [category C] {D : Type u₂} [category D] {F : C ⥤ D}
    {G : D ⥤ C} (adj : F ⊣ G) : limits.preserves_limits G :=
  limits.preserves_limits.mk
    fun (J : Type v) (𝒥 : small_category J) =>
      limits.preserves_limits_of_shape.mk
        fun (K : J ⥤ D) =>
          limits.preserves_limit.mk
            fun (c : limits.cone K) (hc : limits.is_limit c) =>
              iso.inv limits.is_limit.iso_unique_cone_morphism
                fun (s : limits.cone (K ⋙ G)) =>
                  equiv.unique (equiv.symm (hom_equiv is_right_adjoint.adj s c))

protected instance is_equivalence_preserves_limits {C : Type u₁} [category C] {D : Type u₂}
    [category D] (E : D ⥤ C) [is_equivalence E] : limits.preserves_limits E :=
  right_adjoint_preserves_limits (functor.adjunction (functor.inv E))

protected instance is_equivalence_reflects_limits {C : Type u₁} [category C] {D : Type u₂}
    [category D] (E : D ⥤ C) [is_equivalence E] : limits.reflects_limits E :=
  limits.reflects_limits.mk
    fun (J : Type v) (𝒥 : small_category J) =>
      limits.reflects_limits_of_shape.mk
        fun (K : J ⥤ D) =>
          limits.reflects_limit.mk
            fun (c : limits.cone K) (t : limits.is_limit (functor.map_cone E c)) =>
              limits.is_limit.of_iso_limit
                (coe_fn
                  (equiv.symm
                    (limits.is_limit.postcompose_hom_equiv (functor.left_unitor K)
                      (functor.map_cone 𝟭 c)))
                  (limits.is_limit.map_cone_equiv (functor.fun_inv_id E)
                    (limits.is_limit_of_preserves (functor.inv E) t)))
                (limits.cones.ext sorry sorry)

protected instance is_equivalence_creates_limits {C : Type u₁} [category C] {D : Type u₂}
    [category D] (H : D ⥤ C) [is_equivalence H] : creates_limits H :=
  creates_limits.mk
    fun (J : Type v) (𝒥 : small_category J) =>
      creates_limits_of_shape.mk
        fun (F : J ⥤ D) =>
          creates_limit.mk
            fun (c : limits.cone (F ⋙ H)) (t : limits.is_limit c) =>
              liftable_cone.mk (functor.map_cone_inv H c) (functor.map_cone_map_cone_inv H c)

-- verify the preserve_limits instance works as expected:

protected instance has_limit_comp_equivalence {C : Type u₁} [category C] {D : Type u₂} [category D]
    {J : Type v} [small_category J] (K : J ⥤ D) (E : D ⥤ C) [is_equivalence E]
    [limits.has_limit K] : limits.has_limit (K ⋙ E) :=
  limits.has_limit.mk
    (limits.limit_cone.mk (functor.map_cone E (limits.limit.cone K))
      (limits.preserves_limit.preserves (limits.limit.is_limit K)))

theorem has_limit_of_comp_equivalence {C : Type u₁} [category C] {D : Type u₂} [category D]
    {J : Type v} [small_category J] (K : J ⥤ D) (E : D ⥤ C) [is_equivalence E]
    [limits.has_limit (K ⋙ E)] : limits.has_limit K :=
  limits.has_limit_of_iso (iso_whisker_left K (functor.fun_inv_id E) ≪≫ functor.right_unitor K)

/-- auxiliary construction for `cocones_iso` -/
@[simp] theorem cocones_iso_component_hom_app {C : Type u₁} [category C] {D : Type u₂} [category D]
    {F : C ⥤ D} {G : D ⥤ C} (adj : F ⊣ G) {J : Type v} [small_category J] {K : J ⥤ C} (Y : D)
    (t : functor.obj (functor.obj (cocones J D) (opposite.op (K ⋙ F))) Y) (j : J) :
    nat_trans.app (cocones_iso_component_hom adj Y t) j =
        coe_fn (hom_equiv adj (functor.obj K j) Y) (nat_trans.app t j) :=
  Eq.refl (nat_trans.app (cocones_iso_component_hom adj Y t) j)

/-- auxiliary construction for `cocones_iso` -/
def cocones_iso_component_inv {C : Type u₁} [category C] {D : Type u₂} [category D] {F : C ⥤ D}
    {G : D ⥤ C} (adj : F ⊣ G) {J : Type v} [small_category J] {K : J ⥤ C} (Y : D)
    (t : functor.obj (G ⋙ functor.obj (cocones J C) (opposite.op K)) Y) :
    functor.obj (functor.obj (cocones J D) (opposite.op (K ⋙ F))) Y :=
  nat_trans.mk
    fun (j : J) => coe_fn (equiv.symm (hom_equiv adj (functor.obj K j) Y)) (nat_trans.app t j)

/--
When `F ⊣ G`,
the functor associating to each `Y` the cocones over `K ⋙ F` with cone point `Y`
is naturally isomorphic to
the functor associating to each `Y` the cocones over `K` with cone point `G.obj Y`.
-/
-- Note: this is natural in K, but we do not yet have the tools to formulate that.

def cocones_iso {C : Type u₁} [category C] {D : Type u₂} [category D] {F : C ⥤ D} {G : D ⥤ C}
    (adj : F ⊣ G) {J : Type v} [small_category J] {K : J ⥤ C} :
    functor.obj (cocones J D) (opposite.op (K ⋙ F)) ≅
        G ⋙ functor.obj (cocones J C) (opposite.op K) :=
  nat_iso.of_components
    (fun (Y : D) => iso.mk (cocones_iso_component_hom adj Y) (cocones_iso_component_inv adj Y))
    sorry

/-- auxiliary construction for `cones_iso` -/
@[simp] theorem cones_iso_component_hom_app {C : Type u₁} [category C] {D : Type u₂} [category D]
    {F : C ⥤ D} {G : D ⥤ C} (adj : F ⊣ G) {J : Type v} [small_category J] {K : J ⥤ D} (X : Cᵒᵖ)
    (t : functor.obj (functor.op F ⋙ functor.obj (cones J D) K) X) (j : J) :
    nat_trans.app (cones_iso_component_hom adj X t) j =
        coe_fn (hom_equiv adj (opposite.unop X) (functor.obj K j)) (nat_trans.app t j) :=
  Eq.refl (nat_trans.app (cones_iso_component_hom adj X t) j)

/-- auxiliary construction for `cones_iso` -/
@[simp] theorem cones_iso_component_inv_app {C : Type u₁} [category C] {D : Type u₂} [category D]
    {F : C ⥤ D} {G : D ⥤ C} (adj : F ⊣ G) {J : Type v} [small_category J] {K : J ⥤ D} (X : Cᵒᵖ)
    (t : functor.obj (functor.obj (cones J C) (K ⋙ G)) X) (j : J) :
    nat_trans.app (cones_iso_component_inv adj X t) j =
        coe_fn (equiv.symm (hom_equiv adj (opposite.unop X) (functor.obj K j)))
          (nat_trans.app t j) :=
  Eq.refl (nat_trans.app (cones_iso_component_inv adj X t) j)

-- Note: this is natural in K, but we do not yet have the tools to formulate that.

/--
When `F ⊣ G`,
the functor associating to each `X` the cones over `K` with cone point `F.op.obj X`
is naturally isomorphic to
the functor associating to each `X` the cones over `K ⋙ G` with cone point `X`.
-/
def cones_iso {C : Type u₁} [category C] {D : Type u₂} [category D] {F : C ⥤ D} {G : D ⥤ C}
    (adj : F ⊣ G) {J : Type v} [small_category J] {K : J ⥤ D} :
    functor.op F ⋙ functor.obj (cones J D) K ≅ functor.obj (cones J C) (K ⋙ G) :=
  nat_iso.of_components
    (fun (X : Cᵒᵖ) => iso.mk (cones_iso_component_hom adj X) (cones_iso_component_inv adj X)) sorry

end Mathlib


import data.list.chain data.int.basic tactic data.list.basic

variables {ι : Type*} {G : ι → Type*} [Π i, monoid (G i)]

open list

def reduced (l : list (Σ i, G i)) : Prop :=
l.chain' (λ a b, a.1 ≠ b.1) ∧ ∀ a : Σ i, G i, a ∈ l → a.2 ≠ 1

@[simp] lemma reduced_nil : reduced ([] : list (Σ i, G i)) :=
⟨list.chain'_nil, λ _, false.elim⟩

lemma reduced_of_reduced_cons {i : Σ i, G i} {l : list (Σ i, G i)}
  (h : reduced (i :: l)) : reduced l :=
⟨(list.chain'_cons'.1 h.1).2, λ b hb, h.2 _ (mem_cons_of_mem _ hb)⟩

lemma reduced_cons_of_reduced_cons {i : ι} {a b : G i} {l : list (Σ i, G i)}
  (h : reduced (⟨i, a⟩ :: l)) (hb : b ≠ 1) : reduced (⟨i, b⟩ :: l) :=
⟨chain'_cons'.2 (chain'_cons'.1 h.1),
  begin
    rintros ⟨k, c⟩ hk,
    cases (mem_cons_iff _ _ _).1 hk with hk hk,
    { simp only at hk,
      rcases hk with ⟨rfl, h⟩,
      simp * at * },
    { exact h.2 _ (mem_cons_of_mem _ hk) }
  end⟩

lemma reduced_cons_cons {i j : ι} {a : G i} {b : G j}
  {l : list (Σ i, G i)} (hij : i ≠ j) (ha : a ≠ 1)
  (hbl : reduced (⟨j, b⟩ :: l)) : reduced (⟨i, a⟩ :: ⟨j, b⟩ :: l) :=
⟨chain'_cons.2 ⟨hij, hbl.1⟩,
  begin
    rintros ⟨k, c⟩ hk,
    cases (mem_cons_iff _ _ _).1 hk with hk hk,
    { simp only at hk,
      rcases hk with ⟨rfl, h⟩,
      simp * at * },
    { exact hbl.2 _ hk }
  end⟩

lemma reduced_reverse {l : list (Σ i, G i)} (h : reduced l) : reduced l.reverse :=
⟨chain'_reverse.2 $ by {convert h.1, simp [function.funext_iff, eq_comm] },
  by simpa using h.2⟩

@[simp] lemma reduced_reverse_iff {l : list (Σ i, G i)} : reduced l.reverse ↔ reduced l :=
⟨λ h, by convert reduced_reverse h; simp, reduced_reverse⟩

variable (G)
def coprod : Type* := {l : list (Σ i, G i) // reduced l}

namespace coprod

instance : has_one (coprod G) := ⟨⟨[], trivial, by simp⟩⟩

variables {ι} [decidable_eq ι] {G} [Π i, decidable_eq (G i)]

def rcons : (Σ i, G i) → list (Σ i, G i) → list (Σ i, G i)
| i []     := [i]
| i (j::l) :=
  if hij : i.1 = j.1
    then let c := i.2 * cast (congr_arg G hij).symm j.2 in
      if c = 1
        then l
        else ⟨i.1, c⟩ :: l
    else i::j::l

-- def rconcat (a : Σ i, G i) (l : list (Σ i, G i)) : list (Σ i, G i) :=
-- (rcons a l.reverse).reverse

def reduce : list (Σ i, G i) → list (Σ i, G i)
| []       := []
| (i :: l) := if h : i.2 = 1 then reduce l else rcons i (reduce l)

lemma reduced_rcons : ∀ {i : Σ i, G i} {l : list (Σ i, G i)},
  i.2 ≠ 1 → reduced l → reduced (rcons i l)
| ⟨i, a⟩ []            hi h := ⟨list.chain'_singleton _,
  begin
    rintros ⟨j, b⟩ hj,
    simp only [rcons, list.mem_singleton] at hj,
    rcases hj with ⟨rfl, h⟩,
    simp * at *
  end⟩
| ⟨i, a⟩ (⟨j, b⟩ :: l) hi h := begin
  simp [rcons],
  split_ifs,
  { exact reduced_of_reduced_cons h },
  { dsimp only at h_1,
    subst h_1,
    exact reduced_cons_of_reduced_cons h h_2 },
  { exact reduced_cons_cons h_1 hi h }
end

-- lemma reduced_rconcat  {a : Σ i, G i} {l : list (Σ i, G i)}
--   (ha : a.2 ≠ 0) (hl : reduced l) : reduced (rconcat a l) :=
-- begin
--   rw [rconcat, reduced_reverse_iff],
--   exact reduced_rcons ha (reduced_reverse hl)
-- end

lemma reduced_reduce : ∀ l : list (Σ i, G i), reduced (reduce l)
| []     := reduced_nil
| (a::l) := begin
  rw reduce,
  split_ifs,
  { exact reduced_reduce l },
  { exact reduced_rcons h (reduced_reduce l) }
end

lemma rcons_eq_cons : ∀ {i : Σ i, G i} {l : list (Σ i, G i)},
  reduced (i :: l) → rcons i l = i :: l
| i []     h := rfl
| i (j::l) h := dif_neg (chain'_cons.1 h.1).1

-- lemma rconcat_eq_concat  {a : Σ i, G i} {l : list (Σ i, G i)}
--   (h : reduced (l ++ [a])) : rconcat a l = l ++ [a] :=
-- begin
--   rw [rconcat, rcons_eq_cons], simp,
--   convert reduced_reverse h, simp,
-- end

lemma rcons_reduce_eq_reduce_cons : ∀ {i : Σ i, G i} {l : list (Σ i, G i)},
  i.2 ≠ 1 → rcons i (reduce l) = reduce (i :: l)
| a []     ha := by simp [rcons, reduce, ha]
| a (b::l) ha := begin
  rw [reduce],
  split_ifs,
  { rw [reduce, if_neg ha, reduce, if_pos h] },
  { rw [reduce, if_neg ha, reduce, if_neg h] }
end

-- inductive rel : list (Σ i, G i) → list (Σ i, G i) → Prop
-- | refl : ∀ l, rel l l
-- | zero : ∀ {a : ι}, rel [(a, 0)] []
-- | add : ∀ {a i j}, rel [(a, i), (a, j)] [(a, i + j)]
-- | append : ∀ {l₁ l₂ l₃ l₄}, rel l₁ l₂ → rel l₃ l₄ → rel (l₁ ++ l₃) (l₂ ++ l₄)
-- | symm : ∀ {l₁ l₂}, rel l₁ l₂ → rel l₂ l₁
-- | trans : ∀ {l₁ l₂ l₃}, rel l₁ l₂ → rel l₂ l₃ → rel l₁ l₃

-- attribute [refl] rel.refl
-- attribute [symm] rel.symm
-- attribute [trans] rel.trans

-- -- @[refl] lemma rel.refl : ∀ l : list (Σ i, G i), rel l l := sorry

-- lemma rel_rcons_cons : ∀ (a : Σ i, G i) (l : list (Σ i, G i)),
--   rel (rcons a l) (a::l)
-- | a [] := rel.refl _
-- | (a, i) ((b,j)::l) := begin
--   rw rcons,
--   split_ifs,
--   { replace h : a = b := h, subst h,
--     show rel ([] ++ l) ([(a,i), (a, j)]  ++ l),
--     refine rel.append _ (rel.refl _),
--     symmetry,
--     exact rel.add.trans (h_1.symm ▸ rel.zero) },
--   { replace h : a = b := h, subst h,
--     show rel ([(a, i + j)] ++ l) ([(a, i), (a, j)] ++ l),
--     exact rel.append rel.add.symm (rel.refl _) },
--   { refl },
-- end

-- lemma rel_cons_of_rel {l₁ l₂ : list (Σ i, G i)} (h : rel l₁ l₂) (a : Σ i, G i) :
--   rel (a :: l₁) (a :: l₂) :=
-- show rel ([a] ++ l₁) ([a] ++ l₂), from rel.append (rel.refl _) h

-- lemma rel_rcons_cons_of_rel {a : Σ i, G i} {l₁ l₂ : list (Σ i, G i)} (h : rel l₁ l₂) :
--   rel (rcons a l₁) (a ::l₂) :=
-- (rel_rcons_cons a l₁).trans (rel_cons_of_rel h _)

-- lemma rel_reduce : ∀ l : list (Σ i, G i), rel l (reduce l)
-- | [] := rel.refl _
-- | ((a, i)::l) := begin
--   rw reduce,
--   split_ifs,
--   { replace h : i = 0 := h, subst h,
--     show rel ([(a, 0)] ++ l) ([] ++ reduce l),
--     exact rel.append rel.zero (rel_reduce _) },
--   { exact (rel_rcons_cons_of_rel (rel_reduce _).symm).symm }
-- end

-- lemma reduce_eq_reduce_of_rel {l₁ l₂ : list (Σ i, G i)} (h : rel l₁ l₂) : reduce l₁ = reduce l₂ :=
-- begin
--   induction h,
--   { refl },
--   { simp [reduce] },
--   { simp only [reduce],
--     split_ifs,
--     { refl },
--     { simp * at * },
--     { exfalso, omega },
--     { simp [rcons, *] },
--     { exfalso, omega },
--     { simp [rcons, *] },
--     { simp [rcons, *] },
--     { simp [rcons, *] } },
--   {  }

-- end

lemma reduce_eq_self_of_reduced : ∀ {l : list (Σ i, G i)}, reduced l → reduce l = l
| []     h := rfl
| (a::l) h := by rw [← rcons_reduce_eq_reduce_cons (h.2 a (mem_cons_self _ _)),
    reduce_eq_self_of_reduced (reduced_of_reduced_cons h), rcons_eq_cons h]

lemma rcons_eq_reduce_cons {i : Σ i, G i} {l : list (Σ i, G i)}
  (ha : i.2 ≠ 1) (hl : reduced l) : rcons i l = reduce (i :: l) :=
by rw [← rcons_reduce_eq_reduce_cons ha, reduce_eq_self_of_reduced hl]

@[simp] lemma reduce_reduce (l : list (Σ i, G i)) : reduce (reduce l) = reduce l :=
reduce_eq_self_of_reduced (reduced_reduce l)

@[simp] lemma reduce_cons_reduce_eq_reduce_cons (i : Σ i, G i) (l : list (Σ i, G i)) :
  reduce (i :: reduce l) = reduce (i :: l)  :=
if ha : i.2 = 1 then by rw [reduce, if_pos ha, reduce, if_pos ha, reduce_reduce]
else by rw [← rcons_reduce_eq_reduce_cons ha, ← rcons_reduce_eq_reduce_cons ha,
    reduce_reduce]

lemma length_rcons_le : ∀ (i : Σ i, G i) (l : list (Σ i, G i)),
  (rcons i l).length ≤ (i::l : list _).length
| i      []          := le_refl _
| ⟨i, a⟩ (⟨j, b⟩::l) := begin
  simp [rcons],
  split_ifs,
  { linarith },
  { simp },
  { simp }
end

lemma length_reduce_le : ∀ (l : list (Σ i, G i)),
  (reduce l).length ≤ l.length
| []        := le_refl _
| [a]       := by { simp [reduce], split_ifs; simp [rcons] }
| (a::b::l) := begin
  simp only [reduce, rcons],
  split_ifs,
  { exact le_trans (length_reduce_le _)
      (le_trans (nat.le_succ _) (nat.le_succ _)) },
  { exact le_trans (length_rcons_le _ _) (nat.succ_le_succ
      (le_trans (length_reduce_le _) (nat.le_succ _))) },
  { exact le_trans (length_rcons_le _ _) (nat.succ_le_succ
      (le_trans (length_reduce_le _) (nat.le_succ _))) },
  { exact le_trans (length_rcons_le _ _) (nat.succ_le_succ
         (le_trans (length_rcons_le _ _) (nat.succ_le_succ
           (length_reduce_le _)))) }
end

lemma length_rcons_lt_or_eq_rcons : ∀ (i : Σ i, G i) (l : list (Σ i, G i)),
  (rcons i l).length < (i :: l : list _).length ∨ rcons i l = (i::l)
| i [] := or.inr rfl
| i (j::l) := begin
  simp only [rcons],
  split_ifs,
  { exact or.inl (nat.lt_succ_of_le (nat.le_succ _)) },
  { exact or.inl (nat.lt_succ_self _) },
  { simp }
end

lemma length_reduce_lt_or_eq_reduce : ∀ (l : list (Σ i, G i)),
  (reduce l).length < l.length ∨ reduce l = l
| []        := or.inr rfl
| (i::l)    := begin
  simp only [reduce],
  split_ifs,
  { exact or.inl (nat.lt_succ_of_le (length_reduce_le _)) },
  { cases length_rcons_lt_or_eq_rcons i (reduce l) with h h,
    { exact or.inl (lt_of_lt_of_le h (nat.succ_le_succ (length_reduce_le _))) },
    { rw h,
      cases length_reduce_lt_or_eq_reduce l with h h,
      { exact or.inl (nat.succ_lt_succ h) },
      { rw h, right, refl } } }
end

lemma rcons_append : ∀ {i j : Σ i, G i} {l₁ l₂ : list (Σ i, G i)},
  rcons i ((j::l₁) ++ l₂) = rcons i (j::l₁) ++ l₂
| i j [] l₂ := begin
  simp [rcons], split_ifs; simp
end
| a b (c::l₁) l₂ := begin
  rw [cons_append, rcons],
  dsimp,
  split_ifs,
  { simp [rcons, *] },
  { simp [rcons, *] },
  { simp [rcons, *] }
end

lemma rcons_rcons_of_add_eq_zero {i : ι} {a b : G i} : ∀ {l : list (Σ i, G i)},
  a * b = 1 → reduced l → rcons ⟨i, a⟩ (rcons ⟨i, b⟩ l) = l
| []          hab hl := by simp [rcons, cast, hab]
| (⟨j, c⟩::l) hab hl := begin
  simp only [rcons],
  split_ifs,
  { dsimp only at h,
    subst h,
    rw [← rcons_eq_cons hl, left_inv_eq_right_inv hab h_1, cast_eq] },
  { dsimp only at h,
    subst h,
    simp only [rcons, dif_pos rfl],
    rw [cast_eq, cast_eq, if_neg, ← mul_assoc, hab, one_mul],
    { rw [← mul_assoc, hab, one_mul],
      exact hl.2 ⟨i, c⟩ (mem_cons_self _ _) } },
  { rw [rcons, dif_pos rfl, cast_eq], dsimp, rw [if_pos hab] }
end

lemma rcons_rcons_of_add_ne_zero {i : ι} {a b : G i} : ∀ {l : list (Σ i, G i)},
  a * b ≠ 1 → a ≠ 1 → reduced l → rcons ⟨i, a⟩ (rcons ⟨i, b⟩ l) = rcons ⟨i, a * b⟩ l
| []          hab ha hl := by simp [rcons, hab, cast_eq]
| [⟨j, c⟩]    hab ha hl := begin
  simp only [rcons],
  split_ifs,
  { rw [mul_assoc, h_1, mul_one] at h_2,
    exact (ha h_2).elim },
  { simp [rcons, mul_assoc, h_1] },
  { simp only [rcons, ← mul_assoc, *, dif_pos rfl, cast_eq, if_pos rfl] },
  { dsimp only at h,
    subst h,
    simp only [rcons, dif_pos rfl, ← mul_assoc, *, cast_eq] at *,
    simp },
  { simp [rcons, if_neg hab, if_pos rfl, cast_eq] }
end
| (⟨j, c⟩::⟨k, d⟩::l) hab ha hl := begin
  have hjk : j ≠ k, from (chain'_cons.1 hl.1).1,
  dsimp only [rcons],
  split_ifs,
  { rw [mul_assoc, h_1, mul_one] at h_2,
    exact (ha h_2).elim },
  { dsimp [rcons],
    subst h,
    simp [*, rcons, mul_assoc] at * },
  { simp [*, rcons, ← mul_assoc, cast_eq] at * },
  { simp [*, rcons, ← mul_assoc, cast_eq] },
  { simp [*, rcons, cast_eq] }
end

lemma reduce_rcons : ∀ {i : Σ i, G i} (l : list (Σ i, G i)), i.2 ≠ 1 →
  reduce (rcons i l) = rcons i (reduce l)
| i []               hi := by simp [rcons, reduce, hi]
| ⟨i, a⟩ [⟨j, b⟩]    ha := begin
    replace ha : a ≠ 1 := ha,
    dsimp only [reduce, rcons],
    by_cases hij : i = j,
    { subst hij,
      split_ifs;
      simp [*, reduce, rcons, cast_eq] at * },
    { simp [hij, reduce, rcons, ha] }
  end
| ⟨i, a⟩ (⟨j, b⟩::l) ha := begin
  dsimp only [rcons],
  split_ifs,
  { subst h,
    rw [cast_eq] at h_1,
    rw [reduce, if_neg, rcons_rcons_of_add_eq_zero h_1 (reduced_reduce _)],
    { refine λ hb : b = 1, _,
      rw [hb, mul_one] at h_1,
      exact ha h_1 } },
  { subst h,
    rw [reduce, if_neg h_1, reduce],
    split_ifs,
    { erw [cast_eq, show b = 1, from h, mul_one] },
    { rw cast_eq at h_1,
      rw [rcons_rcons_of_add_ne_zero h_1 ha (reduced_reduce l), cast_eq], } },
  { rw [rcons_eq_reduce_cons ha (reduced_reduce _), reduce_cons_reduce_eq_reduce_cons] }
end

@[simp] lemma reduce_reduce_append_eq_reduce_append : ∀ (l₁ l₂ : list (Σ i, G i)),
  reduce (reduce l₁ ++ l₂) = reduce (l₁ ++ l₂)
| []         l₂ := rfl
| (a::l₁) l₂ := begin
  simp only [reduce, cons_append],
  split_ifs with ha ha,
  { exact reduce_reduce_append_eq_reduce_append _ _ },
  { rw [← reduce_reduce_append_eq_reduce_append l₁ l₂],
    induction h : reduce l₁,
    { simp [rcons, rcons_eq_reduce_cons ha (reduced_reduce _)] },
    { rw [← rcons_append, reduce_rcons _ ha] } }
end

@[simp] lemma reduce_append_reduce_eq_reduce_append : ∀ (l₁ l₂ : list (Σ i, G i)),
  reduce (l₁ ++ reduce l₂) = reduce (l₁ ++ l₂)
| []      l₂ := by simp
| (a::l₁) l₂ := by rw [cons_append, ← reduce_cons_reduce_eq_reduce_cons,
    reduce_append_reduce_eq_reduce_append,
    reduce_cons_reduce_eq_reduce_cons, cons_append]

/- TODO: Speed up, not the best definition, no need to reduce entire first list. -/
def mul_aux : list (Σ i, G i) → list (Σ i, G i) → list (Σ i, G i)
| []        l₂ := l₂
| (i :: l₁) l₂ := rcons i (mul_aux l₁ l₂)

lemma reduced_mul_aux : ∀ {l₁ l₂ : list (Σ i, G i)}, reduced l₁ →
  reduced l₂ → reduced (mul_aux l₁ l₂)
| []      l₂ _  h  := h
| (i::l₁) l₂ h₁ h₂ := reduced_rcons
  (h₁.2 _ (mem_cons_self _ _))
  (reduced_mul_aux (reduced_of_reduced_cons h₁) h₂)

lemma mul_aux_eq_reduce_append : ∀ {l₁ l₂ : list (Σ i, G i)}, reduced l₁ →
  reduced l₂ → mul_aux l₁ l₂ = reduce (l₁ ++ l₂)
| []      l₂ _  h  := by simp [reduce, mul_aux, reduce_eq_self_of_reduced h]
| (i::l₁) l₂ h₁ h₂ :=
  by rw [mul_aux, mul_aux_eq_reduce_append (reduced_of_reduced_cons h₁) h₂,
    rcons_reduce_eq_reduce_cons (h₁.2 i (mem_cons_self _ _)), cons_append]

lemma mul_aux_assoc {l₁ l₂ l₃ : list (Σ i, G i)}
  (h₁ : reduced l₁) (h₂ : reduced l₂) (h₃ : reduced l₃) :
  mul_aux (mul_aux l₁ l₂) l₃ = mul_aux l₁ (mul_aux l₂ l₃) :=
begin
  rw [mul_aux_eq_reduce_append h₁ h₂, mul_aux_eq_reduce_append h₂ h₃,
    mul_aux_eq_reduce_append (reduced_reduce _) h₃,
    mul_aux_eq_reduce_append h₁ (reduced_reduce _)],
  simp [append_assoc]
end

lemma mul_aux_nil : ∀ {l₁ : list (Σ i, G i)} (h : reduced l₁), mul_aux l₁ [] = l₁
| []     _ := rfl
| (i::l) h :=
  by rw [mul_aux, mul_aux_nil (reduced_of_reduced_cons h), rcons_eq_cons h]

instance : has_mul (coprod G) :=
⟨λ a b : coprod G, ⟨mul_aux a.1 b.1, reduced_mul_aux a.2 b.2⟩⟩

instance : monoid (coprod G) :=
{ mul := (*),
  one := 1,
  mul_assoc := λ a b c, subtype.eq (mul_aux_assoc a.2 b.2 c.2),
  one_mul := λ ⟨_, _⟩, rfl,
  mul_one := λ a, subtype.eq (mul_aux_nil a.2) }

#print cast_eq
-- ff means a cancellation didn't happen
-- tt means a cancellation did happen
def rcons' : (Σ i, G i) → list (Σ i, G i) × bool → list (Σ i, G i) × bool
| i ([], _) := ([i], ff)
| i (j::l, tt) :=
  if hij : i.1 = j.1
    then let c := i.2 * cast (congr_arg G hij).symm j.2 in
      if c = 1
        then (l, tt)
        else (⟨i.1, c⟩ :: l, ff)
    else (i::j::l, ff)
| i (j::l, ff) := (i::j::l, ff)

def mul_aux' (l₁ l₂ : list (Σ i, G i)) : list (Σ i, G i) × bool :=
foldr rcons' (l₂, tt) l₁

def rcons'' : (Σ i, G i) → list (Σ i, G i) → list (Σ i, G i) × bool
| i [] := ([i], ff)
| i (j::l) :=
  if hij : i.1 = j.1
    then let c := i.2 * cast (congr_arg G hij).symm j.2 in
      if c = 1
        then (l, tt)
        else (⟨i.1, c⟩ :: l, ff)
    else (i::j::l, ff)

def list.init_last {α : Type*} : Π (l : list α) (hl : l ≠ []), list α × α
| []        h := (h rfl).elim
| [i]       h := ([], i)
| (i::j::l) h :=
  let ⟨init, lst⟩ := list.init_last (j ::l) (list.cons_ne_nil _ _) in (i::init, lst)
#eval list.init_last [1,2,3,4] sorry
-- `l₁++ [mid]` should always be reduced whenever this is called
-- def mul_aux''_aux : Π (l₁ : list (Σ i, G i)) (mid : Σ i, G i)
--   (l₂ : list (Σ i, G i)), list (Σ i, G i)
-- | l₁      i []      := l₁ ++ [i]
-- | []      i (j::l₂) :=
--   if hij : i.1 = j.1
--     then let c := i.2 * cast (congr_arg G hij).symm j.2 in
--       if c = 1
--         then l₂
--         else ⟨i.1, c⟩::l₂
--     else i::j::l₂
-- | (i::l₁) j (k::l₂) :=
--   if hij : j.1 = k.1
--     then let c := j.2 * cast (congr_arg G hij).symm k.2 in
--       if c = 1
--         then let ⟨init, lst⟩ := list.init_last (i :: l₁) (list.cons_ne_nil _ _) in
--           mul_aux''_aux init lst l₂
--         else l₁ ++ (⟨j.1, c⟩::l₂)
--     else (i::l₁) ++ (j::k::l₂)
-- `hd.reverse ++ l₁` should be reduced should return `hd.reverse * l₁ * l₂
def mul_aux₃ : Π (l₁ : list (Σ i, G i)) (hd : list (Σ i, G i))
  (l₂ : list (Σ i, G i)), list (Σ i, G i)
| []      []      l₂      := l₂
| []      (i::hd) []      := list.reverse (i :: hd)
| []      (i::hd) (j::l₂) :=
  if hij : i.1 = j.1
    then let c := i.2 * cast (congr_arg G hij).symm j.2 in
      if c = 1
        then mul_aux₃ [] hd l₂
        else list.reverse_core hd (⟨i.1, c⟩::l₂)
    else hd.reverse++i::j::l₂
| (i::l₁) hd      l₂      := mul_aux₃ l₁ (i::hd) l₂

lemma mul_aux₃_eq : ∀ (l₁ : list (Σ i, G i)) (hd : list (Σ i, G i))
  (l₂ : list (Σ i, G i)), reduced (hd.reverse ++ l₁) → reduced l₂ →
  mul_aux₃ l₁ hd l₂ = reduce (hd.reverse ++ l₁ ++ l₂)
| []      []      l₂      h₁ h₂ := by simp [mul_aux₃, reduce_eq_self_of_reduced, *] at *
| []      (i::hd) []      h₁ h₂ := by simp [mul_aux₃, reduce_eq_self_of_reduced, *] at *
| []      (⟨i, a⟩::hd) (⟨j, b⟩::l₂) h₁ h₂ :=
  begin
    simp only [mul_aux₃],
    dsimp only,
    rcases decidable.em (i = j) with ⟨rfl, hij⟩,
    { rw [dif_pos rfl, cast_eq],
      split_ifs,
      { rw [mul_aux₃_eq, append_nil, append_nil, reverse_cons, append_assoc,
          cons_append, nil_append, ← reduce_append_reduce_eq_reduce_append _ (_ :: _),
          reduce, if_neg, reduce, if_neg, rcons_rcons_of_add_eq_zero,
          reduce_append_reduce_eq_reduce_append], } }

  end
| (i::l₁) hd      l₂      := mul_aux₃ l₁ (i::hd) l₂

def X : Type := fin 1000000 → fin 1000000

def f : X := id

def f' : X := λ x, if x.1 = 999999 then ⟨1, by norm_num⟩ else x

@[priority 10000] instance {α : Type}: has_repr (list α) :=
⟨λ l, repr l.length⟩

-- instance : has_repr (multiplicative ℤ) := int.has_repr

--#eval (f = f' : bool)

set_option profiler true

#eval (@list.repeat (list (Σ i : X, ℕ)) [⟨f, 2⟩,⟨f',1⟩,⟨f,2⟩,⟨f',1⟩,
    ⟨f, 2⟩,⟨f',1⟩,⟨f,4⟩,⟨f', 2⟩, ⟨f, 3⟩] 1).zip_with (λ x y, (mul_aux' x y).1)
  (@list.repeat (list (Σ i : X, ℕ)) [⟨f, 4⟩, ⟨f', 5⟩] 1)

#eval (@list.repeat (list (Σ i : X, ℕ)) [⟨f, 2⟩,⟨f',1⟩,⟨f,2⟩,⟨f',1⟩,
    ⟨f, 2⟩,⟨f',1⟩,⟨f,4⟩,⟨f', 2⟩, ⟨f, 3⟩] 1).zip_with (λ x y, mul_aux₃ x [] y)
  (@list.repeat (list (Σ i : X, ℕ)) [⟨f, 4⟩, ⟨f', 5⟩] 1)

open multiplicative

#eval
  let l : list (Σ i : ℕ, multiplicative ℤ):= [⟨1, of_add 2⟩,
    ⟨2, of_add 1⟩,⟨1, of_add 2⟩,⟨2, of_add 1⟩,
    ⟨1, of_add 2⟩,⟨2, of_add 1⟩,⟨1, of_add 4⟩,⟨2, of_add 2⟩, ⟨1, of_add 3⟩] in
  let l' : list (Σ i : ℕ, multiplicative ℤ):= l.reverse.map (λ x, ⟨x.1, x.2⁻¹⟩) in
  --mul_aux₃ l [] l'
((@list.repeat (list (Σ i : ℕ, multiplicative ℤ)) l 100000).zip_with
    (λ x y, mul_aux x y)
  (@list.repeat _ l' 100000))

#eval
  let l : list (Σ i : ℕ, multiplicative ℤ):= [⟨1, of_add 2⟩,
    ⟨2, of_add 1⟩,⟨1, of_add 2⟩,⟨2, of_add 1⟩,
    ⟨1, of_add 2⟩,⟨2, of_add 1⟩,⟨1, of_add 4⟩,⟨2, of_add 2⟩, ⟨1, of_add 3⟩] in
  let l' : list (Σ i : ℕ, multiplicative ℤ):= (⟨2, of_add 3⟩ :: l) in
((@list.repeat (list (Σ i : ℕ, multiplicative ℤ)) l 100000).zip_with
    (λ x y, mul_aux' x y)
  (@list.repeat _ l' 100000))

#eval
  let l : list (Σ i : ℕ, multiplicative ℤ):= [⟨1, of_add 2⟩,
    ⟨2, of_add 1⟩,⟨1, of_add 2⟩,⟨2, of_add 1⟩,
    ⟨1, of_add 2⟩,⟨2, of_add 1⟩,⟨1, of_add 4⟩,⟨2, of_add 2⟩, ⟨1, of_add 3⟩] in
  let l' : list (Σ i : ℕ, multiplicative ℤ):= (⟨2, of_add 3⟩ :: l) in
((@list.repeat (list (Σ i : ℕ, multiplicative ℤ)) l 100000).zip_with
    (λ x y, mul_aux₃ x [] y)
  (@list.repeat _ l' 100000))

 --@mul_aux' ℕ (λ _, ℕ) _ _ _ [⟨1, 2⟩, ⟨2, 3⟩] [⟨3, 3⟩, ⟨4, 5⟩]

-- @[simp] lemma mul_aux'_nil (l : list (Σ i, G i)): mul_aux' [] l = (l, tt) := rfl
-- @[simp] lemma mul_aux'_cons (i : Σ i, G i) (l₁ l₂ : list (Σ i, G i)) :
--   mul_aux' (i :: l₁) l₂ = rcons' i (mul_aux' l₁ l₂) := rfl

-- @[simp] lemma rcons'_tt (i : Σ i, G i) : ∀ (l : list (Σ i, G i)),
--   (rcons' i (l, tt)).1 = rcons i l
-- | [] := rfl
-- | [i] := by simp [rcons', rcons]; split_ifs; simp
-- | (i::l) := by simp [rcons', rcons]; split_ifs; simp

-- @[simp] lemma rcons'_ff (i : Σ i, G i) : ∀ (l : list (Σ i, G i)),
--   rcons' i (l, ff) = (i :: l, ff)
-- | [] := rfl
-- | [i] := by simp [rcons', rcons]; split_ifs; simp
-- | (i::l) := by simp [rcons', rcons]; split_ifs; simp

-- @[simp] lemma foldr_ff : ∀ {l₁ l₂ : list (Σ i, G i)},
--   foldr rcons' (l₂, ff) l₁ = (l₁ ++ l₂, ff)
-- | []      l₂ := rfl
-- | (i::l₁) l₂ := by rw [foldr_cons, foldr_ff, rcons'_ff, cons_append]

-- -- def mul_aux3 : Π (b : bool) (l₁ l₂ : list (Σ i, G i)), list (Σ i, G i) × bool
-- -- | ff l₁ l₂ := (l₁ ++ l₂, ff)
-- -- | tt l₁ [] := (l₁, ff)
-- -- | tt [] l₂ := (l₂, ff)
-- -- | tt [i] (j::l₂) := sorry
-- -- | tt (i::j::l₁) (k::l₂) := let x := mul_aux3 tt (j::l₁) (k :: l₂) in
-- --  mul_aux3 x.2 [i] x.1

-- lemma rcons'_eq_tt_iff {i j : Σ i, G i} {l : list (Σ i, G i)} :
--   (rcons' i (j::l, tt)).2 = tt ↔ ∃ h : i.1 = j.1, i.2 * cast (congr_arg G h).symm j.2 = 1 :=
-- by rw rcons'; split_ifs; simp *

-- lemma rcons'_eq_ff : ∀ {l₁ : list (Σ i, G i)} {l₂ : list (Σ i, G i)}
--   {i : Σ i, G i} (hi : i.2 ≠ 1), (rcons' i (l₂, tt)).2 = ff → reduced (l₁ ++ [i]) →
--   reduced l₂ → reduced (l₁ ++ rcons i l₂)
-- | l₁ [] i hi h₁  hr h₂  := hr
-- | l₁ (i::l₂) j hj h₁ hr h₂ := begin
--   have := mt rcons'_eq_tt_iff.2 (ne_of_eq_of_ne h₁ bool.ff_ne_tt),
--   simp at this,

-- end

-- -- | l₁ [] i hi h₁  hr h₂  := hr
-- -- | [] l₂ j hj h₁ hr h₂ := by simp [reduced_rcons hj h₂]
-- -- --| [i] [] j hj h₁ hr h₂ := by simp [reduced_rcons hj h₂, rcons', *] at *
-- -- | [i] (j::l) k hj h₁ hr h₂ := begin
-- --   simp [rcons],
-- --   split_ifs,
-- --   { simp [rcons', *] at h₁, tauto },
-- --   { cases i with i a,
-- --     exact reduced_cons_cons sorry sorry sorry },
-- --   { sorry }
-- -- end
-- -- | (i::j::l₁) (k::l₂) m hm h₁ hr h₂ := begin
-- --   rw [cons_append, cons_append, rcons'_tt],
-- --   split,
-- --   { refine list.chain'_cons.2 _,
-- --     simp, admit },

-- --   admit
-- -- end

-- lemma foldr_eq_ff :  ∀ {l₁ l₂ : list (Σ i, G i)} {i : Σ i, G i}
--   (h₁ : reduced (i :: l₁)) (h₂ : reduced l₂),
--   (foldr rcons' (l₂, tt) l₁).2 = ff →
--   reduced (i :: (foldr rcons' (l₂, tt) l₁).1)
-- | []      l₂ i h₁ h₂ h := absurd h (by simp)
-- | (j::l₁) l₂ i h₁ h₂ h := begin
--   rw [foldr_cons, ← @prod.mk.eta _ _ (foldr rcons' (l₂, tt) (l₁))] at h,
--   cases hb : (foldr rcons' (l₂, tt) (l₁)).2,
--   { have := foldr_eq_ff (reduced_of_reduced_cons h₁) h₂ hb,
--     rw [foldr_cons, ← @prod.mk.eta _ _ (foldr rcons' (l₂, tt) (l₁)), hb,
--       rcons'_ff],
--     dsimp, }

-- end

-- -- lemma mul_aux'_eq_mul_aux : ∀ {b : bool} {l₁ l₂ : list (Σ i, G i)} {i j : Σ i, G i}
-- --   (h₁ : reduced l₁) (h₂ : reduced l₂)
-- --   (h : b = ff → reduced (l₁ ++ l₂)),
-- --   (foldr rcons' ([j] ++ l₂, b) (l₁ ++ [i])).1 = reduce (l₁ ++ [i, j] ++ l₂)
-- -- | ff [] l₂ i j h₁ h₂ hb := begin
-- --   simp [reduce, rcons'],
-- --   rw [if_neg, if_neg], admit

-- -- end

-- -- lemma mul_aux'_eq_mul_aux : ∀ {b : bool} {l₁ l₂ : list (Σ i, G i)} {i j : Σ i, G i}
-- --   (h₁ : reduced (l₁ ++ [i])) (h₂ : reduced ([j] ++ l₂))
-- --   (h : b = ff → reduced (l₁ ++ [i, j] ++ l₂)),
-- --   (foldr rcons' ([j] ++ l₂, b) (l₁ ++ [i])).1 = mul_aux (l₁ ++ [i]) ([j] ++ l₂) :=
-- -- begin
-- --   intros,
-- --   rw [foldr_append, foldr_cons, foldr_nil, ← @prod.mk.eta _ _ (rcons' i ([j] ++ l₂, b))],
-- --   cases b,
-- --   { rw [rcons'_ff, mul_aux_eq_reduce_append h₁ h₂, append_assoc l₁, ← append_assoc [i],
-- --       cons_append i, nil_append, ← append_assoc, reduce_eq_self_of_reduced (h rfl)],
-- --     simp [rcons'], admit },
-- --   { rw [rcons'_tt],
-- --     cases h : (rcons' i ([j] ++ l₂, tt)).2,
-- --     { rw [mul_aux_eq_reduce_append], },
-- --      }

-- -- end
-- -- | tt  []  l₂ i j h₁ h₂ hb := by simp [mul_aux]
-- -- | ff  []  l₂ i j h₁ h₂ hb := by admit
-- -- | tt  [i] l₂ j k h₁ h₂ hb := by simp [mul_aux]
-- -- | ff  (i::l₁) l₂ j k h₁ h₂ hb := begin
-- --   rw [mul_aux_eq_reduce_append h₁ h₂, foldr_cons],

-- -- end
-- -- | tt (i::l₁) l₂ h₁ h₂ hb := begin
-- --   rw [foldr_cons, ← @prod.mk.eta _ _ (foldr rcons' (l₂, tt) l₁)],
-- --   cases h : (foldr rcons' (l₂, tt) l₁).2,
-- --   { rw [rcons'_ff, mul_aux'_eq_mul_aux (reduced_of_reduced_cons h₁) h₂,
-- --       mul_aux_eq_reduce_append (reduced_of_reduced_cons h₁) h₂,
-- --       mul_aux_eq_reduce_append h₁ h₂], }

-- -- end

-- lemma mul_aux'_eq_mul_aux : ∀ {b : bool} {l₁ l₂ : list (Σ i, G i)}
--   (h₁ : reduced l₁) (h₂ : reduced l₂) (h : b = ff → reduced (l₁ ++ l₂)),
--   (foldr rcons' (l₂, b) l₁).1 = mul_aux l₁ l₂
-- | b   []  l₂ h₁ h₂ hb := rfl
-- | tt  [i] l₂ h₁ h₂ hb := by simp [mul_aux]
-- | ff  l₁ l₂ h₁ h₂ hb := by simp [mul_aux_eq_reduce_append h₁ h₂,
--     reduce_eq_self_of_reduced, *] at *
-- | tt (i::l₁) (j::l₂) h₁ h₂ hb := begin
--   rw [foldr_cons, ← @prod.mk.eta _ _ (foldr rcons' (j::l₂, tt) l₁)],
--   cases h : (foldr rcons' (j::l₂, tt) l₁).2,
--   {

--       }

-- end

-- def inv_aux (l : list (Σ i, G i)) : list (Σ i, G i) :=
-- l.reverse.map (λ a, (a.1, -a.2))

-- lemma inv_aux_cons (a : ι) (i : ℤ) (l : list (Σ i, G i)) :
--   inv_aux ((a, i) :: l) = inv_aux l ++ [(a, -i)] :=
-- by  simp [inv_aux]

-- lemma reduced_inv_aux {l : list (Σ i, G i)} (hl : reduced l) : reduced (inv_aux l) :=
-- ⟨(list.chain'_map _).2 (list.chain'_reverse.2 begin
--   convert hl.1, simp [function.funext_iff, eq_comm],
-- end), begin
--   rintros ⟨a, i⟩ ha,
--   have := hl.2 (a, -i),
--   finish [inv_aux]
-- end⟩

-- instance : has_inv (coprod ι) :=
-- ⟨λ a, ⟨inv_aux a.1, reduced_inv_aux a.2⟩⟩

-- lemma mul_aux_inv_aux_cancel : ∀ {l : list (Σ i, G i)}, reduced l →
--   mul_aux l (inv_aux l) = []
-- | []          hl := rfl
-- | ((a, i)::l) hal :=
-- have hi : i ≠ 0, from hal.2 (a, i) (mem_cons_self _ _),
-- have hl : reduced l, from reduced_of_reduced_cons hal,
-- begin
--   rw [mul_aux_eq_reduce_append hal (reduced_inv_aux hal), inv_aux_cons, cons_append,
--     ← append_assoc, ← reduce_cons_reduce_eq_reduce_cons,
--     ← reduce_reduce_append_eq_reduce_append, reduce_cons_reduce_eq_reduce_cons,
--     ← mul_aux_eq_reduce_append hl (reduced_inv_aux hl), mul_aux_inv_aux_cancel hl],
--   simp [reduce, hi, rcons]
-- end

-- instance : group (coprod ι) :=
-- { mul := (*),
--   inv := has_inv.inv,
--   one := 1,
--   mul_assoc := λ a b c, subtype.eq (mul_aux_assoc a.2 b.2 c.2),
--   one_mul := λ ⟨_, _⟩, rfl,
--   mul_one := λ ⟨_, _⟩, sorry,
--   mul_left_inv := sorry }

-- lemma mul_def (a b : coprod ι) : a * b = ⟨mul_aux a.1 b.1, reduced_mul_aux a.2 b.2⟩ := rfl

-- def of (a : ι) : coprod ι := ⟨[(a, 1)], by simp [reduced] { contextual := tt }⟩

-- @[elab_as_eliminator] lemma induction_on {P : coprod ι → Prop}
--   (g : coprod ι)
--   (h1 : P 1)
--   (atom : ∀ a, P (of a))
--   (atom_inv : ∀ a, P (of a)⁻¹)
--   (hmul : ∀ a g, P g → P (of a * g)) :
--   P g :=
-- begin
--   cases g with l hl,
--   induction l with a l ihl,
--   { exact h1 },
--   { cases a with a i,
--     induction i using int.induction_on with i ihi i ihi,
--     { simpa [reduced] using hl },
--     { by_cases hi : i = 0,
--       { subst i,
--         convert hmul a ⟨l, reduced_of_reduced_cons hl⟩ (ihl (reduced_of_reduced_cons hl)),
--         rw [mul_aux_eq_reduce_append (of a).2 (reduced_of_reduced_cons hl), of,
--           cons_append, nil_append, ← reduce_eq_self_of_reduced hl, int.coe_nat_zero, zero_add] },
--       { have hil : reduced ((a, i) :: l),
--           from reduced_cons_of_reduced_cons hl (by norm_cast; exact hi),
--         convert hmul a ⟨(a, i) :: l, hil⟩ (ihi hil),
--         rw [mul_aux_eq_reduce_append (of a).2 hil, of, cons_append, nil_append,
--           reduce, if_neg, reduce, if_neg, rcons_rcons_of_add_ne_zero],
--          }, }
--   }
-- end

-- variables {β : Type*} [decidable_eq β] (e : ι → β)

-- def map : coprod ι →* coprod β :=
-- { to_fun := λ ⟨l, hl⟩, ⟨l.map e, _⟩ }

end coprod


/-
Copyright (c) 2022 James Gallicchio.

---
This file was modified from source code released by
Microsoft Corporation under the Apache 2.0 license available at
<https://www.apache.org/licenses/>.

Original copyright notice:

Copyright (c) 2019 Microsoft Corporation. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
---

Authors: Leonardo de Moura, James Gallicchio
-/

import LeanColls.Classes

inductive LazyList (α : Type u)
| nil : LazyList α
| cons (hd : α) (tl : LazyList α) : LazyList α
| delayed (t : Thunk (LazyList α)) : LazyList α

namespace LazyList
variable {α : Type u} {β : Type v} {δ : Type w}

/-!
Standard technique for LazyList. Necessary because LazyList is a
nested inductive, but we never actually want to have different motives
for the nested types.

Remark: Lean used well-founded recursion behind the scenes to define LazyList.ind
-/
theorem ind {α : Type u} {motive : LazyList α → Sort v}
        (nil : motive LazyList.nil)
        (cons : (hd : α) → (tl : LazyList α) → motive tl → motive (LazyList.cons hd tl))
        (delayed : (t : Thunk (LazyList α)) → motive t.get → motive (LazyList.delayed t))
        (t : LazyList α) : motive t :=
  match t with
  | LazyList.nil => nil
  | LazyList.cons h t => cons h t (ind nil cons delayed t)
  | LazyList.delayed t => delayed t (ind nil cons delayed t.get)

instance : Inhabited (LazyList α) :=
⟨nil⟩

@[inline] protected def pure : α → LazyList α
| a => cons a nil

/-
Length of a list is number of actual elements
in the list, ignoring delays
-/
def length : LazyList α → Nat
| nil        => 0
| cons _ as  => length as + 1
| delayed as => length as.get

def toList : LazyList α → List α
| nil        => []
| cons a as  => a :: toList as
| delayed as => toList as.get

attribute [simp] length toList

@[simp] theorem length_toList : (l : LazyList α) → l.toList.length = l.length
| nil => rfl
| cons a as => by simp [length_toList as]
| delayed as => by simp [length_toList as.get]

def force : LazyList α → Option (α × LazyList α)
| delayed as => force as.get
| nil        => none
| cons a as  => some (a,as)

theorem toList_force_none {l : LazyList α}
  : force l = none ↔ l.toList = List.nil
  := by
    induction l using ind
    simp [force]
    simp [force]
    simp [force]; assumption

theorem toList_force_some {l : LazyList α}
  : force l = some (x,xs) → l.toList = List.cons x xs.toList
  := by
    induction l using ind generalizing x xs
    simp [force]
    case cons =>
      simp [force]
      intro h
      simp [h]
      apply congr_arg
    case delayed th ih =>
      simp [force]
      intro h
      exact ih h

def head? (l : LazyList α) : Option α := l.force.map (Prod.fst)

def tail? (l : LazyList α) : Option (LazyList α) := l.force.map (Prod.snd)

def isEmpty (l : LazyList α) : Bool := l.length = 0

def append : LazyList α → LazyList α → LazyList α
| nil,        bs => bs
| cons a as,  bs => cons a (delayed (append as bs))
| delayed as, bs => append as.get bs

instance : Append (LazyList α) :=
⟨LazyList.append⟩

@[simp] theorem toList_append (l₁ l₂ : LazyList α)
  : (l₁ ++ l₂).toList = l₁.toList ++ l₂.toList
  := by
    induction l₁ using ind
    simp [HAppend.hAppend, Append.append, append, List.append, toList]
    case cons hd tl tl_ih =>
      simp [HAppend.hAppend, Append.append, append] at tl_ih |-
      simp [tl_ih, toList, Thunk.get]
    case delayed t t_ih =>
      simp [HAppend.hAppend, Append.append, append] at t_ih |-
      assumption

@[simp] theorem length_append (l₁ l₂ : LazyList α)
  : (l₁ ++ l₂).length = l₁.length + l₂.length
  := by
  rw [←length_toList, ←length_toList, ←length_toList]
  rw [toList_append]
  exact List.length_append (toList l₁) (toList l₂)

@[simp] def revAppend : LazyList α → LazyList α → LazyList α
| nil,        bs => bs
| cons a as,  bs => revAppend as (cons a bs)
| delayed as, bs => revAppend as.get bs

@[simp] theorem toList_revAppend (l₁ l₂ : LazyList α)
  : (revAppend l₁ l₂).toList = l₁.toList.reverse ++ l₂.toList
  := by
    induction l₁ using ind generalizing l₂
    simp
    case cons hd tl tl_ih =>
      simp [Thunk.get] at tl_ih |-
      have := tl_ih (cons hd l₂)
      rw [this]
      simp [HAppend.hAppend, Append.append, List.append]
    case delayed t t_ih =>
      simp [HAppend.hAppend, Append.append, append] at t_ih |-
      exact t_ih l₂

@[simp] theorem length_revAppend (l₁ l₂ : LazyList α)
  : (revAppend l₁ l₂).length = l₁.length + l₂.length
  := by
  rw [←length_toList, ←length_toList, ←length_toList]
  rw [toList_revAppend, List.length_append, List.length_reverse]

def reverse (l : LazyList α) := revAppend l nil

@[simp] theorem toList_reverse (l : LazyList α) : l.reverse.toList = l.toList.reverse
  := by simp [reverse]

@[simp] theorem length_reverse (l : LazyList α) : l.reverse.length = l.length
  := by simp [reverse]

def interleave : LazyList α → LazyList α → LazyList α
| nil,        bs => bs
| cons a as,  bs =>
  cons a (delayed (interleave bs as))
| delayed as, bs =>
  interleave as.get bs
termination_by _ as bs => sizeOf (as,bs)

@[specialize] def map (f : α → β) : LazyList α → LazyList β
| nil        => nil
| cons a as  => cons (f a) (delayed (map f as))
| delayed as => map f as.get

@[specialize] def map₂ (f : α → β → δ) : LazyList α → LazyList β → LazyList δ
| nil, _ => nil
| _, nil => nil
| cons a as, cons b bs =>
  cons (f a b) (delayed (map₂ f as bs))
| delayed as, bs =>
  map₂ f as.get bs
| as, delayed bs => map₂ f as bs.get
termination_by _ as bs => sizeOf (as,bs)

@[inline] def zip : LazyList α → LazyList β → LazyList (α × β) :=
  map₂ Prod.mk

def join : LazyList (LazyList α) → LazyList α
| nil        => nil
| cons a as  => a ++ delayed (join as)
| delayed as => join as.get

@[inline] protected def bind (x : LazyList α) (f : α → LazyList β) : LazyList β :=
join (x.map f)

def take : Nat → LazyList α → List α
| 0, _ => []
| _, nil => []
| i+1, cons a as => a :: take i as
| i+1, delayed as => take (i+1) as.get

@[specialize] def filter (p : α → Bool) : LazyList α → LazyList α
| nil          => nil
| (cons a as)  => if p a then cons a (delayed (filter p as)) else filter p as
| (delayed as) => filter p as.get

instance : Monad LazyList where
  pure := @LazyList.pure
  bind := @LazyList.bind
  map := @LazyList.map

instance : Alternative LazyList where
  failure := nil
  orElse  := fun as bs => LazyList.append as (delayed (Thunk.mk bs))

def fold (f : α → τ → α) (acc : α)
: LazyList τ → α
| nil        => acc
| cons a as  =>
  fold f (f acc a) as
| delayed as => fold f acc (as.get)

instance : LeanColls.Foldable (LazyList τ) τ where
  fold l f a := fold f a l

instance : LeanColls.Iterable (LazyList τ) τ where
  ρ := LazyList τ
  step := LazyList.force
  toIterator := id

@[specialize] partial def iterate (f : α → α) : α → LazyList α
| x => cons x (delayed (iterate f (f x)))

@[specialize] partial def iterate₂ (f : α → α → α) : α → α → LazyList α
| x, y => cons x (delayed (iterate₂ f y (f x y)))

partial def cycle : LazyList α → LazyList α
| xs => xs ++ delayed (cycle xs)

def inits : LazyList α → LazyList (LazyList α)
| nil        => cons nil nil
| cons a as  => cons nil (delayed (map (fun as => cons a as) (inits as)))
| delayed as => inits as.get

private def addOpenBracket (s : String) : String :=
if s.isEmpty then "[" else s

def approxToStringAux [ToString α] : Nat → LazyList α → String → String
| _,   nil,        r => (if r.isEmpty then "[" else r) ++ "]"
| 0,   _,          r => (if r.isEmpty then "[" else r) ++ ", ..]"
| n+1, cons a as,  r => approxToStringAux n as ((if r.isEmpty then "[" else r ++ ", ") ++ toString a)
| n,   delayed as, r => approxToStringAux n as.get r

def approxToString [ToString α] (as : LazyList α) (n : Nat := 10) : String :=
as.approxToStringAux n ""

instance [ToString α] : ToString (LazyList α) :=
⟨approxToString⟩

end LazyList

private unsafe def List.toLazyUnsafe {α : Type u} (xs : List α) : LazyList α :=
  unsafeCast xs

@[implementedBy List.toLazyUnsafe]
def List.toLazy {α : Type u} : List α → LazyList α
| []     => LazyList.nil
| (h::t) => LazyList.cons h (toLazy t)

def fib : LazyList Nat :=
LazyList.iterate₂ (·+·) 0 1

def tst : LazyList String := do
  let x ← [1, 2, 3].toLazy
  let y ← [2, 3, 4].toLazy
  -- dbgTrace (toString x ++ " " ++ toString y) $ λ _,
  guard (x + y > 5)
  return (toString x ++ " + " ++ toString y ++ " = " ++ toString (x+y))

open LazyList

def iota (i : UInt32 := 0) : LazyList UInt32 :=
iterate (·+1) i

partial def sieve : LazyList UInt32 → LazyList UInt32
| nil          => nil
| (cons a as)  => cons a (delayed (sieve (filter (fun b => b % a != 0) as)))
| (delayed as) => sieve as.get

partial def primes : LazyList UInt32 :=
sieve (iota 2)

#eval show IO Unit from do
  let n := 10
  IO.println $ tst.isEmpty ;
  -- IO.println $ [1, 2, 3].toLazy.cycle,
  -- IO.println $ [1, 2, 3].toLazy.cycle.inits,
  -- IO.println $ ((iota.filter (λ v, v % 5 == 0)).approx 50000).foldl (+) 0,
  IO.println $ (primes.take 2000).foldl (·+·) 0
  -- IO.println $ tst.head,
  -- IO.println $ fib.interleave (iota.map (+100)),
  -- IO.println $ ((iota.map (+10)).filter (λ v, v % 2 == 0)),
  return ()


namespace Foo

structure A :=
(x : Nat)

def A.doubleX (a : A) :=
2 * a.x

structure B extends A :=
(y : Nat)

def f (b : B) : Nat :=
b.x + b.doubleX

theorem ex1 : { x := 10, y := 0 : B }.doubleX = 20 :=
rfl

theorem ex2 : f { x := 10, y := 0 } = 30 :=
rfl

end Foo


/-
Copyright (c) 2020 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Scott Morrison
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.category_theory.monoidal.functorial
import Mathlib.category_theory.monoidal.functor_category
import Mathlib.category_theory.limits.limits
import Mathlib.PostPort

universes u v

namespace Mathlib

/-!
# `lim : (J ⥤ C) ⥤ C` is lax monoidal when `C` is a monoidal category.

When `C` is a monoidal category, the functorial association `F ↦ limit F` is lax monoidal,
i.e. there are morphisms
* `lim_lax.ε : (𝟙_ C) → limit (𝟙_ (J ⥤ C))`
* `lim_lax.μ : limit F ⊗ limit G ⟶ limit (F ⊗ G)`
satisfying the laws of a lax monoidal functor.
-/

namespace category_theory.limits

protected instance limit_functorial {J : Type v} [small_category J] {C : Type u} [category C]
    [has_limits C] : functorial fun (F : J ⥤ C) => limit F :=
  functorial.mk (functor.map lim)

@[simp] theorem limit_functorial_map {J : Type v} [small_category J] {C : Type u} [category C]
    [has_limits C] {F : J ⥤ C} {G : J ⥤ C} (α : F ⟶ G) :
    map (fun (F : J ⥤ C) => limit F) α = functor.map lim α :=
  rfl

protected instance limit_lax_monoidal {J : Type v} [small_category J] {C : Type u} [category C]
    [has_limits C] [monoidal_category C] : lax_monoidal fun (F : J ⥤ C) => limit F :=
  lax_monoidal.mk
    (limit.lift (functor.obj (functor.const J) 𝟙_) (cone.mk 𝟙_ (nat_trans.mk fun (j : J) => 𝟙)))
    fun (F G : J ⥤ C) =>
      limit.lift (F ⊗ G)
        (cone.mk (limit F ⊗ limit G) (nat_trans.mk fun (j : J) => limit.π F j ⊗ limit.π G j))

/-- The limit functor `F ↦ limit F` bundled as a lax monoidal functor. -/
def lim_lax {J : Type v} [small_category J] {C : Type u} [category C] [has_limits C]
    [monoidal_category C] : lax_monoidal_functor (J ⥤ C) C :=
  lax_monoidal_functor.of fun (F : J ⥤ C) => limit F

@[simp] theorem lim_lax_obj {J : Type v} [small_category J] {C : Type u} [category C] [has_limits C]
    [monoidal_category C] (F : J ⥤ C) :
    functor.obj (lax_monoidal_functor.to_functor lim_lax) F = limit F :=
  rfl

theorem lim_lax_obj' {J : Type v} [small_category J] {C : Type u} [category C] [has_limits C]
    [monoidal_category C] (F : J ⥤ C) :
    functor.obj (lax_monoidal_functor.to_functor lim_lax) F = functor.obj lim F :=
  rfl

@[simp] theorem lim_lax_map {J : Type v} [small_category J] {C : Type u} [category C] [has_limits C]
    [monoidal_category C] {F : J ⥤ C} {G : J ⥤ C} (α : F ⟶ G) :
    functor.map (lax_monoidal_functor.to_functor lim_lax) α = functor.map lim α :=
  rfl

@[simp] theorem lim_lax_ε {J : Type v} [small_category J] {C : Type u} [category C] [has_limits C]
    [monoidal_category C] :
    lax_monoidal_functor.ε lim_lax =
        limit.lift (functor.obj (functor.const J) 𝟙_)
          (cone.mk 𝟙_ (nat_trans.mk fun (j : J) => 𝟙)) :=
  rfl

@[simp] theorem lim_lax_μ {J : Type v} [small_category J] {C : Type u} [category C] [has_limits C]
    [monoidal_category C] (F : J ⥤ C) (G : J ⥤ C) :
    lax_monoidal_functor.μ lim_lax F G =
        limit.lift (F ⊗ G)
          (cone.mk (limit F ⊗ limit G) (nat_trans.mk fun (j : J) => limit.π F j ⊗ limit.π G j)) :=
  rfl

end Mathlib


import pseudo_normed_group.category
import rescale.pseudo_normed_group
.

open_locale nnreal
local attribute [instance] type_pow
noncomputable theory

open category_theory

namespace ProFiltPseuNormGrpWithTinv

variables (r' : ℝ≥0) [fact (0 < r')]
variables (c : ℝ≥0) (m n : ℕ)
variables (M : ProFiltPseuNormGrpWithTinv r')

local notation `ρ` := _root_.rescale

/-
Useful facts that we already have:

* `Pow_mul (r') (N n : ℕ) : Pow r' (N * n) ≅ Pow r' N ⋙ Pow r' n`
* `iso_of_equiv_of_strict'` for constructing isos in `ProFiltPseuNormGrpWithTinv r'`
-/

open comphaus_filtered_pseudo_normed_group

@[simps {fully_applied := ff}]
def Pow_mul_comm_obj_equiv (X : ProFiltPseuNormGrpWithTinv r') :
  X ^ (m * n) ≃+ X ^ (n * m) :=
(linear_equiv.fun_congr_left ℤ X $
calc fin (n * m) ≃ fin n × fin m : fin_prod_fin_equiv.symm
      ... ≃ fin m × fin n            : equiv.prod_comm _ _
      ... ≃ fin (m * n)              : fin_prod_fin_equiv).to_add_equiv

lemma Pow_mul_comm_obj_equiv_strict
  (X : ProFiltPseuNormGrpWithTinv r') (c : ℝ≥0) (x : (X : Type _) ^ (m * n)) :
  x ∈ pseudo_normed_group.filtration ↥(of r' (↥X ^ (m * n))) c ↔
   (Pow_mul_comm_obj_equiv r' m n X) x ∈ pseudo_normed_group.filtration (↥X ^ (n * m)) c :=
begin
  intros,
  simp only [Pow_mul_comm_obj_equiv_apply,
    linear_equiv.trans_apply, linear_equiv.coe_to_add_equiv,
    linear_equiv.fun_congr_left_apply, linear_equiv.fun_congr_left_comp],
  erw pseudo_normed_group.mem_filtration_pi, -- TODO arrange so that `simp` can achieve this
  erw pseudo_normed_group.mem_filtration_pi,
  fsplit,
  { intros h i,
    apply h, },
  { intros h i,
    simpa [- fin_prod_fin_equiv_symm_apply] using h (fin_prod_fin_equiv ((fin_prod_fin_equiv.symm) i).swap), }
end

lemma Pow_mul_comm_obj_equiv_ctu (X : ProFiltPseuNormGrpWithTinv r') (c : ℝ≥0) :
  continuous (pseudo_normed_group.level ⇑(Pow_mul_comm_obj_equiv r' m n X)
    (λ c x, (Pow_mul_comm_obj_equiv_strict r' _ _ X c x).mp) c) :=
begin
  rw [← (filtration_pi_homeo _ c).comp_continuous_iff,
    ← (filtration_pi_homeo _ c).symm.comp_continuous_iff'],
  apply continuous_pi,
  intro i,
  dsimp [- fin_prod_fin_equiv_symm_apply],
  convert continuous_apply (fin_prod_fin_equiv ((fin_prod_fin_equiv.symm) i).swap) using 1,
  ext x,
  rw subtype.coe_mk,
end

@[simps {fully_applied := ff}]
def Pow_mul_comm_obj (X : ProFiltPseuNormGrpWithTinv r') :
  of r' (X ^ (m * n)) ≅ of r' (X ^ (n * m)) :=
iso_of_equiv_of_strict' (Pow_mul_comm_obj_equiv r' _ _ X)
  (Pow_mul_comm_obj_equiv_strict r' _ _ X)
  (Pow_mul_comm_obj_equiv_ctu r' _ _ X)
  (by { intros, ext, refl })

def Pow_mul_comm : Pow r' (m * n) ≅ Pow r' (n * m) :=
  nat_iso.of_components
  (λ X, Pow_mul_comm_obj r' _ _ X)
  begin
    intros X Y f, ext x i,
    -- This is just a terminal simp, which I've exploded for the sake of speed.
    simp only [Pow_mul_comm_obj_hom_to_fun,
      ProFiltPseuNormGrpWithTinv.iso_of_equiv_of_strict'_hom_apply,
      ProFiltPseuNormGrpWithTinv.Pow_map, linear_equiv.trans_apply,
      ProFiltPseuNormGrpWithTinv.coe_comp_apply,
      linear_map.fun_left_apply, linear_equiv.coe_to_add_equiv, id.def,
      equiv.prod_comm_apply, linear_equiv.fun_congr_left_apply, linear_equiv.fun_congr_left_comp,
      profinitely_filtered_pseudo_normed_group_with_Tinv.pi_map_to_fun],
  end

def Pow_comm : Pow r' m ⋙ Pow r' n ≅ Pow r' n ⋙ Pow r' m :=
calc Pow r' m ⋙ Pow r' n ≅ Pow r' (m * n) : (Pow_mul r' m n).symm
  ... ≅ Pow r' (n * m)                    : Pow_mul_comm r' m n
  ... ≅ Pow r' n ⋙ Pow r' m               : Pow_mul r' n m

@[simps]
def Pow_rescale_aux (c : ℝ≥0) (m : ℕ)
  (X : ProFiltPseuNormGrpWithTinv r') :
  ρ c (X ^ m) ≃+ (ρ c X) ^ m :=
add_equiv.refl _

lemma Pow_rescale_aux_ctu
  (X : ProFiltPseuNormGrpWithTinv r') (c' : ℝ≥0) :
  continuous (pseudo_normed_group.level ⇑(Pow_rescale_aux r' c m X) (λ _ _, id) c') :=
begin
  erw [← (filtration_pi_homeo _ _).comp_continuous_iff,
    ← (filtration_pi_homeo _ _).symm.comp_continuous_iff'],
  apply continuous_pi,
  intro i,
  dsimp,
  convert continuous_apply i,
  ext,
  rw subtype.coe_mk
end

def Pow_rescale : Pow r' m ⋙ rescale r' c ≅ rescale r' c ⋙ Pow r' m :=
nat_iso.of_components
  (λ X, begin
    dsimp,
    fapply iso_of_equiv_of_strict',
    apply Pow_rescale_aux,
    { intros c' x,
      erw pseudo_normed_group.mem_filtration_pi, }, -- err, why does that close the goal?
    { apply Pow_rescale_aux_ctu },
    { intros x, ext i, refl, },
  end)
  begin
    intros X Y f, ext x i,
    dsimp,
    refl,
  end

/-- A very specific isomorphism -/
def Pow_rescale_Pow_iso :
  Pow r' m ⋙ rescale r' c ⋙ Pow r' n ≅ Pow r' n ⋙ Pow r' m ⋙ rescale r' c :=
calc Pow r' m ⋙ rescale r' c ⋙ Pow r' n
      ≅ Pow r' m ⋙ Pow r' n ⋙ rescale r' c : iso_whisker_left (Pow r' m) (Pow_rescale r' c n).symm
  ... ≅ (Pow r' m ⋙ Pow r' n) ⋙ rescale r' c : (functor.associator _ _ _).symm
  ... ≅ (Pow r' n ⋙ Pow r' m) ⋙ rescale r' c : iso_whisker_right (Pow_comm r' m n) _
  ... ≅ Pow r' n ⋙ Pow r' m ⋙ rescale r' c : functor.associator _ _ _

end ProFiltPseuNormGrpWithTinv