/-
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 order.hom.bounded
! leanprover-community/mathlib commit f1a2caaf51ef593799107fe9a8d5e411599f3996
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathlib.Order.Hom.Basic
import Mathlib.Order.BoundedOrder

/-!
# Bounded order homomorphisms

This file defines (bounded) order homomorphisms.

We use the `FunLike` 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

* `TopHom`: Maps which preserve `⊤`.
* `BotHom`: Maps which preserve `⊥`.
* `BoundedOrderHom`: Bounded order homomorphisms. Monotone maps which preserve `⊤` and `⊥`.

## Typeclasses

* `TopHomClass`
* `BotHomClass`
* `BoundedOrderHomClass`
-/

open Function OrderDual

variable {F α β γ δ : Type _}

/-- The type of `⊤`-preserving functions from `α` to `β`. -/
structure TopHom (α β : Type _) [Top α] [Top β] where
  /-- The underlying function. The preferred spelling is `FunLike.coe`. -/
  toFun : α → β
  /-- The function preserves the top element. The preferred spelling is `map_top`. -/
  map_top' : toFun ⊤ = ⊤
#align top_hom TopHom

/-- The type of `⊥`-preserving functions from `α` to `β`. -/
structure BotHom (α β : Type _) [Bot α] [Bot β] where
  /-- The underlying function. The preferred spelling is `FunLike.coe`. -/
  toFun : α → β
  /-- The function preserves the bottom element. The preferred spelling is `map_bot`. -/
  map_bot' : toFun ⊥ = ⊥
#align bot_hom BotHom

/-- The type of bounded order homomorphisms from `α` to `β`. -/
structure BoundedOrderHom (α β : Type _) [Preorder α] [Preorder β] [BoundedOrder α]
  [BoundedOrder β] extends OrderHom α β where
  /-- The function preserves the top element. The preferred spelling is `map_top`. -/
  map_top' : toFun ⊤ = ⊤
  /-- The function preserves the bottom element. The preferred spelling is `map_bot`. -/
  map_bot' : toFun ⊥ = ⊥
#align bounded_order_hom BoundedOrderHom

section

/-- `TopHomClass F α β` states that `F` is a type of `⊤`-preserving morphisms.

You should extend this class when you extend `TopHom`. -/
class TopHomClass (F : Type _) (α β : outParam <| Type _) [Top α] [Top β] extends
  FunLike F α fun _ => β where
  /-- A `TopHomClass` morphism preserves the top element. -/
  map_top (f : F) : f ⊤ = ⊤
#align top_hom_class TopHomClass

/-- `BotHomClass F α β` states that `F` is a type of `⊥`-preserving morphisms.

You should extend this class when you extend `BotHom`. -/
class BotHomClass (F : Type _) (α β : outParam <| Type _) [Bot α] [Bot β] extends
  FunLike F α fun _ => β where
  /-- A `BotHomClass` morphism preserves the bottom element. -/
  map_bot (f : F) : f ⊥ = ⊥
#align bot_hom_class BotHomClass

/-- `BoundedOrderHomClass F α β` states that `F` is a type of bounded order morphisms.

You should extend this class when you extend `BoundedOrderHom`. -/
class BoundedOrderHomClass (F : Type _) (α β : outParam <| Type _) [LE α] [LE β] [BoundedOrder α]
  [BoundedOrder β] extends RelHomClass F ((· ≤ ·) : α → α → Prop) ((· ≤ ·) : β → β → Prop) where
  /-- Morphisms preserve the top element. The preferred spelling is `_root_.map_top`. -/
  map_top (f : F) : f ⊤ = ⊤
  /-- Morphisms preserve the bottom element. The preferred spelling is `_root_.map_bot`. -/
  map_bot (f : F) : f ⊥ = ⊥
#align bounded_order_hom_class BoundedOrderHomClass

end

export TopHomClass (map_top)

export BotHomClass (map_bot)

attribute [simp] map_top map_bot

-- Porting note: the `BoundedOrder` parameters can't be inferred through unification in all cases
-- so they should really be instance parameters once this is technically possible.
-- We have to supply these instances through `letI` in some cases as a work-around.
-- See note [lower instance priority]
instance (priority := 100) BoundedOrderHomClass.toTopHomClass {_ : LE α} {_ : LE β}
    {_ : BoundedOrder α} {_ : BoundedOrder β} [BoundedOrderHomClass F α β] : TopHomClass F α β :=
  { ‹BoundedOrderHomClass F α β› with }
#align bounded_order_hom_class.to_top_hom_class BoundedOrderHomClass.toTopHomClass

-- See note [lower instance priority]
instance (priority := 100) BoundedOrderHomClass.toBotHomClass {_ : LE α} {_ : LE β}
    {_ : BoundedOrder α} {_ : BoundedOrder β} [BoundedOrderHomClass F α β] : BotHomClass F α β :=
  { ‹BoundedOrderHomClass F α β› with }
#align bounded_order_hom_class.to_bot_hom_class BoundedOrderHomClass.toBotHomClass

@[nolint dangerousInstance] -- The `OrderTop`s should be instance parameters but depend on outParams
-- See note [lower instance priority]
instance (priority := 100) OrderIsoClass.toTopHomClass {_ : LE α} {_ : OrderTop α}
    {_ : PartialOrder β} {_ : OrderTop β} [OrderIsoClass F α β] : TopHomClass F α β :=
  { show OrderHomClass F α β from inferInstance with
    map_top := fun f => top_le_iff.1 <| (map_inv_le_iff f).1 le_top }
#align order_iso_class.to_top_hom_class OrderIsoClass.toTopHomClass

@[nolint dangerousInstance] -- The `OrderBot`s should be instance parameters but depend on outParams
-- See note [lower instance priority]
instance (priority := 100) OrderIsoClass.toBotHomClass {_ : LE α} {_ : OrderBot α}
    {_ : PartialOrder β} {_ : OrderBot β} [OrderIsoClass F α β] : BotHomClass F α β :=
  { --⟨λ f, le_bot_iff.1 $ (le_map_inv_iff f).1 bot_le⟩
    show OrderHomClass F α β from inferInstance with
    map_bot := fun f => le_bot_iff.1 <| (le_map_inv_iff f).1 bot_le }
#align order_iso_class.to_bot_hom_class OrderIsoClass.toBotHomClass

@[nolint dangerousInstance] -- The `BoundedOrder`s should be instance parameters but depend on
                            -- outParams
-- See note [lower instance priority]
instance (priority := 100) OrderIsoClass.toBoundedOrderHomClass {_ : LE α} {_ : BoundedOrder α}
    {_ : PartialOrder β} {_ : BoundedOrder β} [OrderIsoClass F α β] : BoundedOrderHomClass F α β :=
  { show OrderHomClass F α β from inferInstance, OrderIsoClass.toTopHomClass,
    OrderIsoClass.toBotHomClass with }
#align order_iso_class.to_bounded_order_hom_class OrderIsoClass.toBoundedOrderHomClass

-- Porting note: the `letI` is needed because we can't make the
-- `OrderTop` parameters instance implicit in `OrderIsoClass.toTopHomClass`,
-- and they apparently can't be figured out through unification.
@[simp]
theorem map_eq_top_iff [LE α] [OrderTop α] [PartialOrder β] [OrderTop β] [OrderIsoClass F α β]
    (f : F) {a : α} : f a = ⊤ ↔ a = ⊤ := by
  letI : TopHomClass F α β := OrderIsoClass.toTopHomClass
  rw [← map_top f, (EquivLike.injective f).eq_iff]
#align map_eq_top_iff map_eq_top_iff

-- Porting note: the `letI` is needed because we can't make the
-- `OrderBot` parameters instance implicit in `OrderIsoClass.toBotHomClass`,
-- and they apparently can't be figured out through unification.
@[simp]
theorem map_eq_bot_iff [LE α] [OrderBot α] [PartialOrder β] [OrderBot β] [OrderIsoClass F α β]
    (f : F) {a : α} : f a = ⊥ ↔ a = ⊥ := by
  letI : BotHomClass F α β := OrderIsoClass.toBotHomClass
  rw [← map_bot f, (EquivLike.injective f).eq_iff]
#align map_eq_bot_iff map_eq_bot_iff

/-- Turn an element of a type `F` satisfying `TopHomClass F α β` into an actual
`TopHom`. This is declared as the default coercion from `F` to `TopHom α β`. -/
@[coe]
def TopHomClass.toTopHom [Top α] [Top β] [TopHomClass F α β] (f : F) : TopHom α β :=
  ⟨f, map_top f⟩

instance [Top α] [Top β] [TopHomClass F α β] : CoeTC F (TopHom α β) :=
  ⟨TopHomClass.toTopHom⟩

/-- Turn an element of a type `F` satisfying `BotHomClass F α β` into an actual
`BotHom`. This is declared as the default coercion from `F` to `BotHom α β`. -/
@[coe]
def BotHomClass.toBotHom [Bot α] [Bot β] [BotHomClass F α β] (f : F) : BotHom α β :=
  ⟨f, map_bot f⟩

instance [Bot α] [Bot β] [BotHomClass F α β] : CoeTC F (BotHom α β) :=
  ⟨BotHomClass.toBotHom⟩

/-- Turn an element of a type `F` satisfying `BoundedOrderHomClass F α β` into an actual
`BoundedOrderHom`. This is declared as the default coercion from `F` to `BoundedOrderHom α β`. -/
@[coe]
def BoundedOrderHomClass.toBoundedOrderHom [Preorder α] [Preorder β] [BoundedOrder α]
    [BoundedOrder β] [BoundedOrderHomClass F α β] (f : F) : BoundedOrderHom α β :=
  { (f : α →o β) with toFun := f, map_top' := map_top f, map_bot' := map_bot f }

instance [Preorder α] [Preorder β] [BoundedOrder α] [BoundedOrder β] [BoundedOrderHomClass F α β] :
    CoeTC F (BoundedOrderHom α β) :=
  ⟨BoundedOrderHomClass.toBoundedOrderHom⟩

/-! ### Top homomorphisms -/

namespace TopHom

variable [Top α]

section Top

variable [Top β] [Top γ] [Top δ]

instance : TopHomClass (TopHom α β) α
      β where
  coe := TopHom.toFun
  coe_injective' f g h := by cases f; cases g; congr
  map_top := TopHom.map_top'

#noalign top_hom.to_fun_eq_coe

-- this must come after the coe_to_fun definition
initialize_simps_projections TopHom (toFun → apply)

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

/-- Copy of a `TopHom` with a new `toFun` equal to the old one. Useful to fix definitional
equalities. -/
protected def copy (f : TopHom α β) (f' : α → β) (h : f' = f) :
    TopHom α β where
  toFun := f'
  map_top' := h.symm ▸ f.map_top'
#align top_hom.copy TopHom.copy

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

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

instance : Inhabited (TopHom α β) :=
  ⟨⟨fun _ => ⊤, rfl⟩⟩

variable (α)

/-- `id` as a `TopHom`. -/
protected def id : TopHom α α :=
  ⟨id, rfl⟩
#align top_hom.id TopHom.id

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

variable {α}

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

/-- Composition of `TopHom`s as a `TopHom`. -/
def comp (f : TopHom β γ) (g : TopHom α β) :
    TopHom α γ where
  toFun := f ∘ g
  map_top' := by rw [comp_apply, map_top, map_top]
#align top_hom.comp TopHom.comp

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

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

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

@[simp]
theorem comp_id (f : TopHom α β) : f.comp (TopHom.id α) = f :=
  TopHom.ext fun _ => rfl
#align top_hom.comp_id TopHom.comp_id

@[simp]
theorem id_comp (f : TopHom α β) : (TopHom.id β).comp f = f :=
  TopHom.ext fun _ => rfl
#align top_hom.id_comp TopHom.id_comp

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

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

end Top

instance [Preorder β] [Top β] : Preorder (TopHom α β) :=
  Preorder.lift (FunLike.coe : TopHom α β → α → β)

instance [PartialOrder β] [Top β] : PartialOrder (TopHom α β) :=
  PartialOrder.lift _ FunLike.coe_injective

section OrderTop

variable [Preorder β] [OrderTop β]

instance : OrderTop (TopHom α β) where
  top := ⟨⊤, rfl⟩
  le_top := fun _ => @le_top (α → β) _ _ _

@[simp]
theorem coe_top : ⇑(⊤ : TopHom α β) = ⊤ :=
  rfl
#align top_hom.coe_top TopHom.coe_top

@[simp]
theorem top_apply (a : α) : (⊤ : TopHom α β) a = ⊤ :=
  rfl
#align top_hom.top_apply TopHom.top_apply

end OrderTop

section SemilatticeInf

variable [SemilatticeInf β] [OrderTop β] (f g : TopHom α β)

instance : Inf (TopHom α β) :=
  ⟨fun f g => ⟨f ⊓ g, by rw [Pi.inf_apply, map_top, map_top, inf_top_eq]⟩⟩

instance : SemilatticeInf (TopHom α β) :=
  (FunLike.coe_injective.semilatticeInf _) fun _ _ => rfl

@[simp]
theorem coe_inf : ⇑(f ⊓ g) = ⇑f ⊓ ⇑g :=
  rfl
#align top_hom.coe_inf TopHom.coe_inf

@[simp]

end SemilatticeInf

section SemilatticeSup

variable [SemilatticeSup β] [OrderTop β] (f g : TopHom α β)

instance : Sup (TopHom α β) :=
  ⟨fun f g => ⟨f ⊔ g, by rw [Pi.sup_apply, map_top, map_top, sup_top_eq]⟩⟩

instance : SemilatticeSup (TopHom α β) :=
  (FunLike.coe_injective.semilatticeSup _) fun _ _ => rfl

@[simp]
theorem coe_sup : ⇑(f ⊔ g) = ⇑f ⊔ ⇑g :=
  rfl
#align top_hom.coe_sup TopHom.coe_sup

@[simp]
theorem sup_apply (a : α) : (f ⊔ g) a = f a ⊔ g a :=
  rfl
#align top_hom.sup_apply TopHom.sup_apply

end SemilatticeSup

instance [Lattice β] [OrderTop β] : Lattice (TopHom α β) :=
  FunLike.coe_injective.lattice _ (fun _ _ => rfl) fun _ _ => rfl

instance [DistribLattice β] [OrderTop β] : DistribLattice (TopHom α β) :=
  FunLike.coe_injective.distribLattice _ (fun _ _ => rfl) fun _ _ => rfl

end TopHom

/-! ### Bot homomorphisms -/

namespace BotHom

variable [Bot α]

section Bot

variable [Bot β] [Bot γ] [Bot δ]

instance : BotHomClass (BotHom α β) α
      β where
  coe := BotHom.toFun
  coe_injective' f g h := by cases f; cases g; congr
  map_bot := BotHom.map_bot'

#noalign bot_hom.to_fun_eq_coe

-- this must come after the coe_to_fun definition
initialize_simps_projections BotHom (toFun → apply)

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

/-- Copy of a `BotHom` with a new `toFun` equal to the old one. Useful to fix definitional
equalities. -/
protected def copy (f : BotHom α β) (f' : α → β) (h : f' = f) :
    BotHom α β where
  toFun := f'
  map_bot' := h.symm ▸ f.map_bot'
#align bot_hom.copy BotHom.copy

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

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

instance : Inhabited (BotHom α β) :=
  ⟨⟨fun _ => ⊥, rfl⟩⟩

variable (α)

/-- `id` as a `BotHom`. -/
protected def id : BotHom α α :=
  ⟨id, rfl⟩
#align bot_hom.id BotHom.id

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

variable {α}

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

/-- Composition of `BotHom`s as a `BotHom`. -/
def comp (f : BotHom β γ) (g : BotHom α β) :
    BotHom α γ where
  toFun := f ∘ g
  map_bot' := by rw [comp_apply, map_bot, map_bot]
#align bot_hom.comp BotHom.comp

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

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

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

@[simp]
theorem comp_id (f : BotHom α β) : f.comp (BotHom.id α) = f :=
  BotHom.ext fun _ => rfl
#align bot_hom.comp_id BotHom.comp_id

@[simp]
theorem id_comp (f : BotHom α β) : (BotHom.id β).comp f = f :=
  BotHom.ext fun _ => rfl
#align bot_hom.id_comp BotHom.id_comp

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

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

end Bot

instance [Preorder β] [Bot β] : Preorder (BotHom α β) :=
  Preorder.lift (FunLike.coe : BotHom α β → α → β)

instance [PartialOrder β] [Bot β] : PartialOrder (BotHom α β) :=
  PartialOrder.lift _ FunLike.coe_injective

section OrderBot

variable [Preorder β] [OrderBot β]

instance : OrderBot (BotHom α β) where
  bot := ⟨⊥, rfl⟩
  bot_le := fun _ => @bot_le (α → β) _ _ _

@[simp]
theorem coe_bot : ⇑(⊥ : BotHom α β) = ⊥ :=
  rfl
#align bot_hom.coe_bot BotHom.coe_bot

@[simp]
theorem bot_apply (a : α) : (⊥ : BotHom α β) a = ⊥ :=
  rfl
#align bot_hom.bot_apply BotHom.bot_apply

end OrderBot

section SemilatticeInf

variable [SemilatticeInf β] [OrderBot β] (f g : BotHom α β)

instance : Inf (BotHom α β) :=
  ⟨fun f g => ⟨f ⊓ g, by rw [Pi.inf_apply, map_bot, map_bot, inf_bot_eq]⟩⟩

instance : SemilatticeInf (BotHom α β) :=
  (FunLike.coe_injective.semilatticeInf _) fun _ _ => rfl

@[simp]
theorem coe_inf : ⇑(f ⊓ g) = ⇑f ⊓ ⇑g :=
  rfl
#align bot_hom.coe_inf BotHom.coe_inf

@[simp]
theorem inf_apply (a : α) : (f ⊓ g) a = f a ⊓ g a :=
  rfl
#align bot_hom.inf_apply BotHom.inf_apply

end SemilatticeInf

section SemilatticeSup

variable [SemilatticeSup β] [OrderBot β] (f g : BotHom α β)

instance : Sup (BotHom α β) :=
  ⟨fun f g => ⟨f ⊔ g, by rw [Pi.sup_apply, map_bot, map_bot, sup_bot_eq]⟩⟩

instance : SemilatticeSup (BotHom α β) :=
  (FunLike.coe_injective.semilatticeSup _) fun _ _ => rfl

@[simp]
theorem coe_sup : ⇑(f ⊔ g) = ⇑f ⊔ ⇑g :=
  rfl
#align bot_hom.coe_sup BotHom.coe_sup

@[simp]
theorem sup_apply (a : α) : (f ⊔ g) a = f a ⊔ g a :=
  rfl
#align bot_hom.sup_apply BotHom.sup_apply

end SemilatticeSup

instance [Lattice β] [OrderBot β] : Lattice (BotHom α β) :=
  FunLike.coe_injective.lattice _ (fun _ _ => rfl) fun _ _ => rfl

instance [DistribLattice β] [OrderBot β] : DistribLattice (BotHom α β) :=
  FunLike.coe_injective.distribLattice _ (fun _ _ => rfl) fun _ _ => rfl

end BotHom

/-! ### Bounded order homomorphisms -/

-- Porting note: todo: remove this configuration and use the default configuration.
-- We keep this to be consistent with Lean 3.
initialize_simps_projections BoundedOrderHom (+toOrderHom, -toFun)

namespace BoundedOrderHom

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

/-- Reinterpret a `BoundedOrderHom` as a `TopHom`. -/
def toTopHom (f : BoundedOrderHom α β) : TopHom α β :=
  { f with }
#align bounded_order_hom.to_top_hom BoundedOrderHom.toTopHom

/-- Reinterpret a `BoundedOrderHom` as a `BotHom`. -/
def toBotHom (f : BoundedOrderHom α β) : BotHom α β :=
  { f with }
#align bounded_order_hom.to_bot_hom BoundedOrderHom.toBotHom

instance : BoundedOrderHomClass (BoundedOrderHom α β) α
      β where
  coe f := f.toFun
  coe_injective' f g h := by obtain ⟨⟨_, _⟩, _⟩ := f; obtain ⟨⟨_, _⟩, _⟩ := g; congr
  map_rel f := @(f.monotone')
  map_top f := f.map_top'
  map_bot f := f.map_bot'

#noalign bounded_order_hom.to_fun_eq_coe

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

/-- Copy of a `BoundedOrderHom` with a new `toFun` equal to the old one. Useful to fix
definitional equalities. -/
protected def copy (f : BoundedOrderHom α β) (f' : α → β) (h : f' = f) : BoundedOrderHom α β :=
  { f.toOrderHom.copy f' h, f.toTopHom.copy f' h, f.toBotHom.copy f' h with }
#align bounded_order_hom.copy BoundedOrderHom.copy

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

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

variable (α)

/-- `id` as a `BoundedOrderHom`. -/
protected def id : BoundedOrderHom α α :=
  { OrderHom.id, TopHom.id α, BotHom.id α with }
#align bounded_order_hom.id BoundedOrderHom.id

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

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

variable {α}

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

/-- Composition of `BoundedOrderHom`s as a `BoundedOrderHom`. -/
def comp (f : BoundedOrderHom β γ) (g : BoundedOrderHom α β) : BoundedOrderHom α γ :=
  { f.toOrderHom.comp g.toOrderHom, f.toTopHom.comp g.toTopHom, f.toBotHom.comp g.toBotHom with }
#align bounded_order_hom.comp BoundedOrderHom.comp

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

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

@[simp]
theorem coe_comp_orderHom (f : BoundedOrderHom β γ) (g : BoundedOrderHom α β) :
    (f.comp g : OrderHom α γ) = (f : OrderHom β γ).comp g :=
  rfl
#align bounded_order_hom.coe_comp_order_hom BoundedOrderHom.coe_comp_orderHom

@[simp]
theorem coe_comp_topHom (f : BoundedOrderHom β γ) (g : BoundedOrderHom α β) :
    (f.comp g : TopHom α γ) = (f : TopHom β γ).comp g :=
  rfl
#align bounded_order_hom.coe_comp_top_hom BoundedOrderHom.coe_comp_topHom

@[simp]
theorem coe_comp_botHom (f : BoundedOrderHom β γ) (g : BoundedOrderHom α β) :
    (f.comp g : BotHom α γ) = (f : BotHom β γ).comp g :=
  rfl
#align bounded_order_hom.coe_comp_bot_hom BoundedOrderHom.coe_comp_botHom

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

@[simp]
theorem comp_id (f : BoundedOrderHom α β) : f.comp (BoundedOrderHom.id α) = f :=
  BoundedOrderHom.ext fun _ => rfl
#align bounded_order_hom.comp_id BoundedOrderHom.comp_id

@[simp]
theorem id_comp (f : BoundedOrderHom α β) : (BoundedOrderHom.id β).comp f = f :=
  BoundedOrderHom.ext fun _ => rfl
#align bounded_order_hom.id_comp BoundedOrderHom.id_comp

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

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

end BoundedOrderHom

/-! ### Dual homs -/

namespace TopHom

variable [LE α] [OrderTop α] [LE β] [OrderTop β] [LE γ] [OrderTop γ]

/-- Reinterpret a top homomorphism as a bot homomorphism between the dual lattices. -/
@[simps]
protected def dual :
    TopHom α β ≃ BotHom αᵒᵈ βᵒᵈ where
  toFun f := ⟨f, f.map_top'⟩
  invFun f := ⟨f, f.map_bot'⟩
  left_inv _ := TopHom.ext fun _ => rfl
  right_inv _ := BotHom.ext fun _ => rfl
#align top_hom.dual TopHom.dual
#align top_hom.dual_apply_apply TopHom.dual_apply_apply
#align top_hom.dual_symm_apply_apply TopHom.dual_symm_apply_apply

@[simp]
theorem dual_id : TopHom.dual (TopHom.id α) = BotHom.id _ :=
  rfl
#align top_hom.dual_id TopHom.dual_id

@[simp]
theorem dual_comp (g : TopHom β γ) (f : TopHom α β) :
    TopHom.dual (g.comp f) = g.dual.comp (TopHom.dual f) :=
  rfl
#align top_hom.dual_comp TopHom.dual_comp

@[simp]
theorem symm_dual_id : TopHom.dual.symm (BotHom.id _) = TopHom.id α :=
  rfl
#align top_hom.symm_dual_id TopHom.symm_dual_id

@[simp]
theorem symm_dual_comp (g : BotHom βᵒᵈ γᵒᵈ) (f : BotHom αᵒᵈ βᵒᵈ) :
    TopHom.dual.symm (g.comp f) = (TopHom.dual.symm g).comp (TopHom.dual.symm f) :=
  rfl
#align top_hom.symm_dual_comp TopHom.symm_dual_comp

end TopHom

namespace BotHom

variable [LE α] [OrderBot α] [LE β] [OrderBot β] [LE γ] [OrderBot γ]

/-- Reinterpret a bot homomorphism as a top homomorphism between the dual lattices. -/
@[simps]
protected def dual :
    BotHom α β ≃ TopHom αᵒᵈ βᵒᵈ where
  toFun f := ⟨f, f.map_bot'⟩
  invFun f := ⟨f, f.map_top'⟩
  left_inv _ := BotHom.ext fun _ => rfl
  right_inv _ := TopHom.ext fun _ => rfl
#align bot_hom.dual BotHom.dual
#align bot_hom.dual_apply_apply BotHom.dual_apply_apply
#align bot_hom.dual_symm_apply_apply BotHom.dual_symm_apply_apply

@[simp]
theorem dual_id : BotHom.dual (BotHom.id α) = TopHom.id _ :=
  rfl
#align bot_hom.dual_id BotHom.dual_id

@[simp]
theorem dual_comp (g : BotHom β γ) (f : BotHom α β) :
    BotHom.dual (g.comp f) = g.dual.comp (BotHom.dual f) :=
  rfl
#align bot_hom.dual_comp BotHom.dual_comp

@[simp]
theorem symm_dual_id : BotHom.dual.symm (TopHom.id _) = BotHom.id α :=
  rfl
#align bot_hom.symm_dual_id BotHom.symm_dual_id

@[simp]
theorem symm_dual_comp (g : TopHom βᵒᵈ γᵒᵈ) (f : TopHom αᵒᵈ βᵒᵈ) :
    BotHom.dual.symm (g.comp f) = (BotHom.dual.symm g).comp (BotHom.dual.symm f) :=
  rfl
#align bot_hom.symm_dual_comp BotHom.symm_dual_comp

end BotHom

namespace BoundedOrderHom

variable [Preorder α] [BoundedOrder α] [Preorder β] [BoundedOrder β] [Preorder γ] [BoundedOrder γ]

/-- Reinterpret a bounded order homomorphism as a bounded order homomorphism between the dual
orders. -/
@[simps]
protected def dual :
    BoundedOrderHom α β ≃
      BoundedOrderHom αᵒᵈ
        βᵒᵈ where
  toFun f := ⟨OrderHom.dual f.toOrderHom, f.map_bot', f.map_top'⟩
  invFun f := ⟨OrderHom.dual.symm f.toOrderHom, f.map_bot', f.map_top'⟩
  left_inv _ := ext fun _ => rfl
  right_inv _ := ext fun _ => rfl
#align bounded_order_hom.dual BoundedOrderHom.dual
#align bounded_order_hom.dual_apply_to_order_hom BoundedOrderHom.dual_apply_toOrderHom
#align bounded_order_hom.dual_symm_apply_to_order_hom BoundedOrderHom.dual_symm_apply_toOrderHom

@[simp]
theorem dual_id : BoundedOrderHom.dual (BoundedOrderHom.id α) = BoundedOrderHom.id _ :=
  rfl
#align bounded_order_hom.dual_id BoundedOrderHom.dual_id

@[simp]
theorem dual_comp (g : BoundedOrderHom β γ) (f : BoundedOrderHom α β) :
    BoundedOrderHom.dual (g.comp f) = g.dual.comp (BoundedOrderHom.dual f) :=
  rfl
#align bounded_order_hom.dual_comp BoundedOrderHom.dual_comp

@[simp]
theorem symm_dual_id : BoundedOrderHom.dual.symm (BoundedOrderHom.id _) = BoundedOrderHom.id α :=
  rfl
#align bounded_order_hom.symm_dual_id BoundedOrderHom.symm_dual_id

@[simp]
theorem symm_dual_comp (g : BoundedOrderHom βᵒᵈ γᵒᵈ) (f : BoundedOrderHom αᵒᵈ βᵒᵈ) :
    BoundedOrderHom.dual.symm (g.comp f) =
      (BoundedOrderHom.dual.symm g).comp (BoundedOrderHom.dual.symm f) :=
  rfl
#align bounded_order_hom.symm_dual_comp BoundedOrderHom.symm_dual_comp

end BoundedOrderHom


/-
Copyright (c) 2021 Eric Wieser. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Eric Wieser
-/
import algebra.star.basic
import algebra.ring.pi
import algebra.module.pi

/-!
# `star` on pi types

We put a `has_star` structure on pi types that operates elementwise, such that it describes the
complex conjugation of vectors.
-/

universes u v w
variable {I : Type u}     -- The indexing type
variable {f : I → Type v} -- The family of types already equipped with instances

namespace pi

instance [Π i, has_star (f i)] : has_star (Π i, f i) :=
{ star := λ x i, star (x i) }

@[simp] lemma star_apply [Π i, has_star (f i)] (x : Π i, f i) (i : I) : star x i = star (x i) := rfl

lemma star_def [Π i, has_star (f i)] (x : Π i, f i) : star x = λ i, star (x i) := rfl

instance [Π i, has_involutive_star (f i)] : has_involutive_star (Π i, f i) :=
{ star_involutive := λ _, funext $ λ _, star_star _ }

instance [Π i, monoid (f i)] [Π i, star_monoid (f i)] : star_monoid (Π i, f i) :=
{ star_mul := λ _ _, funext $ λ _, star_mul _ _ }

instance [Π i, add_monoid (f i)] [Π i, star_add_monoid (f i)] : star_add_monoid (Π i, f i) :=
{ star_add := λ _ _, funext $ λ _, star_add _ _ }

instance [Π i, semiring (f i)] [Π i, star_ring (f i)] : star_ring (Π i, f i) :=
{ ..pi.star_add_monoid, ..(pi.star_monoid : star_monoid (Π i, f i)) }

instance {R : Type w}
  [Π i, has_scalar R (f i)] [has_star R] [Π i, has_star (f i)] [Π i, star_module R (f i)] :
  star_module R (Π i, f i) :=
{ star_smul := λ r x, funext $ λ i, star_smul r (x i) }

end pi


/-
Copyright (c) 2020 Jannis Limperg. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Jannis Limperg
-/
import data.list.of_fn
import data.list.range

/-!
# Lemmas about list.*_with_index functions.

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

Some specification lemmas for `list.map_with_index`, `list.mmap_with_index`, `list.foldl_with_index`
and `list.foldr_with_index`.
-/

universes u v

open function

namespace list

variables {α : Type u} {β : Type v}

section map_with_index

@[simp] lemma map_with_index_nil {α β} (f : ℕ → α → β) :
  map_with_index f [] = [] := rfl

lemma map_with_index_core_eq (l : list α) (f : ℕ → α → β) (n : ℕ) :
  l.map_with_index_core f n = l.map_with_index (λ i a, f (i + n) a) :=
begin
  induction l with hd tl hl generalizing f n,
  { simpa },
  { rw [map_with_index],
    simp [map_with_index_core, hl, add_left_comm, add_assoc, add_comm] }
end

lemma map_with_index_eq_enum_map (l : list α) (f : ℕ → α → β) :
  l.map_with_index f = l.enum.map (function.uncurry f) :=
begin
  induction l with hd tl hl generalizing f,
  { simp [list.enum_eq_zip_range] },
  { rw [map_with_index, map_with_index_core, map_with_index_core_eq, hl],
    simp [enum_eq_zip_range, range_succ_eq_map, zip_with_map_left,
    map_uncurry_zip_eq_zip_with] }
end

@[simp] lemma map_with_index_cons {α β} (l : list α) (f : ℕ → α → β) (a : α) :
  map_with_index f (a :: l) = f 0 a :: map_with_index (λ i, f (i + 1)) l :=
by simp [map_with_index_eq_enum_map, enum_eq_zip_range, map_uncurry_zip_eq_zip_with,
         range_succ_eq_map, zip_with_map_left]

lemma map_with_index_append {α} (K L : list α) (f : ℕ → α → β) :
  (K ++ L).map_with_index f = K.map_with_index f ++ L.map_with_index (λ i a, f (i + K.length) a) :=
begin
  induction K with a J IH generalizing f,
  { simp },
  { simp [IH (λ i, f (i+1)), add_assoc], }
end

@[simp] lemma length_map_with_index {α β} (l : list α) (f : ℕ → α → β) :
  (l.map_with_index f).length = l.length :=
begin
  induction l with hd tl IH generalizing f,
  { simp },
  { simp [IH] }
end

@[simp] lemma nth_le_map_with_index {α β} (l : list α) (f : ℕ → α → β) (i : ℕ) (h : i < l.length)
  (h' : i < (l.map_with_index f).length := h.trans_le (l.length_map_with_index f).ge):
  (l.map_with_index f).nth_le i h' = f i (l.nth_le i h) :=
by simp [map_with_index_eq_enum_map, enum_eq_zip_range]

lemma map_with_index_eq_of_fn {α β} (l : list α) (f : ℕ → α → β) :
  l.map_with_index f = of_fn (λ (i : fin l.length), f (i : ℕ) (l.nth_le i i.is_lt)) :=
begin
  induction l with hd tl IH generalizing f,
  { simp },
  { simpa [IH] }
end

end map_with_index

section foldr_with_index

/-- Specification of `foldr_with_index_aux`. -/
def foldr_with_index_aux_spec (f : ℕ → α → β → β) (start : ℕ) (b : β)
  (as : list α) : β :=
foldr (uncurry f) b $ enum_from start as

theorem foldr_with_index_aux_spec_cons (f : ℕ → α → β → β) (start b a as) :
  foldr_with_index_aux_spec f start b (a :: as) =
  f start a (foldr_with_index_aux_spec f (start + 1) b as) :=
rfl

theorem foldr_with_index_aux_eq_foldr_with_index_aux_spec (f : ℕ → α → β → β)
  (start b as) :
  foldr_with_index_aux f start b as = foldr_with_index_aux_spec f start b as :=
begin
  induction as generalizing start,
  { refl },
  { simp only [foldr_with_index_aux, foldr_with_index_aux_spec_cons, *] }
end

theorem foldr_with_index_eq_foldr_enum (f : ℕ → α → β → β) (b : β) (as : list α) :
  foldr_with_index f b as = foldr (uncurry f) b (enum as) :=
by simp only
    [foldr_with_index, foldr_with_index_aux_spec,
     foldr_with_index_aux_eq_foldr_with_index_aux_spec, enum]

end foldr_with_index

theorem indexes_values_eq_filter_enum (p : α → Prop) [decidable_pred p]
  (as : list α) :
  indexes_values p as = filter (p ∘ prod.snd) (enum as) :=
by simp [indexes_values, foldr_with_index_eq_foldr_enum, uncurry, filter_eq_foldr]

theorem find_indexes_eq_map_indexes_values (p : α → Prop) [decidable_pred p]
  (as : list α) :
  find_indexes p as = map prod.fst (indexes_values p as) :=
by simp only
    [indexes_values_eq_filter_enum, map_filter_eq_foldr, find_indexes,
     foldr_with_index_eq_foldr_enum, uncurry]

section foldl_with_index

/-- Specification of `foldl_with_index_aux`. -/
def foldl_with_index_aux_spec (f : ℕ → α → β → α) (start : ℕ) (a : α)
  (bs : list β) : α :=
foldl (λ a (p : ℕ × β), f p.fst a p.snd) a $ enum_from start bs

theorem foldl_with_index_aux_spec_cons (f : ℕ → α → β → α) (start a b bs) :
  foldl_with_index_aux_spec f start a (b :: bs) =
  foldl_with_index_aux_spec f (start + 1) (f start a b) bs :=
rfl

theorem foldl_with_index_aux_eq_foldl_with_index_aux_spec (f : ℕ → α → β → α)
  (start a bs) :
  foldl_with_index_aux f start a bs = foldl_with_index_aux_spec f start a bs :=
begin
  induction bs generalizing start a,
  { refl },
  { simp [foldl_with_index_aux, foldl_with_index_aux_spec_cons, *] }
end

theorem foldl_with_index_eq_foldl_enum (f : ℕ → α → β → α) (a : α) (bs : list β) :
  foldl_with_index f a bs =
  foldl (λ a (p : ℕ × β), f p.fst a p.snd) a (enum bs) :=
by simp only
    [foldl_with_index, foldl_with_index_aux_spec,
     foldl_with_index_aux_eq_foldl_with_index_aux_spec, enum]

end foldl_with_index

section mfold_with_index

variables {m : Type u → Type v} [monad m]

theorem mfoldr_with_index_eq_mfoldr_enum {α β} (f : ℕ → α → β → m β) (b : β) (as : list α) :
  mfoldr_with_index f b as = mfoldr (uncurry f) b (enum as) :=
by simp only
    [mfoldr_with_index, mfoldr_eq_foldr, foldr_with_index_eq_foldr_enum, uncurry]

theorem mfoldl_with_index_eq_mfoldl_enum [is_lawful_monad m] {α β}
  (f : ℕ → β → α → m β) (b : β) (as : list α) :
  mfoldl_with_index f b as =
    mfoldl (λ b (p : ℕ × α), f p.fst b p.snd) b (enum as) :=
by rw [mfoldl_with_index, mfoldl_eq_foldl, foldl_with_index_eq_foldl_enum]

end mfold_with_index

section mmap_with_index

variables {m : Type u → Type v} [applicative m]

/-- Specification of `mmap_with_index_aux`. -/
def mmap_with_index_aux_spec {α β} (f : ℕ → α → m β) (start : ℕ) (as : list α) :
  m (list β) :=
list.traverse (uncurry f) $ enum_from start as
-- Note: `traverse` the class method would require a less universe-polymorphic
-- `m : Type u → Type u`.

theorem mmap_with_index_aux_spec_cons {α β} (f : ℕ → α → m β) (start : ℕ)
  (a : α) (as : list α) :
  mmap_with_index_aux_spec f start (a :: as) =
    list.cons <$> f start a <*> mmap_with_index_aux_spec f (start + 1) as :=
rfl

theorem mmap_with_index_aux_eq_mmap_with_index_aux_spec {α β} (f : ℕ → α → m β)
  (start : ℕ) (as : list α) :
  mmap_with_index_aux f start as = mmap_with_index_aux_spec f start as :=
begin
  induction as generalizing start,
  { refl },
  { simp [mmap_with_index_aux, mmap_with_index_aux_spec_cons, *] }
end

theorem mmap_with_index_eq_mmap_enum {α β} (f : ℕ → α → m β) (as : list α) :
  mmap_with_index f as = list.traverse (uncurry f) (enum as) :=
by simp only
    [mmap_with_index, mmap_with_index_aux_spec,
     mmap_with_index_aux_eq_mmap_with_index_aux_spec, enum ]

end mmap_with_index

section mmap_with_index'

variables {m : Type u → Type v} [applicative m] [is_lawful_applicative m]

theorem mmap_with_index'_aux_eq_mmap_with_index_aux {α} (f : ℕ → α → m punit)
  (start : ℕ) (as : list α) :
  mmap_with_index'_aux f start as =
  mmap_with_index_aux f start as *> pure punit.star :=
by induction as generalizing start;
    simp [mmap_with_index'_aux, mmap_with_index_aux, *, seq_right_eq, const, -comp_const]
      with functor_norm

theorem mmap_with_index'_eq_mmap_with_index {α} (f : ℕ → α → m punit) (as : list α) :
  mmap_with_index' f as = mmap_with_index f as *> pure punit.star :=
by apply mmap_with_index'_aux_eq_mmap_with_index_aux

end mmap_with_index'

end list


/-
Copyright (c) 2017 Mario Carneiro. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Mario Carneiro
-/
import data.fin.fin2
import tactic.localized

/-!
# Alternate definition of `vector` in terms of `fin2`

This file provides a locale `vector3` which overrides the `[a, b, c]` notation to create a `vector3`
instead of a `list`.

The `::` notation is also overloaded by this file to mean `vector3.cons`.
-/

open fin2 nat

universes u
variables {α : Type*} {m n : ℕ}

/-- Alternate definition of `vector` based on `fin2`. -/
def vector3 (α : Type u) (n : ℕ) : Type u := fin2 n → α

instance [inhabited α] : inhabited (vector3 α n) := pi.inhabited _

namespace vector3

/-- The empty vector -/
@[pattern] def nil : vector3 α 0.

/-- The vector cons operation -/
@[pattern] def cons (a : α) (v : vector3 α n) : vector3 α (succ n) :=
λ i, by { refine i.cases' _ _, exact a, exact v }

/- We do not want to make the following notation global, because then these expressions will be
overloaded, and only the expected type will be able to disambiguate the meaning. Worse: Lean will
try to insert a coercion from `vector3 α _` to `list α`, if a list is expected. -/
localized "notation `[` l:(foldr `, ` (h t, vector3.cons h t) vector3.nil `]`) := l" in vector3
notation a :: b := cons a b

@[simp] lemma cons_fz (a : α) (v : vector3 α n) : (a :: v) fz = a := rfl
@[simp] lemma cons_fs (a : α) (v : vector3 α n) (i) : (a :: v) (fs i) = v i := rfl

/-- Get the `i`th element of a vector -/
@[reducible] def nth (i : fin2 n) (v : vector3 α n) : α := v i

/-- Construct a vector from a function on `fin2`. -/
@[reducible] def of_fn (f : fin2 n → α) : vector3 α n := f

/-- Get the head of a nonempty vector. -/
def head (v : vector3 α (succ n)) : α := v fz

/-- Get the tail of a nonempty vector. -/
def tail (v : vector3 α (succ n)) : vector3 α n := λ i, v (fs i)

lemma eq_nil (v : vector3 α 0) : v = [] := funext $ λ i, match i with end

lemma cons_head_tail (v : vector3 α (succ n)) : head v :: tail v = v :=
funext $ λ i, fin2.cases' rfl (λ _, rfl) i

/-- Eliminator for an empty vector. -/
def nil_elim {C : vector3 α 0 → Sort u} (H : C []) (v : vector3 α 0) : C v :=
by rw eq_nil v; apply H

/-- Recursion principle for a nonempty vector. -/
def cons_elim {C : vector3 α (succ n) → Sort u} (H : Π (a : α) (t : vector3 α n), C (a :: t))
  (v : vector3 α (succ n)) : C v :=
by rw ← (cons_head_tail v); apply H

@[simp] lemma cons_elim_cons {C H a t} : @cons_elim α n C H (a :: t) = H a t := rfl

/-- Recursion principle with the vector as first argument. -/
@[elab_as_eliminator]
protected def rec_on {C : Π {n}, vector3 α n → Sort u} {n} (v : vector3 α n)
  (H0 : C [])
  (Hs : Π {n} (a) (w : vector3 α n), C w → C (a :: w)) : C v :=
nat.rec_on n
  (λ v, v.nil_elim H0)
  (λ n IH v, v.cons_elim (λ a t, Hs _ _ (IH _))) v

@[simp] lemma rec_on_nil {C H0 Hs} : @vector3.rec_on α @C 0 [] H0 @Hs = H0 := rfl

@[simp] lemma rec_on_cons {C H0 Hs n a v} :
  @vector3.rec_on α @C (succ n) (a :: v) H0 @Hs = Hs a v (@vector3.rec_on α @C n v H0 @Hs) :=
rfl

/-- Append two vectors -/
def append (v : vector3 α m) (w : vector3 α n) : vector3 α (n+m) :=
nat.rec_on m (λ _, w) (λ m IH v, v.cons_elim $ λ a t, @fin2.cases' (n+m) (λ _, α) a (IH t)) v

local infix ` +-+ `:65 := vector3.append

@[simp] lemma append_nil (w : vector3 α n) : [] +-+ w = w := rfl

@[simp] lemma append_cons (a : α) (v : vector3 α m) (w : vector3 α n) :
  (a :: v) +-+ w = a :: (v +-+ w) := rfl

@[simp] lemma append_left : ∀ {m} (i : fin2 m) (v : vector3 α m) {n} (w : vector3 α n),
  (v +-+ w) (left n i) = v i
| ._ (@fz m)   v n w := v.cons_elim (λ a t, by simp [*, left])
| ._ (@fs m i) v n w := v.cons_elim (λ a t, by simp [*, left])

@[simp] lemma append_add : ∀ {m} (v : vector3 α m) {n} (w : vector3 α n) (i : fin2 n),
  (v +-+ w) (add i m) = w i
| 0        v n w i := rfl
| (succ m) v n w i := v.cons_elim (λ a t, by simp [*, add])

/-- Insert `a` into `v` at index `i`. -/
def insert (a : α) (v : vector3 α n) (i : fin2 (succ n)) : vector3 α (succ n) :=
λ j, (a :: v) (insert_perm i j)

@[simp] lemma insert_fz (a : α) (v : vector3 α n) : insert a v fz = a :: v :=
by refine funext (λ j, j.cases' _ _); intros; refl

@[simp] lemma insert_fs (a : α) (b : α) (v : vector3 α n) (i : fin2 (succ n)) :
  insert a (b :: v) (fs i) = b :: insert a v i :=
funext $ λ j, by
{ refine j.cases' _ (λ j, _); simp [insert, insert_perm],
  refine fin2.cases' _ _ (insert_perm i j); simp [insert_perm] }

lemma append_insert (a : α) (t : vector3 α m) (v : vector3 α n) (i : fin2 (succ n))
  (e : succ n + m = succ (n + m)) :
  insert a (t +-+ v) (eq.rec_on e (i.add m)) = eq.rec_on e (t +-+ insert a v i) :=
begin
  refine vector3.rec_on t (λ e, _) (λ k b t IH e, _) e, refl,
  have e' := succ_add n k,
  change insert a (b :: (t +-+ v)) (eq.rec_on (congr_arg succ e') (fs (add i k)))
    = eq.rec_on (congr_arg succ e') (b :: (t +-+ insert a v i)),
  rw ← (eq.drec_on e' rfl : fs (eq.rec_on e' (i.add k) : fin2 (succ (n + k))) = eq.rec_on
    (congr_arg succ e') (fs (i.add k))),
  simp, rw IH, exact eq.drec_on e' rfl
end

end vector3

section vector3
open vector3
open_locale vector3

/-- "Curried" exists, i.e. `∃ x₁ ... xₙ, f [x₁, ..., xₙ]`. -/
def vector_ex : Π k, (vector3 α k → Prop) → Prop
| 0        f := f []
| (succ k) f := ∃x : α, vector_ex k (λ v, f (x :: v))

/-- "Curried" forall, i.e. `∀ x₁ ... xₙ, f [x₁, ..., xₙ]`. -/
def vector_all : Π k, (vector3 α k → Prop) → Prop
| 0        f := f []
| (succ k) f := ∀ x : α, vector_all k (λ v, f (x :: v))

lemma exists_vector_zero (f : vector3 α 0 → Prop) : Exists f ↔ f [] :=
⟨λ ⟨v, fv⟩, by rw ← (eq_nil v); exact fv, λ f0, ⟨[], f0⟩⟩

lemma exists_vector_succ (f : vector3 α (succ n) → Prop) : Exists f ↔ ∃x v, f (x :: v) :=
⟨λ ⟨v, fv⟩, ⟨_, _, by rw cons_head_tail v; exact fv⟩, λ ⟨x, v, fxv⟩, ⟨_, fxv⟩⟩

lemma vector_ex_iff_exists : ∀ {n} (f : vector3 α n → Prop), vector_ex n f ↔ Exists f
| 0        f := (exists_vector_zero f).symm
| (succ n) f := iff.trans (exists_congr (λ x, vector_ex_iff_exists _)) (exists_vector_succ f).symm

lemma vector_all_iff_forall : ∀ {n} (f : vector3 α n → Prop), vector_all n f ↔ ∀ v, f v
| 0        f := ⟨λ f0 v, v.nil_elim f0, λ al, al []⟩
| (succ n) f := (forall_congr (λ x, vector_all_iff_forall (λ v, f (x :: v)))).trans
  ⟨λ al v, v.cons_elim al, λ al x v, al (x :: v)⟩

/-- `vector_allp p v` is equivalent to `∀ i, p (v i)`, but unfolds directly to a conjunction,
  i.e. `vector_allp p [0, 1, 2] = p 0 ∧ p 1 ∧ p 2`. -/
def vector_allp (p : α → Prop) (v : vector3 α n) : Prop :=
vector3.rec_on v true (λ n a v IH, @vector3.rec_on _ (λ n v, Prop) _ v (p a) (λ n b v' _, p a ∧ IH))

@[simp] lemma vector_allp_nil (p : α → Prop) : vector_allp p [] = true := rfl
@[simp] lemma vector_allp_singleton (p : α → Prop) (x : α) : vector_allp p [x] = p x := rfl
@[simp] lemma vector_allp_cons (p : α → Prop) (x : α) (v : vector3 α n) :
  vector_allp p (x :: v) ↔ p x ∧ vector_allp p v :=
vector3.rec_on v (and_true _).symm (λ n a v IH, iff.rfl)

lemma vector_allp_iff_forall (p : α → Prop) (v : vector3 α n) : vector_allp p v ↔ ∀ i, p (v i) :=
begin
  refine v.rec_on _ _,
  { exact ⟨λ _, fin2.elim0, λ _, trivial⟩ },
  { simp, refine λ n a v IH, (and_congr_right (λ _, IH)).trans
      ⟨λ ⟨pa, h⟩ i, by {refine i.cases' _ _, exacts [pa, h]}, λ h, ⟨_, λ i, _⟩⟩,
    { have h0 := h fz, simp at h0, exact h0 },
    { have hs := h (fs i), simp at hs, exact hs } }
end

lemma vector_allp.imp {p q : α → Prop} (h : ∀ x, p x → q x) {v : vector3 α n}
  (al : vector_allp p v) : vector_allp q v :=
(vector_allp_iff_forall _ _).2 (λ i, h _ $ (vector_allp_iff_forall _ _).1 al _)

end vector3


/-
Copyright (c) 2020 Simon Hudon. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Simon Hudon

! This file was ported from Lean 3 source module control.fix
! leanprover-community/mathlib commit 207cfac9fcd06138865b5d04f7091e46d9320432
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathlib.Data.Part
import Mathlib.Data.Nat.Upto
import Mathlib.Data.Stream.Defs

/-!
# Fixed point

This module defines a generic `fix` operator for defining recursive
computations that are not necessarily well-founded or productive.
An instance is defined for `Part`.

## Main definition

 * class `Fix`
 * `Part.fix`
-/

universe u v

open Classical

variable {α : Type _} {β : α → Type _}

/-- `Fix α` provides a `fix` operator to define recursive computatiation
via the fixed point of function of type `α → α`. -/
class Fix (α : Type _) where
  /-- `fix f` represents the computation of a fixed point for `f`.-/
  fix : (α → α) → α
#align has_fix Fix

namespace Part

open Part Nat Nat.Upto

section Basic

variable (f : (∀ a, Part (β a)) → (∀ a, Part (β a)))

/-- A series of successive, finite approximation of the fixed point of `f`, defined by
`approx f n = f^[n] ⊥`. The limit of this chain is the fixed point of `f`. -/
def Fix.approx : Stream' (∀ a, Part (β a))
  | 0 => ⊥
  | Nat.succ i => f (Fix.approx i)
#align part.fix.approx Part.Fix.approx

/-- loop body for finding the fixed point of `f` -/
def fixAux {p : ℕ → Prop} (i : Nat.Upto p) (g : ∀ j : Nat.Upto p, i < j → ∀ a, Part (β a)) :
    ∀ a, Part (β a) :=
  f fun x : α => (assert ¬p i.val) fun h : ¬p i.val => g (i.succ h) (Nat.lt_succ_self _) x
#align part.fix_aux Part.fixAux

/-- The least fixed point of `f`.

If `f` is a continuous function (according to complete partial orders),
it satisfies the equations:

  1. `fix f = f (fix f)`          (is a fixed point)
  2. `∀ X, f X ≤ X → fix f ≤ X`   (least fixed point)
-/
-- porting note: added noncomputable, because WellFounded.fix is noncomputable (for now?)
protected noncomputable def fix (x : α) : Part (β x) :=
  (Part.assert (∃ i, (Fix.approx f i x).Dom)) fun h =>
    WellFounded.fix.{1} (Nat.Upto.wf h) (fixAux f) Nat.Upto.zero x
#align part.fix Part.fix

protected theorem fix_def {x : α} (h' : ∃ i, (Fix.approx f i x).Dom) :
    Part.fix f x = Fix.approx f (Nat.succ (Nat.find h')) x := by
  let p := fun i : ℕ => (Fix.approx f i x).Dom
  have : p (Nat.find h') := Nat.find_spec h'
  generalize hk : Nat.find h' = k
  replace hk : Nat.find h' = k + (@Upto.zero p).val := hk
  rw [hk] at this
  revert hk
  dsimp [Part.fix]; rw [assert_pos h']; revert this
  generalize Upto.zero = z; intro _this hk
  suffices : ∀ x',
    WellFounded.fix (Part.fix.proof_1 f x h') (fixAux f) z x' = Fix.approx f (succ k) x'
  exact this _
  induction k generalizing z with
  | zero =>
    intro x'
    rw [Fix.approx, WellFounded.fix_eq, fixAux]
    congr
    ext x: 1
    rw [assert_neg]
    rfl
    rw [Nat.zero_add] at _this
    simpa only [not_not, Coe]
  | succ n n_ih =>
    intro x'
    rw [Fix.approx, WellFounded.fix_eq, fixAux]
    congr
    ext : 1
    have hh : ¬(Fix.approx f z.val x).Dom := by
      apply Nat.find_min h'
      rw [hk, Nat.succ_add, ← Nat.add_succ]
      apply Nat.lt_of_succ_le
      apply Nat.le_add_left
    rw [succ_add_eq_succ_add] at _this hk
    rw [assert_pos hh, n_ih (Upto.succ z hh) _this hk]
#align part.fix_def Part.fix_def

theorem fix_def' {x : α} (h' : ¬∃ i, (Fix.approx f i x).Dom) : Part.fix f x = none := by
  dsimp [Part.fix]
  rw [assert_neg h']
#align part.fix_def' Part.fix_def'

end Basic

end Part

namespace Part

-- porting note: added noncomputable, because WellFounded.fix is noncomputable (for now?)
noncomputable instance : Fix (Part α) :=
  ⟨fun f => Part.fix (fun x u => f (x u)) ()⟩

end Part

open Sigma

namespace Pi

-- porting note: added noncomputable, because WellFounded.fix is noncomputable (for now?)
noncomputable instance Part.hasFix {β} : Fix (α → Part β) :=
  ⟨Part.fix⟩
#align pi.part.has_fix Pi.Part.hasFix

end Pi


example (x : Nat × Nat) : x.1 + x.2 ≥ 0 :=
  let (a, b) := x
  _

example (x : Nat × Nat) : x.1 + x.2 ≥ 0 :=
  have (a, b) := x
  _

example (x : Nat × Nat) : x.1 + x.2 ≥ 0 := by
  let (a, b) := x
  done

example (x : Nat × Nat) : x.1 + x.2 ≥ 0 := by
  have (a, b) := x
  done

def f : Nat × Nat → Nat
  | (a, b) => a + b + 1

example (x : Nat × Nat) : f x > 0 := by
  let (a, b) := x
  done


/-
Copyright (c) 2018 Simon Hudon. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Author: Simon Hudon

Functors with two arguments
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.logic.function.basic
import Mathlib.control.functor
import Mathlib.tactic.core
import Mathlib.PostPort

universes u₀ u₁ u₂ l l_3 l_2 l_1 u_1 u_2

namespace Mathlib

class bifunctor (F : Type u₀ → Type u₁ → Type u₂)
where
  bimap : {α α' : Type u₀} → {β β' : Type u₁} → (α → α') → (β → β') → F α β → F α' β'

class is_lawful_bifunctor (F : Type u₀ → Type u₁ → Type u₂) [bifunctor F]
where
  id_bimap : ∀ {α : Type u₀} {β : Type u₁} (x : F α β), bimap id id x = x
  bimap_bimap : ∀ {α₀ α₁ α₂ : Type u₀} {β₀ β₁ β₂ : Type u₁} (f : α₀ → α₁) (f' : α₁ → α₂) (g : β₀ → β₁) (g' : β₁ → β₂) (x : F α₀ β₀),
  bimap f' g' (bimap f g x) = bimap (f' ∘ f) (g' ∘ g) x

theorem is_lawful_bifunctor.bimap_id_id {F : Type l_3 → Type l_2 → Type l_1} [bifunctor F] [c : is_lawful_bifunctor F] {α : Type l_3} {β : Type l_2} : bimap id id = id :=
  funext fun (x : F α β) => id_bimap x

theorem is_lawful_bifunctor.bimap_comp_bimap {F : Type l_3 → Type l_2 → Type l_1} [bifunctor F] [c : is_lawful_bifunctor F] {α₀ : Type l_3} {α₁ : Type l_3} {α₂ : Type l_3} {β₀ : Type l_2} {β₁ : Type l_2} {β₂ : Type l_2} (f : α₀ → α₁) (f' : α₁ → α₂) (g : β₀ → β₁) (g' : β₁ → β₂) : bimap f' g' ∘ bimap f g = bimap (f' ∘ f) (g' ∘ g) :=
  funext fun (x : F α₀ β₀) => bimap_bimap f f' g g' x

namespace bifunctor

def fst {F : Type u₀ → Type u₁ → Type u₂} [bifunctor F] {α : Type u₀} {α' : Type u₀} {β : Type u₁} (f : α → α') : F α β → F α' β :=
  bimap f id

def snd {F : Type u₀ → Type u₁ → Type u₂} [bifunctor F] {α : Type u₀} {β : Type u₁} {β' : Type u₁} (f : β → β') : F α β → F α β' :=
  bimap id f

theorem id_fst {F : Type u₀ → Type u₁ → Type u₂} [bifunctor F] [is_lawful_bifunctor F] {α : Type u₀} {β : Type u₁} (x : F α β) : fst id x = x :=
  id_bimap

theorem snd_id {F : Type l_3 → Type l_2 → Type l_1} [bifunctor F] [is_lawful_bifunctor F] {α : Type l_3} {β : Type l_2} : snd id = id :=
  funext fun (x : F α β) => id_snd x

theorem comp_fst {F : Type u₀ → Type u₁ → Type u₂} [bifunctor F] [is_lawful_bifunctor F] {α₀ : Type u₀} {α₁ : Type u₀} {α₂ : Type u₀} {β : Type u₁} (f : α₀ → α₁) (f' : α₁ → α₂) (x : F α₀ β) : fst f' (fst f x) = fst (f' ∘ f) x := sorry

theorem fst_snd {F : Type u₀ → Type u₁ → Type u₂} [bifunctor F] [is_lawful_bifunctor F] {α₀ : Type u₀} {α₁ : Type u₀} {β₀ : Type u₁} {β₁ : Type u₁} (f : α₀ → α₁) (f' : β₀ → β₁) (x : F α₀ β₀) : fst f (snd f' x) = bimap f f' x := sorry

theorem snd_comp_fst {F : Type l_3 → Type l_2 → Type l_1} [bifunctor F] [is_lawful_bifunctor F] {α₀ : Type l_3} {α₁ : Type l_3} {β₀ : Type l_2} {β₁ : Type l_2} (f : α₀ → α₁) (f' : β₀ → β₁) : snd f' ∘ fst f = bimap f f' :=
  funext fun (x : F α₀ β₀) => snd_fst f f' x

theorem comp_snd {F : Type u₀ → Type u₁ → Type u₂} [bifunctor F] [is_lawful_bifunctor F] {α : Type u₀} {β₀ : Type u₁} {β₁ : Type u₁} {β₂ : Type u₁} (g : β₀ → β₁) (g' : β₁ → β₂) (x : F α β₀) : snd g' (snd g x) = snd (g' ∘ g) x := sorry

end bifunctor

protected instance prod.bifunctor : bifunctor Prod :=
  bifunctor.mk prod.map

protected instance prod.is_lawful_bifunctor : is_lawful_bifunctor Prod :=
  is_lawful_bifunctor.mk sorry sorry

protected instance bifunctor.const : bifunctor functor.const :=
  bifunctor.mk fun (α α' : Type u_1) (β β_1 : Type u_2) (f : α → α') (_x : β → β_1) => f

protected instance is_lawful_bifunctor.const : is_lawful_bifunctor functor.const :=
  is_lawful_bifunctor.mk sorry sorry

protected instance bifunctor.flip {F : Type u₀ → Type u₁ → Type u₂} [bifunctor F] : bifunctor (flip F) :=
  bifunctor.mk fun (α α' : Type u₁) (β β' : Type u₀) (f : α → α') (f' : β → β') (x : flip F α β) => bimap f' f x

protected instance is_lawful_bifunctor.flip {F : Type u₀ → Type u₁ → Type u₂} [bifunctor F] [is_lawful_bifunctor F] : is_lawful_bifunctor (flip F) :=
  is_lawful_bifunctor.mk sorry sorry

protected instance sum.bifunctor : bifunctor sum :=
  bifunctor.mk sum.map

protected instance sum.is_lawful_bifunctor : is_lawful_bifunctor sum :=
  is_lawful_bifunctor.mk sorry sorry

protected instance bifunctor.functor {F : Type u₀ → Type u₁ → Type u₂} [bifunctor F] {α : Type u₀} : Functor (F α) :=
  { map := fun (_x _x_1 : Type u₁) => bifunctor.snd,
    mapConst := fun (α_1 β : Type u₁) => bifunctor.snd ∘ function.const β }

protected instance bifunctor.is_lawful_functor {F : Type u₀ → Type u₁ → Type u₂} [bifunctor F] [is_lawful_bifunctor F] {α : Type u₀} : is_lawful_functor (F α) :=
  is_lawful_functor.mk
    (fun (α_1 : Type u₁) (x : F α α_1) =>
      eq.mpr
        (id
          (Eq.trans
            ((fun (a a_1 : F α α_1) (e_1 : a = a_1) (ᾰ ᾰ_1 : F α α_1) (e_2 : ᾰ = ᾰ_1) => congr (congr_arg Eq e_1) e_2)
              (id <$> x) x (Eq.trans (congr_fun bifunctor.snd_id x) (id.def x)) x x (Eq.refl x))
            (propext (eq_self_iff_true x))))
        trivial)
    fun (α_1 β γ : Type u₁) (g : α_1 → β) (h : β → γ) (x : F α α_1) =>
      eq.mpr
        (id
          (Eq.trans
            ((fun (a a_1 : F α γ) (e_1 : a = a_1) (ᾰ ᾰ_1 : F α γ) (e_2 : ᾰ = ᾰ_1) => congr (congr_arg Eq e_1) e_2)
              ((h ∘ g) <$> x) (bifunctor.snd (h ∘ g) x) (Eq.refl (bifunctor.snd (h ∘ g) x)) (h <$> g <$> x)
              (bifunctor.snd (h ∘ g) x) (bifunctor.comp_snd g h x))
            (propext (eq_self_iff_true (bifunctor.snd (h ∘ g) x)))))
        trivial

protected instance function.bicompl.bifunctor {F : Type u₀ → Type u₁ → Type u₂} [bifunctor F] (G : Type u_1 → Type u₀) (H : Type u_2 → Type u₁) [Functor G] [Functor H] : bifunctor (function.bicompl F G H) :=
  bifunctor.mk
    fun (α α' : Type u_1) (β β' : Type u_2) (f : α → α') (f' : β → β') (x : function.bicompl F G H α β) =>
      bimap (Functor.map f) (Functor.map f') x

protected instance function.bicompl.is_lawful_bifunctor {F : Type u₀ → Type u₁ → Type u₂} [bifunctor F] (G : Type u_1 → Type u₀) (H : Type u_2 → Type u₁) [Functor G] [Functor H] [is_lawful_functor G] [is_lawful_functor H] [is_lawful_bifunctor F] : is_lawful_bifunctor (function.bicompl F G H) :=
  is_lawful_bifunctor.mk sorry sorry

protected instance function.bicompr.bifunctor {F : Type u₀ → Type u₁ → Type u₂} [bifunctor F] (G : Type u₂ → Type u_1) [Functor G] : bifunctor (function.bicompr G F) :=
  bifunctor.mk
    fun (α α' : Type u₀) (β β' : Type u₁) (f : α → α') (f' : β → β') (x : function.bicompr G F α β) => bimap f f' <$> x

protected instance function.bicompr.is_lawful_bifunctor {F : Type u₀ → Type u₁ → Type u₂} [bifunctor F] (G : Type u₂ → Type u_1) [Functor G] [is_lawful_functor G] [is_lawful_bifunctor F] : is_lawful_bifunctor (function.bicompr G F) :=
  is_lawful_bifunctor.mk sorry sorry


/-
Copyright (c) 2020 Kenny Lau. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Kenny Lau
-/

import algebra.geom_sum
import linear_algebra.smodeq
import ring_theory.jacobson_ideal

/-!
# Completion of a module with respect to an ideal.

In this file we define the notions of Hausdorff, precomplete, and complete for an `R`-module `M`
with respect to an ideal `I`:

## Main definitions

- `is_Hausdorff I M`: this says that the intersection of `I^n M` is `0`.
- `is_precomplete I M`: this says that every Cauchy sequence converges.
- `is_adic_complete I M`: this says that `M` is Hausdorff and precomplete.
- `Hausdorffification I M`: this is the universal Hausdorff module with a map from `M`.
- `completion I M`: if `I` is finitely generated, then this is the universal complete module (TODO)
  with a map from `M`. This map is injective iff `M` is Hausdorff and surjective iff `M` is
  precomplete.

-/

open submodule

variables {R : Type*} [comm_ring R] (I : ideal R)
variables (M : Type*) [add_comm_group M] [module R M]
variables {N : Type*} [add_comm_group N] [module R N]

/-- A module `M` is Hausdorff with respect to an ideal `I` if `⋂ I^n M = 0`. -/
class is_Hausdorff : Prop :=
(haus' : ∀ x : M, (∀ n : ℕ, x ≡ 0 [SMOD (I ^ n • ⊤ : submodule R M)]) → x = 0)

/-- A module `M` is precomplete with respect to an ideal `I` if every Cauchy sequence converges. -/
class is_precomplete : Prop :=
(prec' : ∀ f : ℕ → M,
  (∀ {m n}, m ≤ n → f m ≡ f n [SMOD (I ^ m • ⊤ : submodule R M)]) →
  ∃ L : M, ∀ n, f n ≡ L [SMOD (I ^ n • ⊤ : submodule R M)])

/-- A module `M` is `I`-adically complete if it is Hausdorff and precomplete. -/
class is_adic_complete extends is_Hausdorff I M, is_precomplete I M : Prop

variables {I M}

theorem is_Hausdorff.haus (h : is_Hausdorff I M) :
  ∀ x : M, (∀ n : ℕ, x ≡ 0 [SMOD (I ^ n • ⊤ : submodule R M)]) → x = 0 := is_Hausdorff.haus'

theorem is_Hausdorff_iff : is_Hausdorff I M ↔
  ∀ x : M, (∀ n : ℕ, x ≡ 0 [SMOD (I ^ n • ⊤ : submodule R M)]) → x = 0 :=
⟨is_Hausdorff.haus, λ h, ⟨h⟩⟩

theorem is_precomplete.prec (h : is_precomplete I M) {f : ℕ → M} :
  (∀ {m n}, m ≤ n → f m ≡ f n [SMOD (I ^ m • ⊤ : submodule R M)]) →
  ∃ L : M, ∀ n, f n ≡ L [SMOD (I ^ n • ⊤ : submodule R M)] := is_precomplete.prec' _

theorem is_precomplete_iff : is_precomplete I M ↔ ∀ f : ℕ → M,
  (∀ {m n}, m ≤ n → f m ≡ f n [SMOD (I ^ m • ⊤ : submodule R M)]) →
  ∃ L : M, ∀ n, f n ≡ L [SMOD (I ^ n • ⊤ : submodule R M)] :=
⟨λ h, h.1, λ h, ⟨h⟩⟩

variables (I M)

/-- The Hausdorffification of a module with respect to an ideal. -/
@[reducible] def Hausdorffification : Type* :=
M ⧸ (⨅ n : ℕ, I ^ n • ⊤ : submodule R M)

/-- The completion of a module with respect to an ideal. This is not necessarily Hausdorff.
In fact, this is only complete if the ideal is finitely generated. -/
def adic_completion : submodule R (Π n : ℕ, (M ⧸ (I ^ n • ⊤ : submodule R M))) :=
{ carrier := { f | ∀ {m n} (h : m ≤ n), liftq _ (mkq _)
    (by { rw ker_mkq, exact smul_mono (ideal.pow_le_pow h) le_rfl }) (f n) = f m },
  zero_mem' := λ m n hmn, by rw [pi.zero_apply, pi.zero_apply, linear_map.map_zero],
  add_mem' := λ f g hf hg m n hmn, by rw [pi.add_apply, pi.add_apply,
    linear_map.map_add, hf hmn, hg hmn],
  smul_mem' := λ c f hf m n hmn, by rw [pi.smul_apply, pi.smul_apply, linear_map.map_smul, hf hmn] }

namespace is_Hausdorff

instance bot : is_Hausdorff (⊥ : ideal R) M :=
⟨λ x hx, by simpa only [pow_one ⊥, bot_smul, smodeq.bot] using hx 1⟩

variables {M}
protected theorem subsingleton (h : is_Hausdorff (⊤ : ideal R) M) : subsingleton M :=
⟨λ x y, eq_of_sub_eq_zero $ h.haus (x - y) $ λ n,
  by { rw [ideal.top_pow, top_smul], exact smodeq.top }⟩
variables (M)

@[priority 100] instance of_subsingleton [subsingleton M] : is_Hausdorff I M :=
⟨λ x _, subsingleton.elim _ _⟩

variables {I M}
theorem infi_pow_smul (h : is_Hausdorff I M) :
  (⨅ n : ℕ, I ^ n • ⊤ : submodule R M) = ⊥ :=
eq_bot_iff.2 $ λ x hx, (mem_bot _).2 $ h.haus x $ λ n, smodeq.zero.2 $
(mem_infi $ λ n : ℕ, I ^ n • ⊤).1 hx n

end is_Hausdorff

namespace Hausdorffification

/-- The canonical linear map to the Hausdorffification. -/
def of : M →ₗ[R] Hausdorffification I M := mkq _

variables {I M}
@[elab_as_eliminator]
lemma induction_on {C : Hausdorffification I M → Prop} (x : Hausdorffification I M)
  (ih : ∀ x, C (of I M x)) : C x :=
quotient.induction_on' x ih
variables (I M)

instance : is_Hausdorff I (Hausdorffification I M) :=
⟨λ x, quotient.induction_on' x $ λ x hx, (quotient.mk_eq_zero _).2 $ (mem_infi _).2 $ λ n, begin
  have := comap_map_mkq (⨅ n : ℕ, I ^ n • ⊤ : submodule R M) (I ^ n • ⊤),
  simp only [sup_of_le_right (infi_le (λ n, (I ^ n • ⊤ : submodule R M)) n)] at this,
  rw [← this, map_smul'', mem_comap, submodule.map_top, range_mkq, ← smodeq.zero], exact hx n
end⟩

variables {M} [h : is_Hausdorff I N]
include h

/-- universal property of Hausdorffification: any linear map to a Hausdorff module extends to a
unique map from the Hausdorffification. -/
def lift (f : M →ₗ[R] N) : Hausdorffification I M →ₗ[R] N :=
liftq _ f $ map_le_iff_le_comap.1 $ h.infi_pow_smul ▸ le_infi (λ n,
le_trans (map_mono $ infi_le _ n) $ by { rw map_smul'', exact smul_mono le_rfl le_top })

theorem lift_of (f : M →ₗ[R] N) (x : M) : lift I f (of I M x) = f x := rfl

theorem lift_comp_of (f : M →ₗ[R] N) : (lift I f).comp (of I M) = f :=
linear_map.ext $ λ _, rfl

/-- Uniqueness of lift. -/
theorem lift_eq (f : M →ₗ[R] N) (g : Hausdorffification I M →ₗ[R] N) (hg : g.comp (of I M) = f) :
  g = lift I f :=
linear_map.ext $ λ x, induction_on x $ λ x, by rw [lift_of, ← hg, linear_map.comp_apply]

end Hausdorffification

namespace is_precomplete

instance bot : is_precomplete (⊥ : ideal R) M :=
begin
  refine ⟨λ f hf, ⟨f 1, λ n, _⟩⟩, cases n,
  { rw [pow_zero, ideal.one_eq_top, top_smul], exact smodeq.top },
  specialize hf (nat.le_add_left 1 n),
  rw [pow_one, bot_smul, smodeq.bot] at hf, rw hf
end

instance top : is_precomplete (⊤ : ideal R) M :=
⟨λ f hf, ⟨0, λ n, by { rw [ideal.top_pow, top_smul], exact smodeq.top }⟩⟩

@[priority 100] instance of_subsingleton [subsingleton M] : is_precomplete I M :=
⟨λ f hf, ⟨0, λ n, by rw subsingleton.elim (f n) 0⟩⟩

end is_precomplete

namespace adic_completion

/-- The canonical linear map to the completion. -/
def of : M →ₗ[R] adic_completion I M :=
{ to_fun    := λ x, ⟨λ n, mkq _ x, λ m n hmn, rfl⟩,
  map_add'  := λ x y, rfl,
  map_smul' := λ c x, rfl }

@[simp] lemma of_apply (x : M) (n : ℕ) : (of I M x).1 n = mkq _ x := rfl

/-- Linearly evaluating a sequence in the completion at a given input. -/
def eval (n : ℕ) : adic_completion I M →ₗ[R] (M ⧸ (I ^ n • ⊤ : submodule R M)) :=
{ to_fun    := λ f, f.1 n,
  map_add'  := λ f g, rfl,
  map_smul' := λ c f, rfl }

@[simp] lemma coe_eval (n : ℕ) :
  (eval I M n : adic_completion I M → (M ⧸ (I ^ n • ⊤ : submodule R M))) = λ f, f.1 n := rfl

lemma eval_apply (n : ℕ) (f : adic_completion I M) : eval I M n f = f.1 n := rfl

lemma eval_of (n : ℕ) (x : M) : eval I M n (of I M x) = mkq _ x := rfl

@[simp] lemma eval_comp_of (n : ℕ) : (eval I M n).comp (of I M) = mkq _ := rfl

@[simp] lemma range_eval (n : ℕ) : (eval I M n).range = ⊤ :=
linear_map.range_eq_top.2 $ λ x, quotient.induction_on' x $ λ x, ⟨of I M x, rfl⟩

variables {I M}
@[ext] lemma ext {x y : adic_completion I M} (h : ∀ n, eval I M n x = eval I M n y) : x = y :=
subtype.eq $ funext h
variables (I M)

instance : is_Hausdorff I (adic_completion I M) :=
⟨λ x hx, ext $ λ n, smul_induction_on (smodeq.zero.1 $ hx n)
  (λ r hr x _, ((eval I M n).map_smul r x).symm ▸ quotient.induction_on' (eval I M n x)
    (λ x, smodeq.zero.2 $ smul_mem_smul hr mem_top))
  (λ _ _ ih1 ih2, by rw [linear_map.map_add, ih1, ih2, linear_map.map_zero, add_zero])⟩

end adic_completion

namespace is_adic_complete

instance bot : is_adic_complete (⊥ : ideal R) M := {}

protected theorem subsingleton (h : is_adic_complete (⊤ : ideal R) M) : subsingleton M :=
h.1.subsingleton

@[priority 100] instance of_subsingleton [subsingleton M] : is_adic_complete I M := {}

open_locale big_operators
open finset

lemma le_jacobson_bot [is_adic_complete I R] : I ≤ (⊥ : ideal R).jacobson :=
begin
  intros x hx,
  rw [← ideal.neg_mem_iff, ideal.mem_jacobson_bot],
  intros y,
  rw add_comm,
  let f : ℕ → R := λ n, ∑ i in range n, (x * y) ^ i,
  have hf : ∀ m n, m ≤ n → f m ≡ f n [SMOD I ^ m • (⊤ : submodule R R)],
  { intros m n h,
    simp only [f, algebra.id.smul_eq_mul, ideal.mul_top, smodeq.sub_mem],
    rw [← add_tsub_cancel_of_le h, finset.sum_range_add, ← sub_sub, sub_self, zero_sub,
      neg_mem_iff],
    apply submodule.sum_mem,
    intros n hn,
    rw [mul_pow, pow_add, mul_assoc],
    exact ideal.mul_mem_right _ (I ^ m) (ideal.pow_mem_pow hx m) },
  obtain ⟨L, hL⟩ := is_precomplete.prec to_is_precomplete hf,
  { rw is_unit_iff_exists_inv,
    use L,
    rw [← sub_eq_zero, neg_mul],
    apply is_Hausdorff.haus (to_is_Hausdorff : is_Hausdorff I R),
    intros n,
    specialize hL n,
    rw [smodeq.sub_mem, algebra.id.smul_eq_mul, ideal.mul_top] at ⊢ hL,
    rw sub_zero,
    suffices : (1 - x * y) * (f n) - 1 ∈ I ^ n,
    { convert (ideal.sub_mem _ this (ideal.mul_mem_left _ (1 + - (x * y)) hL)) using 1,
      ring },
    cases n,
    { simp only [ideal.one_eq_top, pow_zero] },
    { dsimp [f],
      rw [← neg_sub _ (1:R), neg_mul, mul_geom_sum, neg_sub,
        sub_sub, add_comm, ← sub_sub, sub_self, zero_sub, neg_mem_iff, mul_pow],
      exact ideal.mul_mem_right _ (I ^ _) (ideal.pow_mem_pow hx _), } },
end

end is_adic_complete


/-
Copyright (c) 2020 Markus Himmel. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Markus Himmel, Scott Morrison, Jakob von Raumer

! This file was ported from Lean 3 source module category_theory.abelian.projective
! leanprover-community/mathlib commit f8d8465c3c392a93b9ed226956e26dee00975946
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.Algebra.Homology.QuasiIso
import Mathbin.CategoryTheory.Abelian.Homology
import Mathbin.CategoryTheory.Preadditive.ProjectiveResolution
import Mathbin.CategoryTheory.Preadditive.Yoneda.Limits
import Mathbin.CategoryTheory.Preadditive.Yoneda.Projective

/-!
# Abelian categories with enough projectives have projective resolutions

When `C` is abelian `projective.d f` and `f` are exact.
Hence, starting from an epimorphism `P ⟶ X`, where `P` is projective,
we can apply `projective.d` repeatedly to obtain a projective resolution of `X`.
-/

noncomputable section

open CategoryTheory

open CategoryTheory.Limits

open Opposite

universe v u v' u'

namespace CategoryTheory

open CategoryTheory.Projective

variable {C : Type u} [Category.{v} C] [Abelian C]

/-- When `C` is abelian, `projective.d f` and `f` are exact.
-/
theorem exact_d_f [EnoughProjectives C] {X Y : C} (f : X ⟶ Y) : Exact (d f) f :=
  (Abelian.exact_iff _ _).2 <|
    ⟨by simp, zero_of_epi_comp (π _) <| by rw [← category.assoc, cokernel.condition]⟩
#align category_theory.exact_d_f CategoryTheory.exact_d_f

/-- The preadditive Co-Yoneda functor on `P` preserves colimits if `P` is projective. -/
def preservesFiniteColimitsPreadditiveCoyonedaObjOfProjective (P : C) [hP : Projective P] :
    PreservesFiniteColimits (preadditiveCoyonedaObj (op P)) :=
  by
  letI := (projective_iff_preserves_epimorphisms_preadditive_coyoneda_obj' P).mp hP
  apply functor.preserves_finite_colimits_of_preserves_epis_and_kernels
#align category_theory.preserves_finite_colimits_preadditive_coyoneda_obj_of_projective CategoryTheory.preservesFiniteColimitsPreadditiveCoyonedaObjOfProjective

/-- An object is projective if its preadditive Co-Yoneda functor preserves finite colimits. -/
theorem projective_of_preservesFiniteColimits_preadditiveCoyonedaObj (P : C)
    [hP : PreservesFiniteColimits (preadditiveCoyonedaObj (op P))] : Projective P :=
  by
  rw [projective_iff_preserves_epimorphisms_preadditive_coyoneda_obj']
  infer_instance
#align category_theory.projective_of_preserves_finite_colimits_preadditive_coyoneda_obj CategoryTheory.projective_of_preservesFiniteColimits_preadditiveCoyonedaObj

namespace ProjectiveResolution

/-!
Our goal is to define `ProjectiveResolution.of Z : ProjectiveResolution Z`.
The `0`-th object in this resolution will just be `projective.over Z`,
i.e. an arbitrarily chosen projective object with a map to `Z`.
After that, we build the `n+1`-st object as `projective.syzygies`
applied to the previously constructed morphism,
and the map to the `n`-th object as `projective.d`.
-/

variable [EnoughProjectives C]

/-- Auxiliary definition for `ProjectiveResolution.of`. -/
@[simps]
def ofComplex (Z : C) : ChainComplex C ℕ :=
  ChainComplex.mk' (Projective.over Z) (Projective.syzygies (Projective.π Z))
    (Projective.d (Projective.π Z)) fun ⟨X, Y, f⟩ =>
    ⟨Projective.syzygies f, Projective.d f, (exact_d_f f).w⟩
#align category_theory.ProjectiveResolution.of_complex CategoryTheory.ProjectiveResolution.ofComplex

/-- In any abelian category with enough projectives,
`ProjectiveResolution.of Z` constructs a projective resolution of the object `Z`.
-/
irreducible_def of (Z : C) : ProjectiveResolution Z :=
  { complex := ofComplex Z
    π :=
      ChainComplex.mkHom _ _ (Projective.π Z) 0
        (by
          simp
          exact (exact_d_f (projective.π Z)).w.symm)
        fun n _ => ⟨0, by ext⟩
    Projective := by rintro (_ | _ | _ | n) <;> apply projective.projective_over
    exact₀ := by simpa using exact_d_f (projective.π Z)
    exact := by
      rintro (_ | n) <;>
        · simp
          apply exact_d_f
    Epi := Projective.π_epi Z }
#align category_theory.ProjectiveResolution.of CategoryTheory.ProjectiveResolution.of

instance (priority := 100) (Z : C) : HasProjectiveResolution Z where out := ⟨of Z⟩

instance (priority := 100) : HasProjectiveResolutions C where out Z := by infer_instance

end ProjectiveResolution

end CategoryTheory

namespace HomologicalComplex.Hom

variable {C : Type u} [Category.{v} C] [Abelian C]

/-- If `X` is a chain complex of projective objects and we have a quasi-isomorphism `f : X ⟶ Y[0]`,
then `X` is a projective resolution of `Y.` -/
def toSingle₀ProjectiveResolution {X : ChainComplex C ℕ} {Y : C}
    (f : X ⟶ (ChainComplex.single₀ C).obj Y) [QuasiIso f] (H : ∀ n, Projective (X.pt n)) :
    ProjectiveResolution Y where
  complex := X
  π := f
  Projective := H
  exact₀ := f.to_single₀_exact_d_f_at_zero
  exact := f.to_single₀_exact_at_succ
  Epi := f.to_single₀_epi_at_zero
#align homological_complex.hom.to_single₀_ProjectiveResolution HomologicalComplex.Hom.toSingle₀ProjectiveResolution

end HomologicalComplex.Hom


/-
Copyright (c) 2017 Mario Carneiro. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Sébastien Gouëzel, Floris van Doorn, Mario Carneiro
-/
import data.list.big_operators

/-!
# Join of a list of lists

This file proves basic properties of `list.join`, which concatenates a list of lists. It is defined
in [`data.list.defs`](./data/list/defs).
-/

variables {α β : Type*}

namespace list

attribute [simp] join

@[simp] lemma join_nil : [([] : list α)].join = [] := rfl

@[simp] lemma join_eq_nil : ∀ {L : list (list α)}, join L = [] ↔ ∀ l ∈ L, l = []
| []       := iff_of_true rfl (forall_mem_nil _)
| (l :: L) := by simp only [join, append_eq_nil, join_eq_nil, forall_mem_cons]

@[simp] lemma join_append (L₁ L₂ : list (list α)) : join (L₁ ++ L₂) = join L₁ ++ join L₂ :=
by induction L₁; [refl, simp only [*, join, cons_append, append_assoc]]

@[simp] lemma join_filter_empty_eq_ff [decidable_pred (λ l : list α, l.empty = ff)] :
  ∀ {L : list (list α)}, join (L.filter (λ l, l.empty = ff)) = L.join
| []              := rfl
| ([] :: L)       := by simp [@join_filter_empty_eq_ff L]
| ((a :: l) :: L) := by simp [@join_filter_empty_eq_ff L]

@[simp] lemma join_filter_ne_nil [decidable_pred (λ l : list α, l ≠ [])] {L : list (list α)} :
  join (L.filter (λ l, l ≠ [])) = L.join :=
by simp [join_filter_empty_eq_ff, ← empty_iff_eq_nil]

lemma join_join (l : list (list (list α))) : l.join.join = (l.map join).join :=
by { induction l, simp, simp [l_ih] }

@[simp] lemma length_join (L : list (list α)) : length (join L) = sum (map length L) :=
by induction L; [refl, simp only [*, join, map, sum_cons, length_append]]

@[simp] lemma length_bind (l : list α) (f : α → list β) :
  length (list.bind l f) = sum (map (length ∘ f) l) :=
by rw [list.bind, length_join, map_map]

@[simp] lemma bind_eq_nil {l : list α} {f : α → list β} :
  list.bind l f = [] ↔ ∀ x ∈ l, f x = [] :=
join_eq_nil.trans $ by simp only [mem_map, forall_exists_index, and_imp, forall_apply_eq_imp_iff₂]

/-- In a join, taking the first elements up to an index which is the sum of the lengths of the
first `i` sublists, is the same as taking the join of the first `i` sublists. -/
lemma take_sum_join (L : list (list α)) (i : ℕ) :
  L.join.take ((L.map length).take i).sum = (L.take i).join :=
begin
  induction L generalizing i, { simp },
  cases i, { simp },
  simp [take_append, L_ih]
end

/-- In a join, dropping all the elements up to an index which is the sum of the lengths of the
first `i` sublists, is the same as taking the join after dropping the first `i` sublists. -/
lemma drop_sum_join (L : list (list α)) (i : ℕ) :
  L.join.drop ((L.map length).take i).sum = (L.drop i).join :=
begin
  induction L generalizing i, { simp },
  cases i, { simp },
  simp [drop_append, L_ih],
end

/-- Taking only the first `i+1` elements in a list, and then dropping the first `i` ones, one is
left with a list of length `1` made of the `i`-th element of the original list. -/
lemma drop_take_succ_eq_cons_nth_le (L : list α) {i : ℕ} (hi : i < L.length) :
  (L.take (i+1)).drop i = [nth_le L i hi] :=
begin
  induction L generalizing i,
  { simp only [length] at hi, exact (nat.not_succ_le_zero i hi).elim },
  cases i, { simp },
  have : i < L_tl.length,
  { simp at hi,
    exact nat.lt_of_succ_lt_succ hi },
  simp [L_ih this],
  refl
end

/-- In a join of sublists, taking the slice between the indices `A` and `B - 1` gives back the
original sublist of index `i` if `A` is the sum of the lenghts of sublists of index `< i`, and
`B` is the sum of the lengths of sublists of index `≤ i`. -/
lemma drop_take_succ_join_eq_nth_le (L : list (list α)) {i : ℕ} (hi : i < L.length) :
  (L.join.take ((L.map length).take (i+1)).sum).drop ((L.map length).take i).sum = nth_le L i hi :=
begin
  have : (L.map length).take i = ((L.take (i+1)).map length).take i, by simp [map_take, take_take],
  simp [take_sum_join, this, drop_sum_join, drop_take_succ_eq_cons_nth_le _ hi]
end

/-- Auxiliary lemma to control elements in a join. -/
lemma sum_take_map_length_lt1 (L : list (list α)) {i j : ℕ}
  (hi : i < L.length) (hj : j < (nth_le L i hi).length) :
  ((L.map length).take i).sum + j < ((L.map length).take (i+1)).sum :=
by simp [hi, sum_take_succ, hj]

/-- Auxiliary lemma to control elements in a join. -/
lemma sum_take_map_length_lt2 (L : list (list α)) {i j : ℕ}
  (hi : i < L.length) (hj : j < (nth_le L i hi).length) :
  ((L.map length).take i).sum + j < L.join.length :=
begin
  convert lt_of_lt_of_le (sum_take_map_length_lt1 L hi hj) (monotone_sum_take _ hi),
  have : L.length = (L.map length).length, by simp,
  simp [this, -length_map]
end

/-- The `n`-th element in a join of sublists is the `j`-th element of the `i`th sublist,
where `n` can be obtained in terms of `i` and `j` by adding the lengths of all the sublists
of index `< i`, and adding `j`. -/
lemma nth_le_join (L : list (list α)) {i j : ℕ}
  (hi : i < L.length) (hj : j < (nth_le L i hi).length) :
  nth_le L.join (((L.map length).take i).sum + j) (sum_take_map_length_lt2 L hi hj) =
  nth_le (nth_le L i hi) j hj :=
by rw [nth_le_take L.join (sum_take_map_length_lt2 L hi hj) (sum_take_map_length_lt1 L hi hj),
  nth_le_drop, nth_le_of_eq (drop_take_succ_join_eq_nth_le L hi)]

/-- Two lists of sublists are equal iff their joins coincide, as well as the lengths of the
sublists. -/
theorem eq_iff_join_eq (L L' : list (list α)) :
  L = L' ↔ L.join = L'.join ∧ map length L = map length L' :=
begin
  refine ⟨λ H, by simp [H], _⟩,
  rintros ⟨join_eq, length_eq⟩,
  apply ext_le,
  { have : length (map length L) = length (map length L'), by rw length_eq,
    simpa using this },
  { assume n h₁ h₂,
    rw [← drop_take_succ_join_eq_nth_le, ← drop_take_succ_join_eq_nth_le, join_eq, length_eq] }
end

end list


/-
Copyright (c) 2021 Bhavik Mehta. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Bhavik Mehta
-/
import category_theory.arrow
import category_theory.limits.constructions.epi_mono
import category_theory.limits.creates
import category_theory.limits.unit
import category_theory.structured_arrow

/-!
# Limits and colimits in comma categories

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

We build limits in the comma category `comma L R` provided that the two source categories have
limits and `R` preserves them.
This is used to construct limits in the arrow category, structured arrow category and under
category, and show that the appropriate forgetful functors create limits.

The duals of all the above are also given.
-/

namespace category_theory
open category limits

universes w' w v u₁ u₂ u₃

variables {J : Type w} [category.{w'} J]
variables {A : Type u₁} [category.{v} A]
variables {B : Type u₂} [category.{v} B]
variables {T : Type u₃} [category.{v} T]

namespace comma

variables {L : A ⥤ T} {R : B ⥤ T}

variables (F : J ⥤ comma L R)

/-- (Implementation). An auxiliary cone which is useful in order to construct limits
in the comma category. -/
@[simps]
def limit_auxiliary_cone (c₁ : cone (F ⋙ fst L R)) :
  cone ((F ⋙ snd L R) ⋙ R) :=
(cones.postcompose (whisker_left F (comma.nat_trans L R) : _)).obj (L.map_cone c₁)

/--
If `R` preserves the appropriate limit, then given a cone for `F ⋙ fst L R : J ⥤ L` and a
limit cone for `F ⋙ snd L R : J ⥤ R` we can build a cone for `F` which will turn out to be a limit
cone.
-/
@[simps]
def cone_of_preserves [preserves_limit (F ⋙ snd L R) R]
  (c₁ : cone (F ⋙ fst L R)) {c₂ : cone (F ⋙ snd L R)} (t₂ : is_limit c₂) :
  cone F :=
{ X :=
  { left := c₁.X,
    right := c₂.X,
    hom := (is_limit_of_preserves R t₂).lift (limit_auxiliary_cone _ c₁) },
  π :=
  { app := λ j,
    { left := c₁.π.app j,
      right := c₂.π.app j,
      w' := ((is_limit_of_preserves R t₂).fac (limit_auxiliary_cone F c₁) j).symm },
    naturality' := λ j₁ j₂ t, by ext; dsimp; simp [←c₁.w t, ←c₂.w t] } }

/-- Provided that `R` preserves the appropriate limit, then the cone in `cone_of_preserves` is a
limit. -/
def cone_of_preserves_is_limit [preserves_limit (F ⋙ snd L R) R]
  {c₁ : cone (F ⋙ fst L R)} (t₁ : is_limit c₁)
  {c₂ : cone (F ⋙ snd L R)} (t₂ : is_limit c₂) :
  is_limit (cone_of_preserves F c₁ t₂) :=
{ lift := λ s,
  { left := t₁.lift ((fst L R).map_cone s),
    right := t₂.lift ((snd L R).map_cone s),
    w' := (is_limit_of_preserves R t₂).hom_ext $ λ j,
    begin
      rw [cone_of_preserves_X_hom, assoc, assoc, (is_limit_of_preserves R t₂).fac,
        limit_auxiliary_cone_π_app, ←L.map_comp_assoc, t₁.fac, R.map_cone_π_app, ←R.map_comp,
        t₂.fac],
      exact (s.π.app j).w,
    end },
  uniq' := λ s m w, comma_morphism.ext _ _
      (t₁.uniq ((fst L R).map_cone s) _ (λ j, by simp [←w]))
      (t₂.uniq ((snd L R).map_cone s) _ (λ j, by simp [←w])) }

/-- (Implementation). An auxiliary cocone which is useful in order to construct colimits
in the comma category. -/
@[simps]
def colimit_auxiliary_cocone (c₂ : cocone (F ⋙ snd L R)) :
  cocone ((F ⋙ fst L R) ⋙ L) :=
(cocones.precompose (whisker_left F (comma.nat_trans L R) : _)).obj (R.map_cocone c₂)

/--
If `L` preserves the appropriate colimit, then given a colimit cocone for `F ⋙ fst L R : J ⥤ L` and
a cocone for `F ⋙ snd L R : J ⥤ R` we can build a cocone for `F` which will turn out to be a
colimit cocone.
-/
@[simps]
def cocone_of_preserves [preserves_colimit (F ⋙ fst L R) L]
  {c₁ : cocone (F ⋙ fst L R)} (t₁ : is_colimit c₁) (c₂ : cocone (F ⋙ snd L R))  :
  cocone F :=
{ X :=
  { left := c₁.X,
    right := c₂.X,
    hom := (is_colimit_of_preserves L t₁).desc (colimit_auxiliary_cocone _ c₂) },
  ι :=
  { app := λ j,
    { left := c₁.ι.app j,
      right := c₂.ι.app j,
      w' := ((is_colimit_of_preserves L t₁).fac (colimit_auxiliary_cocone _ c₂) j) },
    naturality' := λ j₁ j₂ t, by ext; dsimp; simp [←c₁.w t, ←c₂.w t] } }

/-- Provided that `L` preserves the appropriate colimit, then the cocone in `cocone_of_preserves` is
a colimit. -/
def cocone_of_preserves_is_colimit [preserves_colimit (F ⋙ fst L R) L]
  {c₁ : cocone (F ⋙ fst L R)} (t₁ : is_colimit c₁)
  {c₂ : cocone (F ⋙ snd L R)} (t₂ : is_colimit c₂) :
  is_colimit (cocone_of_preserves F t₁ c₂) :=
{ desc := λ s,
  { left := t₁.desc ((fst L R).map_cocone s),
    right := t₂.desc ((snd L R).map_cocone s),
    w' := (is_colimit_of_preserves L t₁).hom_ext $ λ j,
    begin
      rw [cocone_of_preserves_X_hom, (is_colimit_of_preserves L t₁).fac_assoc,
        colimit_auxiliary_cocone_ι_app, assoc, ←R.map_comp, t₂.fac, L.map_cocone_ι_app,
        ←L.map_comp_assoc, t₁.fac],
      exact (s.ι.app j).w,
    end },
  uniq' := λ s m w, comma_morphism.ext _ _
      (t₁.uniq ((fst L R).map_cocone s) _ (by simp [←w]))
      (t₂.uniq ((snd L R).map_cocone s) _ (by simp [←w])) }

instance has_limit (F : J ⥤ comma L R)
  [has_limit (F ⋙ fst L R)] [has_limit (F ⋙ snd L R)]
  [preserves_limit (F ⋙ snd L R) R] :
  has_limit F :=
has_limit.mk ⟨_, cone_of_preserves_is_limit _ (limit.is_limit _) (limit.is_limit _)⟩

instance has_limits_of_shape
  [has_limits_of_shape J A] [has_limits_of_shape J B] [preserves_limits_of_shape J R] :
  has_limits_of_shape J (comma L R) := {}

instance has_limits [has_limits A] [has_limits B] [preserves_limits R] :
  has_limits (comma L R) := ⟨infer_instance⟩

instance has_colimit (F : J ⥤ comma L R)
  [has_colimit (F ⋙ fst L R)] [has_colimit (F ⋙ snd L R)]
  [preserves_colimit (F ⋙ fst L R) L] :
  has_colimit F :=
has_colimit.mk ⟨_, cocone_of_preserves_is_colimit _ (colimit.is_colimit _) (colimit.is_colimit _)⟩

instance has_colimits_of_shape
  [has_colimits_of_shape J A] [has_colimits_of_shape J B] [preserves_colimits_of_shape J L] :
  has_colimits_of_shape J (comma L R) := {}

instance has_colimits [has_colimits A] [has_colimits B] [preserves_colimits L] :
  has_colimits (comma L R) := ⟨infer_instance⟩

end comma

namespace arrow

instance has_limit (F : J ⥤ arrow T)
  [i₁ : has_limit (F ⋙ left_func)] [i₂ : has_limit (F ⋙ right_func)] :
  has_limit F :=
@@comma.has_limit _ _ _ _ _ i₁ i₂ _

instance has_limits_of_shape [has_limits_of_shape J T] : has_limits_of_shape J (arrow T) := {}
instance has_limits [has_limits T] : has_limits (arrow T) := ⟨infer_instance⟩

instance has_colimit (F : J ⥤ arrow T)
  [i₁ : has_colimit (F ⋙ left_func)] [i₂ : has_colimit (F ⋙ right_func)] :
  has_colimit F :=
@@comma.has_colimit _ _ _ _ _ i₁ i₂ _

instance has_colimits_of_shape [has_colimits_of_shape J T] : has_colimits_of_shape J (arrow T) := {}
instance has_colimits [has_colimits T] : has_colimits (arrow T) := ⟨infer_instance⟩

end arrow

namespace structured_arrow

variables {X : T} {G : A ⥤ T} (F : J ⥤ structured_arrow X G)

instance has_limit [i₁ : has_limit (F ⋙ proj X G)] [i₂ : preserves_limit (F ⋙ proj X G) G] :
  has_limit F :=
@@comma.has_limit _ _ _ _ _ _ i₁ i₂

instance has_limits_of_shape [has_limits_of_shape J A] [preserves_limits_of_shape J G] :
  has_limits_of_shape J (structured_arrow X G) := {}

instance has_limits [has_limits A] [preserves_limits G] :
  has_limits (structured_arrow X G) := ⟨infer_instance⟩

noncomputable instance creates_limit [i : preserves_limit (F ⋙ proj X G) G] :
  creates_limit F (proj X G) :=
creates_limit_of_reflects_iso $ λ c t,
{ lifted_cone := @@comma.cone_of_preserves _ _ _ _ _ i punit_cone t,
  makes_limit := comma.cone_of_preserves_is_limit _ punit_cone_is_limit _,
  valid_lift := cones.ext (iso.refl _) $ λ j, (id_comp _).symm }

noncomputable instance creates_limits_of_shape [preserves_limits_of_shape J G] :
  creates_limits_of_shape J (proj X G) := {}

noncomputable instance creates_limits [preserves_limits G] :
  creates_limits (proj X G : _) := ⟨⟩

instance mono_right_of_mono [has_pullbacks A] [preserves_limits_of_shape walking_cospan G]
  {Y Z : structured_arrow X G} (f : Y ⟶ Z) [mono f] : mono f.right :=
show mono ((proj X G).map f), from infer_instance

lemma mono_iff_mono_right [has_pullbacks A] [preserves_limits_of_shape walking_cospan G]
  {Y Z : structured_arrow X G} (f : Y ⟶ Z) : mono f ↔ mono f.right :=
⟨λ h, by exactI infer_instance, λ h, by exactI mono_of_mono_right f⟩

end structured_arrow

namespace costructured_arrow

variables {G : A ⥤ T} {X : T} (F : J ⥤ costructured_arrow G X)

instance has_colimit [i₁ : has_colimit (F ⋙ proj G X)] [i₂ : preserves_colimit (F ⋙ proj G X) G] :
  has_colimit F :=
@@comma.has_colimit _ _ _ _ _ i₁ _ i₂

instance has_colimits_of_shape [has_colimits_of_shape J A] [preserves_colimits_of_shape J G] :
  has_colimits_of_shape J (costructured_arrow G X) := {}

instance has_colimits [has_colimits A] [preserves_colimits G] :
  has_colimits (costructured_arrow G X) := ⟨infer_instance⟩

noncomputable instance creates_colimit [i : preserves_colimit (F ⋙ proj G X) G] :
  creates_colimit F (proj G X) :=
creates_colimit_of_reflects_iso $ λ c t,
{ lifted_cocone := @@comma.cocone_of_preserves _ _ _ _ _ i t punit_cocone,
  makes_colimit := comma.cocone_of_preserves_is_colimit _ _ punit_cocone_is_colimit,
  valid_lift := cocones.ext (iso.refl _) $ λ j, comp_id _ }

noncomputable instance creates_colimits_of_shape [preserves_colimits_of_shape J G] :
  creates_colimits_of_shape J (proj G X) := {}

noncomputable instance creates_colimits [preserves_colimits G] :
  creates_colimits (proj G X : _) := ⟨⟩

instance epi_left_of_epi [has_pushouts A] [preserves_colimits_of_shape walking_span G]
  {Y Z : costructured_arrow G X} (f : Y ⟶ Z) [epi f] : epi f.left :=
show epi ((proj G X).map f), from infer_instance

lemma epi_iff_epi_left [has_pushouts A] [preserves_colimits_of_shape walking_span G]
  {Y Z : costructured_arrow G X} (f : Y ⟶ Z) : epi f ↔ epi f.left :=
⟨λ h, by exactI infer_instance, λ h, by exactI epi_of_epi_left f⟩

end costructured_arrow

end category_theory