/-
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
Ported by: Frédéric Dupuis

! This file was ported from Lean 3 source module algebra.order.hom.monoid
! leanprover-community/mathlib commit 3342d1b2178381196f818146ff79bc0e7ccd9e2d
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathlib.Data.Pi.Algebra
import Mathlib.Algebra.Hom.Group
import Mathlib.Algebra.Order.Group.Instances
import Mathlib.Algebra.Order.Monoid.WithZero.Defs
import Mathlib.Order.Hom.Basic

/-!
# Ordered monoid and group homomorphisms

This file defines morphisms between (additive) ordered monoids.

## Types of morphisms

* `OrderAddMonoidHom`: Ordered additive monoid homomorphisms.
* `OrderMonoidHom`: Ordered monoid homomorphisms.
* `OrderMonoidWithZeroHom`: Ordered monoid with zero homomorphisms.

## Typeclasses

* `OrderAddMonoidHomClass`
* `OrderMonoidHomClass`
* `OrderMonoidWithZeroHomClass`

## Notation

* `→+o`: Bundled ordered additive monoid homs. Also use for additive groups homs.
* `→*o`: Bundled ordered monoid homs. Also use for groups homs.
* `→*₀o`: Bundled ordered monoid with zero homs. Also use for groups with zero homs.

## Implementation notes

There's a coercion from bundled homs to fun, and the canonical notation is to use the bundled hom as
a function via this coercion.

There is no `OrderGroupHom` -- the idea is that `OrderMonoidHom` is used.
The constructor for `OrderMonoidHom` needs a proof of `map_one` as well as `map_mul`; a separate
constructor `OrderMonoidHom.mk'` will construct ordered group homs (i.e. ordered monoid homs
between ordered groups) given only a proof that multiplication is preserved,

Implicit `{}` brackets are often used instead of type class `[]` brackets. This is done when the
instances can be inferred because they are implicit arguments to the type `OrderMonoidHom`. When
they can be inferred from the type it is faster to use this method than to use type class inference.

## Tags

ordered monoid, ordered group, monoid with zero
-/

open Function

variable {F α β γ δ : Type _}

section AddMonoid

/-- `α →+o β` is the type of monotone functions `α → β` that preserve the `OrderedAddCommMonoid`
structure.

`OrderAddMonoidHom` is also used for ordered group homomorphisms.

When possible, instead of parametrizing results over `(f : α →+o β)`,
you should parametrize over `(F : Type _) [OrderAddMonoidHomClass F α β] (f : F)`.

When you extend this structure, make sure to extend `OrderAddMonoidHomClass`. -/
structure OrderAddMonoidHom (α β : Type _) [Preorder α] [Preorder β] [AddZeroClass α]
  [AddZeroClass β] extends α →+ β where
  /-- An `OrderAddMonoidHom` is a monotone function. -/
  monotone' : Monotone toFun
#align order_add_monoid_hom OrderAddMonoidHom

/-- Infix notation for `OrderAddMonoidHom`. -/
infixr:25 " →+o " => OrderAddMonoidHom

section

/-- `OrderAddMonoidHomClass F α β` states that `F` is a type of ordered monoid homomorphisms.

You should also extend this typeclass when you extend `OrderAddMonoidHom`. -/
class OrderAddMonoidHomClass (F : Type _) (α β : outParam <| Type _) [Preorder α] [Preorder β]
  [AddZeroClass α] [AddZeroClass β] extends AddMonoidHomClass F α β where
  /-- An `OrderAddMonoidHom` is a monotone function. -/
  monotone (f : F) : Monotone f
#align order_add_monoid_hom_class OrderAddMonoidHomClass

end

-- Instances and lemmas are defined below through `@[to_additive]`.
end AddMonoid

section Monoid

/-- `α →*o β` is the type of functions `α → β` that preserve the `OrderedCommMonoid` structure.

`OrderMonoidHom` is also used for ordered group homomorphisms.

When possible, instead of parametrizing results over `(f : α →*o β)`,
you should parametrize over `(F : Type _) [OrderMonoidHomClass F α β] (f : F)`.

When you extend this structure, make sure to extend `OrderMonoidHomClass`. -/
@[to_additive]
structure OrderMonoidHom (α β : Type _) [Preorder α] [Preorder β] [MulOneClass α]
  [MulOneClass β] extends α →* β where
  /-- An `OrderMonoidHom` is a monotone function. -/
  monotone' : Monotone toFun
#align order_monoid_hom OrderMonoidHom

/-- Infix notation for `OrderMonoidHom`. -/
infixr:25 " →*o " => OrderMonoidHom

section

/-- `OrderMonoidHomClass F α β` states that `F` is a type of ordered monoid homomorphisms.

You should also extend this typeclass when you extend `OrderMonoidHom`. -/
@[to_additive]
class OrderMonoidHomClass (F : Type _) (α β : outParam <| Type _) [Preorder α] [Preorder β]
  [MulOneClass α] [MulOneClass β] extends MonoidHomClass F α β where
  /-- An `OrderMonoidHom` is a monotone function. -/
  monotone (f : F) : Monotone f
#align order_monoid_hom_class OrderMonoidHomClass

end

variable {_ : Preorder α} {_ : Preorder β} {_ : MulOneClass α} {_ : MulOneClass β}

/-- Turn an element of a type `F` satisfying `OrderMonoidHomClass F α β` into an actual
`OrderMonoidHom`. This is declared as the default coercion from `F` to `α →*o β`. -/
@[to_additive (attr := coe)
  "Turn an element of a type `F` satisfying `OrderAddMonoidHomClass F α β` into an actual
  `OrderAddMonoidHom`. This is declared as the default coercion from `F` to `α →+o β`."]
def OrderMonoidHomClass.toOrderMonoidHom [OrderMonoidHomClass F α β] (f : F) : α →*o β :=
{ (f : α →* β) with monotone' := monotone f }

-- See note [lower instance priority]
@[to_additive]
instance (priority := 100) OrderMonoidHomClass.toOrderHomClass [OrderMonoidHomClass F α β] :
    OrderHomClass F α β :=
  { ‹OrderMonoidHomClass F α β› with map_rel := OrderMonoidHomClass.monotone }
#align order_monoid_hom_class.to_order_hom_class OrderMonoidHomClass.toOrderHomClass
#align order_add_monoid_hom_class.to_order_hom_class OrderAddMonoidHomClass.toOrderHomClass

/-- Any type satisfying `OrderMonoidHomClass` can be cast into `OrderMonoidHom` via
  `OrderMonoidHomClass.toOrderMonoidHom`. -/
@[to_additive "Any type satisfying `OrderAddMonoidHomClass` can be cast into `OrderAddMonoidHom` via
  `OrderAddMonoidHomClass.toOrderAddMonoidHom`"]
instance [OrderMonoidHomClass F α β] : CoeTC F (α →*o β) :=
  ⟨OrderMonoidHomClass.toOrderMonoidHom⟩

end Monoid

section MonoidWithZero

variable [Preorder α] [Preorder β] [MulZeroOneClass α] [MulZeroOneClass β]

/-- `OrderMonoidWithZeroHom α β` is the type of functions `α → β` that preserve
the `MonoidWithZero` structure.

`OrderMonoidWithZeroHom` is also used for group homomorphisms.

When possible, instead of parametrizing results over `(f : α →+ β)`,
you should parametrize over `(F : Type _) [OrderMonoidWithZeroHomClass F α β] (f : F)`.

When you extend this structure, make sure to extend `OrderMonoidWithZeroHomClass`. -/
structure OrderMonoidWithZeroHom (α β : Type _) [Preorder α] [Preorder β] [MulZeroOneClass α]
  [MulZeroOneClass β] extends α →*₀ β where
  /-- An `OrderMonoidWithZeroHom` is a monotone function. -/
  monotone' : Monotone toFun
#align order_monoid_with_zero_hom OrderMonoidWithZeroHom

/-- Infix notation for `OrderMonoidWithZeroHom`. -/
infixr:25 " →*₀o " => OrderMonoidWithZeroHom

section

/-- `OrderMonoidWithZeroHomClass F α β` states that `F` is a type of
ordered monoid with zero homomorphisms.

You should also extend this typeclass when you extend `OrderMonoidWithZeroHom`. -/
class OrderMonoidWithZeroHomClass (F : Type _) (α β : outParam <| Type _) [Preorder α] [Preorder β]
  [MulZeroOneClass α] [MulZeroOneClass β] extends MonoidWithZeroHomClass F α β where
  /-- An `OrderMonoidWithZeroHom` is a monotone function. -/
  monotone (f : F) : Monotone f
#align order_monoid_with_zero_hom_class OrderMonoidWithZeroHomClass

/-- Turn an element of a type `F` satisfying `OrderMonoidWithZeroHomClass F α β` into an actual
`OrderMonoidWithZeroHom`. This is declared as the default coercion from `F` to `α →+*₀o β`. -/
@[coe]
def OrderMonoidWithZeroHomClass.toOrderMonoidWithZeroHom [OrderMonoidWithZeroHomClass F α β]
    (f : F) : α →*₀o β :=
{ (f : α →*₀ β) with monotone' := monotone f }

end

-- See note [lower instance priority]
instance (priority := 100) OrderMonoidWithZeroHomClass.toOrderMonoidHomClass
    {_ : Preorder α} {_ : Preorder β} {_ : MulZeroOneClass α} {_ : MulZeroOneClass β}
    [OrderMonoidWithZeroHomClass F α β] : OrderMonoidHomClass F α β :=
  { ‹OrderMonoidWithZeroHomClass F α β› with }
#align order_monoid_with_zero_hom_class.to_order_monoid_hom_class OrderMonoidWithZeroHomClass.toOrderMonoidHomClass

instance [OrderMonoidWithZeroHomClass F α β] : CoeTC F (α →*₀o β) :=
  ⟨OrderMonoidWithZeroHomClass.toOrderMonoidWithZeroHom⟩

end MonoidWithZero

section OrderedAddCommMonoid

variable [OrderedAddCommMonoid α] [OrderedAddCommMonoid β] [OrderAddMonoidHomClass F α β] (f : F)
  {a : α}

theorem map_nonneg (ha : 0 ≤ a) : 0 ≤ f a := by
  rw [← map_zero f]
  exact OrderHomClass.mono _ ha
#align map_nonneg map_nonneg

theorem map_nonpos (ha : a ≤ 0) : f a ≤ 0 := by
  rw [← map_zero f]
  exact OrderHomClass.mono _ ha
#align map_nonpos map_nonpos

end OrderedAddCommMonoid

section OrderedAddCommGroup

variable [OrderedAddCommGroup α] [OrderedAddCommMonoid β] [AddMonoidHomClass F α β] (f : F)

theorem monotone_iff_map_nonneg : Monotone (f : α → β) ↔ ∀ a, 0 ≤ a → 0 ≤ f a :=
  ⟨fun h a => by
    rw [← map_zero f]
    apply h, fun h a b hl => by
    rw [← sub_add_cancel b a, map_add f]
    exact le_add_of_nonneg_left (h _ <| sub_nonneg.2 hl)⟩
#align monotone_iff_map_nonneg monotone_iff_map_nonneg

theorem antitone_iff_map_nonpos : Antitone (f : α → β) ↔ ∀ a, 0 ≤ a → f a ≤ 0 :=
  monotone_toDual_comp_iff.symm.trans <| monotone_iff_map_nonneg _
#align antitone_iff_map_nonpos antitone_iff_map_nonpos

theorem monotone_iff_map_nonpos : Monotone (f : α → β) ↔ ∀ a ≤ 0, f a ≤ 0 :=
  antitone_comp_ofDual_iff.symm.trans <| antitone_iff_map_nonpos _
#align monotone_iff_map_nonpos monotone_iff_map_nonpos

theorem antitone_iff_map_nonneg : Antitone (f : α → β) ↔ ∀ a ≤ 0, 0 ≤ f a :=
  monotone_comp_ofDual_iff.symm.trans <| monotone_iff_map_nonneg _
#align antitone_iff_map_nonneg antitone_iff_map_nonneg

variable [CovariantClass β β (· + ·) (· < ·)]

theorem strictMono_iff_map_pos : StrictMono (f : α → β) ↔ ∀ a, 0 < a → 0 < f a := by
  refine ⟨fun h a => ?_, fun h a b hl => ?_⟩
  · rw [← map_zero f]
    apply h
  · rw [← sub_add_cancel b a, map_add f]
    exact lt_add_of_pos_left _ (h _ <| sub_pos.2 hl)
#align strict_mono_iff_map_pos strictMono_iff_map_pos

theorem strictAnti_iff_map_neg : StrictAnti (f : α → β) ↔ ∀ a, 0 < a → f a < 0 :=
  strictMono_toDual_comp_iff.symm.trans <| strictMono_iff_map_pos _
#align strict_anti_iff_map_neg strictAnti_iff_map_neg

theorem strictMono_iff_map_neg : StrictMono (f : α → β) ↔ ∀ a < 0, f a < 0 :=
  strictAnti_comp_ofDual_iff.symm.trans <| strictAnti_iff_map_neg _
#align strict_mono_iff_map_neg strictMono_iff_map_neg

theorem strictAnti_iff_map_pos : StrictAnti (f : α → β) ↔ ∀ a < 0, 0 < f a :=
  strictMono_comp_ofDual_iff.symm.trans <| strictMono_iff_map_pos _
#align strict_anti_iff_map_pos strictAnti_iff_map_pos

end OrderedAddCommGroup

namespace OrderMonoidHom

section Preorder

variable [Preorder α] [Preorder β] [Preorder γ] [Preorder δ] [MulOneClass α] [MulOneClass β]
  [MulOneClass γ] [MulOneClass δ] {f g : α →*o β}

@[to_additive]
 instance : OrderMonoidHomClass (α →*o β) α β where
  coe f := f.toFun
  coe_injective' f g h := by
    obtain ⟨⟨⟨_, _⟩⟩, _⟩ := f
    obtain ⟨⟨⟨_, _⟩⟩, _⟩ := g
    congr
  map_mul f := f.map_mul'
  map_one f := f.map_one'
  monotone f := f.monotone'

-- Porting note:
-- These helper instances are unhelpful in Lean 4, so omitting:
-- /-- Helper instance for when there's too many metavariables to apply `FunLike.instCoeFunForAll`
-- directly. -/
-- @[to_additive "Helper instance for when there's too many metavariables to apply
-- `FunLike.instCoeFunForAll` directly."]
-- instance : CoeFun (α →*o β) fun _ => α → β :=
--   FunLike.instCoeFunForAll

-- Other lemmas should be accessed through the `FunLike` API
@[to_additive (attr := ext)]
theorem ext (h : ∀ a, f a = g a) : f = g :=
  FunLike.ext f g h
#align order_monoid_hom.ext OrderMonoidHom.ext
#align order_add_monoid_hom.ext OrderAddMonoidHom.ext

@[to_additive]
theorem toFun_eq_coe (f : α →*o β) : f.toFun = (f : α → β) :=
  rfl
#align order_monoid_hom.to_fun_eq_coe OrderMonoidHom.toFun_eq_coe
#align order_add_monoid_hom.to_fun_eq_coe OrderAddMonoidHom.toFun_eq_coe

@[to_additive (attr := simp)]
theorem coe_mk (f : α →* β) (h) : (OrderMonoidHom.mk f h : α → β) = f :=
  rfl
#align order_monoid_hom.coe_mk OrderMonoidHom.coe_mk
#align order_add_monoid_hom.coe_mk OrderAddMonoidHom.coe_mk

@[to_additive (attr := simp)]
theorem mk_coe (f : α →*o β) (h) : OrderMonoidHom.mk (f : α →* β) h = f := by
  ext
  rfl
#align order_monoid_hom.mk_coe OrderMonoidHom.mk_coe
#align order_add_monoid_hom.mk_coe OrderAddMonoidHom.mk_coe

/-- Reinterpret an ordered monoid homomorphism as an order homomorphism. -/
@[to_additive "Reinterpret an ordered additive monoid homomorphism as an order homomorphism."]
def toOrderHom (f : α →*o β) : α →o β :=
  { f with }
#align order_monoid_hom.to_order_hom OrderMonoidHom.toOrderHom
#align order_add_monoid_hom.to_order_hom OrderAddMonoidHom.toOrderHom

@[to_additive (attr := simp)]
theorem coe_monoidHom (f : α →*o β) : ((f : α →* β) : α → β) = f :=
  rfl
#align order_monoid_hom.coe_monoid_hom OrderMonoidHom.coe_monoidHom
#align order_add_monoid_hom.coe_add_monoid_hom OrderAddMonoidHom.coe_addMonoidHom

@[to_additive (attr := simp)]
theorem coe_orderHom (f : α →*o β) : ((f : α →o β) : α → β) = f :=
  rfl
#align order_monoid_hom.coe_order_hom OrderMonoidHom.coe_orderHom
#align order_add_monoid_hom.coe_order_hom OrderAddMonoidHom.coe_orderHom

@[to_additive]
theorem toMonoidHom_injective : Injective (toMonoidHom : _ → α →* β) := fun f g h =>
  ext <| by convert FunLike.ext_iff.1 h using 0
#align order_monoid_hom.to_monoid_hom_injective OrderMonoidHom.toMonoidHom_injective
#align order_add_monoid_hom.to_add_monoid_hom_injective OrderAddMonoidHom.toAddMonoidHom_injective

@[to_additive]
theorem toOrderHom_injective : Injective (toOrderHom : _ → α →o β) := fun f g h =>
  ext <| by convert FunLike.ext_iff.1 h using 0
#align order_monoid_hom.to_order_hom_injective OrderMonoidHom.toOrderHom_injective
#align order_add_monoid_hom.to_order_hom_injective OrderAddMonoidHom.toOrderHom_injective

/-- Copy of an `OrderMonoidHom` with a new `toFun` equal to the old one. Useful to fix
definitional equalities. -/
@[to_additive "Copy of an `OrderAddMonoidHom` with a new `toFun` equal to the old one. Useful to fix
definitional equalities."]
protected def copy (f : α →*o β) (f' : α → β) (h : f' = f) : α →*o β :=
  { f.toMonoidHom.copy f' h with toFun := f', monotone' := h.symm.subst f.monotone' }
#align order_monoid_hom.copy OrderMonoidHom.copy
#align order_add_monoid_hom.copy OrderAddMonoidHom.copy

@[to_additive (attr := simp)]
theorem coe_copy (f : α →*o β) (f' : α → β) (h : f' = f) : ⇑(f.copy f' h) = f' :=
  rfl
#align order_monoid_hom.coe_copy OrderMonoidHom.coe_copy
#align order_add_monoid_hom.coe_copy OrderAddMonoidHom.coe_copy

@[to_additive]
theorem copy_eq (f : α →*o β) (f' : α → β) (h : f' = f) : f.copy f' h = f :=
  FunLike.ext' h
#align order_monoid_hom.copy_eq OrderMonoidHom.copy_eq
#align order_add_monoid_hom.copy_eq OrderAddMonoidHom.copy_eq

variable (α)

/-- The identity map as an ordered monoid homomorphism. -/
@[to_additive "The identity map as an ordered additive monoid homomorphism."]
protected def id : α →*o α :=
  { MonoidHom.id α, OrderHom.id with }
#align order_monoid_hom.id OrderMonoidHom.id
#align order_add_monoid_hom.id OrderAddMonoidHom.id

@[to_additive (attr := simp)]
theorem coe_id : ⇑(OrderMonoidHom.id α) = id :=
  rfl
#align order_monoid_hom.coe_id OrderMonoidHom.coe_id
#align order_add_monoid_hom.coe_id OrderAddMonoidHom.coe_id

@[to_additive]
instance : Inhabited (α →*o α) :=
  ⟨OrderMonoidHom.id α⟩

variable {α}

/-- Composition of `OrderMonoidHom`s as an `OrderMonoidHom`. -/
@[to_additive "Composition of `OrderAddMonoidHom`s as an `OrderAddMonoidHom`"]
def comp (f : β →*o γ) (g : α →*o β) : α →*o γ :=
  { f.toMonoidHom.comp (g : α →* β), f.toOrderHom.comp (g : α →o β) with }
#align order_monoid_hom.comp OrderMonoidHom.comp
#align order_add_monoid_hom.comp OrderAddMonoidHom.comp

@[to_additive (attr := simp)]
theorem coe_comp (f : β →*o γ) (g : α →*o β) : (f.comp g : α → γ) = f ∘ g :=
  rfl
#align order_monoid_hom.coe_comp OrderMonoidHom.coe_comp
#align order_add_monoid_hom.coe_comp OrderAddMonoidHom.coe_comp

@[to_additive (attr := simp)]
theorem comp_apply (f : β →*o γ) (g : α →*o β) (a : α) : (f.comp g) a = f (g a) :=
  rfl
#align order_add_monoid_hom.comp_apply OrderAddMonoidHom.comp_apply
#align order_monoid_hom.comp_apply OrderMonoidHom.comp_apply

@[to_additive]
theorem coe_comp_monoidHom (f : β →*o γ) (g : α →*o β) :
    (f.comp g : α →* γ) = (f : β →* γ).comp g :=
  rfl
#align order_monoid_hom.coe_comp_monoid_hom OrderMonoidHom.coe_comp_monoidHom
#align order_add_monoid_hom.coe_comp_add_monoid_hom OrderAddMonoidHom.coe_comp_addMonoidHom

@[to_additive]
theorem coe_comp_orderHom (f : β →*o γ) (g : α →*o β) :
    (f.comp g : α →o γ) = (f : β →o γ).comp g :=
  rfl
#align order_monoid_hom.coe_comp_order_hom OrderMonoidHom.coe_comp_orderHom
#align order_add_monoid_hom.coe_comp_order_hom OrderAddMonoidHom.coe_comp_orderHom

@[to_additive (attr := simp)]
theorem comp_assoc (f : γ →*o δ) (g : β →*o γ) (h : α →*o β) :
    (f.comp g).comp h = f.comp (g.comp h) :=
  rfl
#align order_monoid_hom.comp_assoc OrderMonoidHom.comp_assoc
#align order_add_monoid_hom.comp_assoc OrderAddMonoidHom.comp_assoc

@[to_additive (attr := simp)]
theorem comp_id (f : α →*o β) : f.comp (OrderMonoidHom.id α) = f :=
  rfl
#align order_monoid_hom.comp_id OrderMonoidHom.comp_id
#align order_add_monoid_hom.comp_id OrderAddMonoidHom.comp_id

@[to_additive (attr := simp)]
theorem id_comp (f : α →*o β) : (OrderMonoidHom.id β).comp f = f :=
  rfl
#align order_monoid_hom.id_comp OrderMonoidHom.id_comp
#align order_add_monoid_hom.id_comp OrderAddMonoidHom.id_comp

@[to_additive]
theorem cancel_right {g₁ g₂ : β →*o γ} {f : α →*o β} (hf : Function.Surjective f) :
    g₁.comp f = g₂.comp f ↔ g₁ = g₂ :=
  ⟨fun h => ext <| hf.forall.2 <| FunLike.ext_iff.1 h, fun _ => by congr⟩
#align order_monoid_hom.cancel_right OrderMonoidHom.cancel_right
#align order_add_monoid_hom.cancel_right OrderAddMonoidHom.cancel_right

@[to_additive]
theorem cancel_left {g : β →*o γ} {f₁ f₂ : α →*o β} (hg : Function.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 order_monoid_hom.cancel_left OrderMonoidHom.cancel_left
#align order_add_monoid_hom.cancel_left OrderAddMonoidHom.cancel_left

/-- `1` is the homomorphism sending all elements to `1`. -/
@[to_additive "`0` is the homomorphism sending all elements to `0`."]
instance : One (α →*o β) :=
  ⟨{ (1 : α →* β) with monotone' := monotone_const }⟩

@[to_additive (attr := simp)]
theorem coe_one : ⇑(1 : α →*o β) = 1 :=
  rfl
#align order_monoid_hom.coe_one OrderMonoidHom.coe_one
#align order_add_monoid_hom.coe_zero OrderAddMonoidHom.coe_zero

@[to_additive (attr := simp)]
theorem one_apply (a : α) : (1 : α →*o β) a = 1 :=
  rfl
#align order_monoid_hom.one_apply OrderMonoidHom.one_apply
#align order_add_monoid_hom.zero_apply OrderAddMonoidHom.zero_apply

@[to_additive (attr := simp)]
theorem one_comp (f : α →*o β) : (1 : β →*o γ).comp f = 1 :=
  rfl
#align order_monoid_hom.one_comp OrderMonoidHom.one_comp
#align order_add_monoid_hom.zero_comp OrderAddMonoidHom.zero_comp

@[to_additive (attr := simp)]
theorem comp_one (f : β →*o γ) : f.comp (1 : α →*o β) = 1 :=
  ext fun _ => map_one f
#align order_monoid_hom.comp_one OrderMonoidHom.comp_one
#align order_add_monoid_hom.comp_zero OrderAddMonoidHom.comp_zero

end Preorder

section Mul

variable [OrderedCommMonoid α] [OrderedCommMonoid β] [OrderedCommMonoid γ]

/-- For two ordered monoid morphisms `f` and `g`, their product is the ordered monoid morphism
sending `a` to `f a * g a`. -/
@[to_additive "For two ordered additive monoid morphisms `f` and `g`, their product is the ordered
additive monoid morphism sending `a` to `f a + g a`."]
instance : Mul (α →*o β) :=
  ⟨fun f g => { (f * g : α →* β) with monotone' := f.monotone'.mul' g.monotone' }⟩

@[to_additive (attr := simp)]
theorem coe_mul (f g : α →*o β) : ⇑(f * g) = f * g :=
  rfl
#align order_monoid_hom.coe_mul OrderMonoidHom.coe_mul
#align order_add_monoid_hom.coe_add OrderAddMonoidHom.coe_add

@[to_additive (attr := simp)]
theorem mul_apply (f g : α →*o β) (a : α) : (f * g) a = f a * g a :=
  rfl
#align order_monoid_hom.mul_apply OrderMonoidHom.mul_apply
#align order_add_monoid_hom.add_apply OrderAddMonoidHom.add_apply

@[to_additive]
theorem mul_comp (g₁ g₂ : β →*o γ) (f : α →*o β) : (g₁ * g₂).comp f = g₁.comp f * g₂.comp f :=
  rfl
#align order_monoid_hom.mul_comp OrderMonoidHom.mul_comp
#align order_add_monoid_hom.add_comp OrderAddMonoidHom.add_comp

@[to_additive]
theorem comp_mul (g : β →*o γ) (f₁ f₂ : α →*o β) : g.comp (f₁ * f₂) = g.comp f₁ * g.comp f₂ :=
  ext fun _ => map_mul g _ _
#align order_monoid_hom.comp_mul OrderMonoidHom.comp_mul
#align order_add_monoid_hom.comp_add OrderAddMonoidHom.comp_add

end Mul

section OrderedCommMonoid

variable {hα : OrderedCommMonoid α} {hβ : OrderedCommMonoid β}

@[to_additive (attr := simp)]
theorem toMonoidHom_eq_coe (f : α →*o β) : f.toMonoidHom = f :=
  rfl
#align order_monoid_hom.to_monoid_hom_eq_coe OrderMonoidHom.toMonoidHom_eq_coe
#align order_add_monoid_hom.to_add_monoid_hom_eq_coe OrderAddMonoidHom.toAddMonoidHom_eq_coe

@[to_additive (attr := simp)]

end OrderedCommMonoid

section OrderedCommGroup

variable {hα : OrderedCommGroup α} {hβ : OrderedCommGroup β}

/-- Makes an ordered group homomorphism from a proof that the map preserves multiplication. -/
@[to_additive
      "Makes an ordered additive group homomorphism from a proof that the map preserves
      addition."]
def mk' (f : α → β) (hf : Monotone f) (map_mul : ∀ a b : α, f (a * b) = f a * f b) : α →*o β :=
  { MonoidHom.mk' f map_mul with monotone' := hf }
#align order_monoid_hom.mk' OrderMonoidHom.mk'
#align order_add_monoid_hom.mk' OrderAddMonoidHom.mk'

end OrderedCommGroup

end OrderMonoidHom

namespace OrderMonoidWithZeroHom

section Preorder

variable [Preorder α] [Preorder β] [Preorder γ] [Preorder δ] [MulZeroOneClass α] [MulZeroOneClass β]
  [MulZeroOneClass γ] [MulZeroOneClass δ] {f g : α →*₀o β}

instance : OrderMonoidWithZeroHomClass (α →*₀o β) α β where
  coe f := f.toFun
  coe_injective' f g h := by
    obtain ⟨⟨⟨_, _⟩⟩, _⟩ := f
    obtain ⟨⟨⟨_, _⟩⟩, _⟩ := g
    congr
  map_mul f := f.map_mul'
  map_one f := f.map_one'
  map_zero f := f.map_zero'
  monotone f := f.monotone'

-- Porting note:
-- These helper instances are unhelpful in Lean 4, so omitting:
--/-- Helper instance for when there's too many metavariables to apply `FunLike.instCoeFunForAll`
--directly. -/
--instance : CoeFun (α →*₀o β) fun _ => α → β :=
--  FunLike.instCoeFunForAll

-- Other lemmas should be accessed through the `FunLike` API
@[ext]
theorem ext (h : ∀ a, f a = g a) : f = g :=
  FunLike.ext f g h
#align order_monoid_with_zero_hom.ext OrderMonoidWithZeroHom.ext

theorem toFun_eq_coe (f : α →*₀o β) : f.toFun = (f : α → β) :=
  rfl
#align order_monoid_with_zero_hom.to_fun_eq_coe OrderMonoidWithZeroHom.toFun_eq_coe

@[simp]
theorem coe_mk (f : α →*₀ β) (h) : (OrderMonoidWithZeroHom.mk f h : α → β) = f :=
  rfl
#align order_monoid_with_zero_hom.coe_mk OrderMonoidWithZeroHom.coe_mk

@[simp]
theorem mk_coe (f : α →*₀o β) (h) : OrderMonoidWithZeroHom.mk (f : α →*₀ β) h = f := rfl
#align order_monoid_with_zero_hom.mk_coe OrderMonoidWithZeroHom.mk_coe

/-- Reinterpret an ordered monoid with zero homomorphism as an order monoid homomorphism. -/
def toOrderMonoidHom (f : α →*₀o β) : α →*o β :=
  { f with }
#align order_monoid_with_zero_hom.to_order_monoid_hom OrderMonoidWithZeroHom.toOrderMonoidHom

@[simp]
theorem coe_monoidWithZeroHom (f : α →*₀o β) : ⇑(f : α →*₀ β) = f :=
  rfl
#align order_monoid_with_zero_hom.coe_monoid_with_zero_hom OrderMonoidWithZeroHom.coe_monoidWithZeroHom

@[simp]
theorem coe_orderMonoidHom (f : α →*₀o β) : ⇑(f : α →*o β) = f :=
  rfl
#align order_monoid_with_zero_hom.coe_order_monoid_hom OrderMonoidWithZeroHom.coe_orderMonoidHom

theorem toOrderMonoidHom_injective : Injective (toOrderMonoidHom : _ → α →*o β) := fun f g h =>
  ext <| by convert FunLike.ext_iff.1 h using 0
#align order_monoid_with_zero_hom.to_order_monoid_hom_injective OrderMonoidWithZeroHom.toOrderMonoidHom_injective

theorem toMonoidWithZeroHom_injective : Injective (toMonoidWithZeroHom : _ → α →*₀ β) :=
  fun f g h => ext <| by convert FunLike.ext_iff.1 h using 0
#align order_monoid_with_zero_hom.to_monoid_with_zero_hom_injective OrderMonoidWithZeroHom.toMonoidWithZeroHom_injective

/-- Copy of an `OrderMonoidWithZeroHom` with a new `toFun` equal to the old one. Useful to fix
definitional equalities. -/
protected def copy (f : α →*₀o β) (f' : α → β) (h : f' = f) : α →*o β :=
  { f.toOrderMonoidHom.copy f' h, f.toMonoidWithZeroHom.copy f' h with toFun := f' }
#align order_monoid_with_zero_hom.copy OrderMonoidWithZeroHom.copy

@[simp]
theorem coe_copy (f : α →*₀o β) (f' : α → β) (h : f' = f) : ⇑(f.copy f' h) = f' :=
  rfl
#align order_monoid_with_zero_hom.coe_copy OrderMonoidWithZeroHom.coe_copy

theorem copy_eq (f : α →*₀o β) (f' : α → β) (h : f' = f) : f.copy f' h = f :=
  FunLike.ext' h
#align order_monoid_with_zero_hom.copy_eq OrderMonoidWithZeroHom.copy_eq

variable (α)

/-- The identity map as an ordered monoid with zero homomorphism. -/
protected def id : α →*₀o α :=
  { MonoidWithZeroHom.id α, OrderHom.id with }
#align order_monoid_with_zero_hom.id OrderMonoidWithZeroHom.id

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

instance : Inhabited (α →*₀o α) :=
  ⟨OrderMonoidWithZeroHom.id α⟩

variable {α}

/-- Composition of `OrderMonoidWithZeroHom`s as an `OrderMonoidWithZeroHom`. -/
def comp (f : β →*₀o γ) (g : α →*₀o β) : α →*₀o γ :=
  { f.toMonoidWithZeroHom.comp (g : α →*₀ β), f.toOrderMonoidHom.comp (g : α →*o β) with }
#align order_monoid_with_zero_hom.comp OrderMonoidWithZeroHom.comp

@[simp]
theorem coe_comp (f : β →*₀o γ) (g : α →*₀o β) : (f.comp g : α → γ) = f ∘ g :=
  rfl
#align order_monoid_with_zero_hom.coe_comp OrderMonoidWithZeroHom.coe_comp

@[simp]
theorem comp_apply (f : β →*₀o γ) (g : α →*₀o β) (a : α) : (f.comp g) a = f (g a) :=
  rfl
#align order_monoid_with_zero_hom.comp_apply OrderMonoidWithZeroHom.comp_apply

theorem coe_comp_monoidWithZeroHom (f : β →*₀o γ) (g : α →*₀o β) :
    (f.comp g : α →*₀ γ) = (f : β →*₀ γ).comp g :=
  rfl
#align order_monoid_with_zero_hom.coe_comp_monoid_with_zero_hom OrderMonoidWithZeroHom.coe_comp_monoidWithZeroHom

theorem coe_comp_orderMonoidHom (f : β →*₀o γ) (g : α →*₀o β) :
    (f.comp g : α →*o γ) = (f : β →*o γ).comp g :=
  rfl
#align order_monoid_with_zero_hom.coe_comp_order_monoid_hom OrderMonoidWithZeroHom.coe_comp_orderMonoidHom

@[simp]
theorem comp_assoc (f : γ →*₀o δ) (g : β →*₀o γ) (h : α →*₀o β) :
    (f.comp g).comp h = f.comp (g.comp h) :=
  rfl
#align order_monoid_with_zero_hom.comp_assoc OrderMonoidWithZeroHom.comp_assoc

@[simp]
theorem comp_id (f : α →*₀o β) : f.comp (OrderMonoidWithZeroHom.id α) = f := rfl
#align order_monoid_with_zero_hom.comp_id OrderMonoidWithZeroHom.comp_id

@[simp]
theorem id_comp (f : α →*₀o β) : (OrderMonoidWithZeroHom.id β).comp f = f := rfl
#align order_monoid_with_zero_hom.id_comp OrderMonoidWithZeroHom.id_comp

theorem cancel_right {g₁ g₂ : β →*₀o γ} {f : α →*₀o β} (hf : Function.Surjective f) :
    g₁.comp f = g₂.comp f ↔ g₁ = g₂ :=
  ⟨fun h => ext <| hf.forall.2 <| FunLike.ext_iff.1 h, fun _ => by congr⟩
#align order_monoid_with_zero_hom.cancel_right OrderMonoidWithZeroHom.cancel_right

theorem cancel_left {g : β →*₀o γ} {f₁ f₂ : α →*₀o β} (hg : Function.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 order_monoid_with_zero_hom.cancel_left OrderMonoidWithZeroHom.cancel_left

end Preorder

section Mul

variable [LinearOrderedCommMonoidWithZero α] [LinearOrderedCommMonoidWithZero β]
  [LinearOrderedCommMonoidWithZero γ]

/-- For two ordered monoid morphisms `f` and `g`, their product is the ordered monoid morphism
sending `a` to `f a * g a`. -/
instance : Mul (α →*₀o β) :=
  ⟨fun f g => { (f * g : α →*₀ β) with monotone' := f.monotone'.mul' g.monotone' }⟩

@[simp]
theorem coe_mul (f g : α →*₀o β) : ⇑(f * g) = f * g :=
  rfl
#align order_monoid_with_zero_hom.coe_mul OrderMonoidWithZeroHom.coe_mul

@[simp]
theorem mul_apply (f g : α →*₀o β) (a : α) : (f * g) a = f a * g a :=
  rfl
#align order_monoid_with_zero_hom.mul_apply OrderMonoidWithZeroHom.mul_apply

theorem mul_comp (g₁ g₂ : β →*₀o γ) (f : α →*₀o β) : (g₁ * g₂).comp f = g₁.comp f * g₂.comp f :=
  rfl
#align order_monoid_with_zero_hom.mul_comp OrderMonoidWithZeroHom.mul_comp

theorem comp_mul (g : β →*₀o γ) (f₁ f₂ : α →*₀o β) : g.comp (f₁ * f₂) = g.comp f₁ * g.comp f₂ :=
  ext fun _ => map_mul g _ _
#align order_monoid_with_zero_hom.comp_mul OrderMonoidWithZeroHom.comp_mul

end Mul

section LinearOrderedCommMonoidWithZero

variable {hα : Preorder α} {hα' : MulZeroOneClass α} {hβ : Preorder β} {hβ' : MulZeroOneClass β}

@[simp]
theorem toMonoidWithZeroHom_eq_coe (f : α →*₀o β) : f.toMonoidWithZeroHom = f := by
  rfl
#align order_monoid_with_zero_hom.to_monoid_with_zero_hom_eq_coe OrderMonoidWithZeroHom.toMonoidWithZeroHom_eq_coe

@[simp]
theorem toOrderMonoidHom_eq_coe (f : α →*₀o β) : f.toOrderMonoidHom = f :=
  rfl
#align order_monoid_with_zero_hom.to_order_monoid_hom_eq_coe OrderMonoidWithZeroHom.toOrderMonoidHom_eq_coe

end LinearOrderedCommMonoidWithZero

end OrderMonoidWithZeroHom


/-
Copyright (c) 2020 Microsoft Corporation. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Leonardo de Moura
-/
import Lean.Meta.AppBuilder
import Lean.Meta.SynthInstance
import Lean.Meta.Tactic.Simp.Types

namespace Lean.Meta.Simp

def synthesizeArgs (lemmaName : Name) (xs : Array Expr) (bis : Array BinderInfo) (discharge? : Expr → SimpM (Option Expr)) : SimpM Bool := do
  for x in xs, bi in bis do
    let type ← inferType x
    if bi.isInstImplicit then
      unless (← synthesizeInstance x type) do
        return false
    else if (← instantiateMVars x).isMVar then
      if (← isProp type) then
        match (← discharge? type) with
        | some proof =>
          unless (← isDefEq x proof) do
            trace[Meta.Tactic.simp.discharge] "{lemmaName}, failed to assign proof{indentExpr type}"
            return false
        | none =>
          trace[Meta.Tactic.simp.discharge] "{lemmaName}, failed to discharge hypotheses{indentExpr type}"
          return false
      else if (← isClass? type).isSome then
        unless (← synthesizeInstance x type) do
          return false
  return true
where
  synthesizeInstance (x type : Expr) : SimpM Bool := do
    match (← trySynthInstance type) with
    | LOption.some val =>
      if (← isDefEq x val) then
        return true
      else
        trace[Meta.Tactic.simp.discharge] "{lemmaName}, failed to assign instance{indentExpr type}"
        return false
    | _ =>
      trace[Meta.Tactic.simp.discharge] "{lemmaName}, failed to synthesize instance{indentExpr type}"
      return false

private def tryLemmaCore (lhs : Expr) (xs : Array Expr) (bis : Array BinderInfo) (val : Expr) (type : Expr) (e : Expr) (lemma : SimpLemma) (numExtraArgs : Nat) (discharge? : Expr → SimpM (Option Expr)) : SimpM (Option Result) := do
  let rec go (e : Expr) : SimpM (Option Result) := do
    if (← isDefEq lhs e) then
      unless (← synthesizeArgs lemma.getName xs bis discharge?) do
        return none
      let proof ← instantiateMVars (mkAppN val xs)
      if ← hasAssignableMVar proof then
        trace[Meta.Tactic.simp.rewrite] "{lemma}, has unassigned metavariables after unification"
        return none
      let rhs   ← instantiateMVars type.appArg!
      if e == rhs then
        return none
      if lemma.perm && !Expr.lt rhs e then
        trace[Meta.Tactic.simp.rewrite] "{lemma}, perm rejected {e} ==> {rhs}"
        return none
      trace[Meta.Tactic.simp.rewrite] "{lemma}, {e} ==> {rhs}"
      return some { expr := rhs, proof? := proof }
    else
      unless lhs.isMVar do
        -- We do not report unification failures when `lhs` is a metavariable
        -- Example: `x = ()`
        -- TODO: reconsider if we want lemmas such as `(x : Unit) → x = ()`
        trace[Meta.Tactic.simp.unify] "{lemma}, failed to unify {lhs} with {e}"
      return none
  /- Check whether we need something more sophisticated here.
     This simple approach was good enough for Mathlib 3 -/
  let mut extraArgs := #[]
  let mut e := e
  for i in [:numExtraArgs] do
    extraArgs := extraArgs.push e.appArg!
    e := e.appFn!
  match (← go e) with
  | none => return none
  | some { expr := eNew, proof? := none } => return some { expr := mkAppN eNew extraArgs }
  | some { expr := eNew, proof? := some proof } =>
    let mut proof := proof
    for extraArg in extraArgs do
      proof ← mkCongrFun proof extraArg
    return some { expr := mkAppN eNew extraArgs, proof? := some proof }

def tryLemmaWithExtraArgs? (e : Expr) (lemma : SimpLemma) (numExtraArgs : Nat) (discharge? : Expr → SimpM (Option Expr)) : SimpM (Option Result) :=
  withNewMCtxDepth do
    let val  ← lemma.getValue
    let type ← inferType val
    let (xs, bis, type) ← forallMetaTelescopeReducing type
    let type ← whnf (← instantiateMVars type)
    let lhs := type.appFn!.appArg!
    tryLemmaCore lhs xs bis val type e lemma numExtraArgs discharge?

def tryLemma? (e : Expr) (lemma : SimpLemma) (discharge? : Expr → SimpM (Option Expr)) : SimpM (Option Result) := do
  withNewMCtxDepth do
    let val  ← lemma.getValue
    let type ← inferType val
    let (xs, bis, type) ← forallMetaTelescopeReducing type
    let type ← whnf (← instantiateMVars type)
    let lhs := type.appFn!.appArg!
    match (← tryLemmaCore lhs xs bis val type e lemma 0 discharge?) with
    | some result => return some result
    | none =>
      let lhsNumArgs := lhs.getAppNumArgs
      let eNumArgs   := e.getAppNumArgs
      if eNumArgs > lhsNumArgs then
        tryLemmaCore lhs xs bis val type e lemma (eNumArgs - lhsNumArgs) discharge?
      else
        return none
/-
Remark: the parameter tag is used for creating trace messages. It is irrelevant otherwise.
-/
def rewrite (e : Expr) (s : DiscrTree SimpLemma) (erased : Std.PHashSet Name) (discharge? : Expr → SimpM (Option Expr)) (tag : String) : SimpM Result := do
  let candidates ← s.getMatchWithExtra e
  if candidates.isEmpty then
    trace[Debug.Meta.Tactic.simp] "no theorems found for {tag}-rewriting {e}"
    return { expr := e }
  else
    let candidates := candidates.insertionSort fun e₁ e₂ => e₁.1.priority < e₂.1.priority
    for (lemma, numExtraArgs) in candidates do
      unless inErasedSet lemma do
        if let some result ← tryLemmaWithExtraArgs? e lemma numExtraArgs discharge? then
          return result
    return { expr := e }
where
  inErasedSet (lemma : SimpLemma) : Bool :=
    match lemma.name? with
    | none => false
    | some name => erased.contains name

def rewriteCtorEq? (e : Expr) : MetaM (Option Result) := withReducibleAndInstances do
  match e.eq? with
  | none => return none
  | some (_, lhs, rhs) =>
    let lhs ← whnf lhs
    let rhs ← whnf rhs
    let env ← getEnv
    match lhs.constructorApp? env, rhs.constructorApp? env with
    | some (c₁, _), some (c₂, _) =>
      if c₁.name != c₂.name then
        withLocalDeclD `h e fun h =>
          return some { expr := mkConst ``False, proof? := (← mkEqFalse' (← mkLambdaFVars #[h] (← mkNoConfusion (mkConst ``False) h))) }
      else
        return none
    | _, _ => return none

@[inline] def tryRewriteCtorEq (e : Expr) (x : SimpM Step) : SimpM Step := do
  match (← rewriteCtorEq? e) with
  | some r => return Step.done r
  | none => x

def rewriteUsingDecide? (e : Expr) : MetaM (Option Result) := withReducibleAndInstances do
  if e.hasFVar || e.hasMVar || e.isConstOf ``True || e.isConstOf ``False then
    return none
  else
    try
      let d ← mkDecide e
      let r ← withDefault <| whnf d
      if r.isConstOf ``true then
        return some { expr := mkConst ``True, proof? := mkAppN (mkConst ``eq_true_of_decide) #[e, d.appArg!, (← mkEqRefl (mkConst ``true))] }
      else if r.isConstOf ``false then
        let h ← mkEqRefl d
        return some { expr := mkConst ``False, proof? := mkAppN (mkConst ``eq_false_of_decide) #[e, d.appArg!, (← mkEqRefl (mkConst ``false))] }
      else
        return none
    catch _ =>
      return none

@[inline] def tryRewriteUsingDecide (e : Expr) (x : SimpM Step) : SimpM Step := do
  if (← read).config.decide then
    match (← rewriteUsingDecide? e) with
    | some r => return Step.done r
    | none => x
  else
    x

def rewritePre (e : Expr) (discharge? : Expr → SimpM (Option Expr)) : SimpM Step := do
  let lemmas ← (← read).simpLemmas
  return Step.visit (← rewrite e lemmas.pre lemmas.erased discharge? (tag := "pre"))

def rewritePost (e : Expr) (discharge? : Expr → SimpM (Option Expr)) : SimpM Step := do
  let lemmas ← (← read).simpLemmas
  return Step.visit (← rewrite e lemmas.post lemmas.erased discharge? (tag := "post"))

def preDefault (e : Expr) (discharge? : Expr → SimpM (Option Expr)) : SimpM Step :=
  tryRewriteCtorEq e <| rewritePre e discharge?

def postDefault (e : Expr) (discharge? : Expr → SimpM (Option Expr)) : SimpM Step := do
  -- TODO: try equation lemmas
  tryRewriteCtorEq e <| tryRewriteUsingDecide e <| rewritePost e discharge?

end Lean.Meta.Simp


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

! This file was ported from Lean 3 source module ring_theory.prime
! leanprover-community/mathlib commit 327c3c0d9232d80e250dc8f65e7835b82b266ea5
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.Algebra.Associated
import Mathbin.Algebra.BigOperators.Basic

/-!
# Prime elements in rings

> THIS FILE IS SYNCHRONIZED WITH MATHLIB4.
> Any changes to this file require a corresponding PR to mathlib4.
This file contains lemmas about prime elements of commutative rings.
-/

section CancelCommMonoidWithZero

variable {R : Type _} [CancelCommMonoidWithZero R]

open Finset

open BigOperators

/- warning: mul_eq_mul_prime_prod -> mul_eq_mul_prime_prod is a dubious translation:
lean 3 declaration is
  forall {R : Type.{u1}} [_inst_1 : CancelCommMonoidWithZero.{u1} R] {α : Type.{u2}} [_inst_2 : DecidableEq.{succ u2} α] {x : R} {y : R} {a : R} {s : Finset.{u2} α} {p : α -> R}, (forall (i : α), (Membership.Mem.{u2, u2} α (Finset.{u2} α) (Finset.hasMem.{u2} α) i s) -> (Prime.{u1} R (CancelCommMonoidWithZero.toCommMonoidWithZero.{u1} R _inst_1) (p i))) -> (Eq.{succ u1} R (HMul.hMul.{u1, u1, u1} R R R (instHMul.{u1} R (MulZeroClass.toHasMul.{u1} R (MulZeroOneClass.toMulZeroClass.{u1} R (MonoidWithZero.toMulZeroOneClass.{u1} R (CommMonoidWithZero.toMonoidWithZero.{u1} R (CancelCommMonoidWithZero.toCommMonoidWithZero.{u1} R _inst_1)))))) x y) (HMul.hMul.{u1, u1, u1} R R R (instHMul.{u1} R (MulZeroClass.toHasMul.{u1} R (MulZeroOneClass.toMulZeroClass.{u1} R (MonoidWithZero.toMulZeroOneClass.{u1} R (CommMonoidWithZero.toMonoidWithZero.{u1} R (CancelCommMonoidWithZero.toCommMonoidWithZero.{u1} R _inst_1)))))) a (Finset.prod.{u1, u2} R α (CommMonoidWithZero.toCommMonoid.{u1} R (CancelCommMonoidWithZero.toCommMonoidWithZero.{u1} R _inst_1)) s (fun (i : α) => p i)))) -> (Exists.{succ u2} (Finset.{u2} α) (fun (t : Finset.{u2} α) => Exists.{succ u2} (Finset.{u2} α) (fun (u : Finset.{u2} α) => Exists.{succ u1} R (fun (b : R) => Exists.{succ u1} R (fun (c : R) => And (Eq.{succ u2} (Finset.{u2} α) (Union.union.{u2} (Finset.{u2} α) (Finset.hasUnion.{u2} α (fun (a : α) (b : α) => _inst_2 a b)) t u) s) (And (Disjoint.{u2} (Finset.{u2} α) (Finset.partialOrder.{u2} α) (Finset.orderBot.{u2} α) t u) (And (Eq.{succ u1} R a (HMul.hMul.{u1, u1, u1} R R R (instHMul.{u1} R (MulZeroClass.toHasMul.{u1} R (MulZeroOneClass.toMulZeroClass.{u1} R (MonoidWithZero.toMulZeroOneClass.{u1} R (CommMonoidWithZero.toMonoidWithZero.{u1} R (CancelCommMonoidWithZero.toCommMonoidWithZero.{u1} R _inst_1)))))) b c)) (And (Eq.{succ u1} R x (HMul.hMul.{u1, u1, u1} R R R (instHMul.{u1} R (MulZeroClass.toHasMul.{u1} R (MulZeroOneClass.toMulZeroClass.{u1} R (MonoidWithZero.toMulZeroOneClass.{u1} R (CommMonoidWithZero.toMonoidWithZero.{u1} R (CancelCommMonoidWithZero.toCommMonoidWithZero.{u1} R _inst_1)))))) b (Finset.prod.{u1, u2} R α (CommMonoidWithZero.toCommMonoid.{u1} R (CancelCommMonoidWithZero.toCommMonoidWithZero.{u1} R _inst_1)) t (fun (i : α) => p i)))) (Eq.{succ u1} R y (HMul.hMul.{u1, u1, u1} R R R (instHMul.{u1} R (MulZeroClass.toHasMul.{u1} R (MulZeroOneClass.toMulZeroClass.{u1} R (MonoidWithZero.toMulZeroOneClass.{u1} R (CommMonoidWithZero.toMonoidWithZero.{u1} R (CancelCommMonoidWithZero.toCommMonoidWithZero.{u1} R _inst_1)))))) c (Finset.prod.{u1, u2} R α (CommMonoidWithZero.toCommMonoid.{u1} R (CancelCommMonoidWithZero.toCommMonoidWithZero.{u1} R _inst_1)) u (fun (i : α) => p i))))))))))))
but is expected to have type
  forall {R : Type.{u1}} [_inst_1 : CancelCommMonoidWithZero.{u1} R] {α : Type.{u2}} [_inst_2 : DecidableEq.{succ u2} α] {x : R} {y : R} {a : R} {s : Finset.{u2} α} {p : α -> R}, (forall (i : α), (Membership.mem.{u2, u2} α (Finset.{u2} α) (Finset.instMembershipFinset.{u2} α) i s) -> (Prime.{u1} R (CancelCommMonoidWithZero.toCommMonoidWithZero.{u1} R _inst_1) (p i))) -> (Eq.{succ u1} R (HMul.hMul.{u1, u1, u1} R R R (instHMul.{u1} R (MulZeroClass.toMul.{u1} R (MulZeroOneClass.toMulZeroClass.{u1} R (MonoidWithZero.toMulZeroOneClass.{u1} R (CommMonoidWithZero.toMonoidWithZero.{u1} R (CancelCommMonoidWithZero.toCommMonoidWithZero.{u1} R _inst_1)))))) x y) (HMul.hMul.{u1, u1, u1} R R R (instHMul.{u1} R (MulZeroClass.toMul.{u1} R (MulZeroOneClass.toMulZeroClass.{u1} R (MonoidWithZero.toMulZeroOneClass.{u1} R (CommMonoidWithZero.toMonoidWithZero.{u1} R (CancelCommMonoidWithZero.toCommMonoidWithZero.{u1} R _inst_1)))))) a (Finset.prod.{u1, u2} R α (CommMonoidWithZero.toCommMonoid.{u1} R (CancelCommMonoidWithZero.toCommMonoidWithZero.{u1} R _inst_1)) s (fun (i : α) => p i)))) -> (Exists.{succ u2} (Finset.{u2} α) (fun (t : Finset.{u2} α) => Exists.{succ u2} (Finset.{u2} α) (fun (u : Finset.{u2} α) => Exists.{succ u1} R (fun (b : R) => Exists.{succ u1} R (fun (c : R) => And (Eq.{succ u2} (Finset.{u2} α) (Union.union.{u2} (Finset.{u2} α) (Finset.instUnionFinset.{u2} α (fun (a : α) (b : α) => _inst_2 a b)) t u) s) (And (Disjoint.{u2} (Finset.{u2} α) (Finset.partialOrder.{u2} α) (Finset.instOrderBotFinsetToLEToPreorderPartialOrder.{u2} α) t u) (And (Eq.{succ u1} R a (HMul.hMul.{u1, u1, u1} R R R (instHMul.{u1} R (MulZeroClass.toMul.{u1} R (MulZeroOneClass.toMulZeroClass.{u1} R (MonoidWithZero.toMulZeroOneClass.{u1} R (CommMonoidWithZero.toMonoidWithZero.{u1} R (CancelCommMonoidWithZero.toCommMonoidWithZero.{u1} R _inst_1)))))) b c)) (And (Eq.{succ u1} R x (HMul.hMul.{u1, u1, u1} R R R (instHMul.{u1} R (MulZeroClass.toMul.{u1} R (MulZeroOneClass.toMulZeroClass.{u1} R (MonoidWithZero.toMulZeroOneClass.{u1} R (CommMonoidWithZero.toMonoidWithZero.{u1} R (CancelCommMonoidWithZero.toCommMonoidWithZero.{u1} R _inst_1)))))) b (Finset.prod.{u1, u2} R α (CommMonoidWithZero.toCommMonoid.{u1} R (CancelCommMonoidWithZero.toCommMonoidWithZero.{u1} R _inst_1)) t (fun (i : α) => p i)))) (Eq.{succ u1} R y (HMul.hMul.{u1, u1, u1} R R R (instHMul.{u1} R (MulZeroClass.toMul.{u1} R (MulZeroOneClass.toMulZeroClass.{u1} R (MonoidWithZero.toMulZeroOneClass.{u1} R (CommMonoidWithZero.toMonoidWithZero.{u1} R (CancelCommMonoidWithZero.toCommMonoidWithZero.{u1} R _inst_1)))))) c (Finset.prod.{u1, u2} R α (CommMonoidWithZero.toCommMonoid.{u1} R (CancelCommMonoidWithZero.toCommMonoidWithZero.{u1} R _inst_1)) u (fun (i : α) => p i))))))))))))
Case conversion may be inaccurate. Consider using '#align mul_eq_mul_prime_prod mul_eq_mul_prime_prodₓ'. -/
/-- If `x * y = a * ∏ i in s, p i` where `p i` is always prime, then
  `x` and `y` can both be written as a divisor of `a` multiplied by
  a product over a subset of `s`  -/
theorem mul_eq_mul_prime_prod {α : Type _} [DecidableEq α] {x y a : R} {s : Finset α} {p : α → R}
    (hp : ∀ i ∈ s, Prime (p i)) (hx : x * y = a * ∏ i in s, p i) :
    ∃ (t u : Finset α)(b c : R),
      t ∪ u = s ∧ Disjoint t u ∧ a = b * c ∧ (x = b * ∏ i in t, p i) ∧ y = c * ∏ i in u, p i :=
  by
  induction' s using Finset.induction with i s his ih generalizing x y a
  · exact ⟨∅, ∅, x, y, by simp [hx]⟩
  · rw [prod_insert his, ← mul_assoc] at hx
    have hpi : Prime (p i) := hp i (mem_insert_self _ _)
    rcases ih (fun i hi => hp i (mem_insert_of_mem hi)) hx with
      ⟨t, u, b, c, htus, htu, hbc, rfl, rfl⟩
    have hit : i ∉ t := fun hit => his (htus ▸ mem_union_left _ hit)
    have hiu : i ∉ u := fun hiu => his (htus ▸ mem_union_right _ hiu)
    obtain ⟨d, rfl⟩ | ⟨d, rfl⟩ : p i ∣ b ∨ p i ∣ c
    exact hpi.dvd_or_dvd ⟨a, by rw [← hbc, mul_comm]⟩
    · rw [mul_assoc, mul_comm a, mul_right_inj' hpi.ne_zero] at hbc
      exact
        ⟨insert i t, u, d, c, by rw [insert_union, htus], disjoint_insert_left.2 ⟨hiu, htu⟩, by
          simp [hbc, prod_insert hit, mul_assoc, mul_comm, mul_left_comm]⟩
    · rw [← mul_assoc, mul_right_comm b, mul_left_inj' hpi.ne_zero] at hbc
      exact
        ⟨t, insert i u, b, d, by rw [union_insert, htus], disjoint_insert_right.2 ⟨hit, htu⟩, by
          simp [← hbc, prod_insert hiu, mul_assoc, mul_comm, mul_left_comm]⟩
#align mul_eq_mul_prime_prod mul_eq_mul_prime_prod

/- warning: mul_eq_mul_prime_pow -> mul_eq_mul_prime_pow is a dubious translation:
lean 3 declaration is
  forall {R : Type.{u1}} [_inst_1 : CancelCommMonoidWithZero.{u1} R] {x : R} {y : R} {a : R} {p : R} {n : Nat}, (Prime.{u1} R (CancelCommMonoidWithZero.toCommMonoidWithZero.{u1} R _inst_1) p) -> (Eq.{succ u1} R (HMul.hMul.{u1, u1, u1} R R R (instHMul.{u1} R (MulZeroClass.toHasMul.{u1} R (MulZeroOneClass.toMulZeroClass.{u1} R (MonoidWithZero.toMulZeroOneClass.{u1} R (CommMonoidWithZero.toMonoidWithZero.{u1} R (CancelCommMonoidWithZero.toCommMonoidWithZero.{u1} R _inst_1)))))) x y) (HMul.hMul.{u1, u1, u1} R R R (instHMul.{u1} R (MulZeroClass.toHasMul.{u1} R (MulZeroOneClass.toMulZeroClass.{u1} R (MonoidWithZero.toMulZeroOneClass.{u1} R (CommMonoidWithZero.toMonoidWithZero.{u1} R (CancelCommMonoidWithZero.toCommMonoidWithZero.{u1} R _inst_1)))))) a (HPow.hPow.{u1, 0, u1} R Nat R (instHPow.{u1, 0} R Nat (Monoid.Pow.{u1} R (MonoidWithZero.toMonoid.{u1} R (CommMonoidWithZero.toMonoidWithZero.{u1} R (CancelCommMonoidWithZero.toCommMonoidWithZero.{u1} R _inst_1))))) p n))) -> (Exists.{1} Nat (fun (i : Nat) => Exists.{1} Nat (fun (j : Nat) => Exists.{succ u1} R (fun (b : R) => Exists.{succ u1} R (fun (c : R) => And (Eq.{1} Nat (HAdd.hAdd.{0, 0, 0} Nat Nat Nat (instHAdd.{0} Nat Nat.hasAdd) i j) n) (And (Eq.{succ u1} R a (HMul.hMul.{u1, u1, u1} R R R (instHMul.{u1} R (MulZeroClass.toHasMul.{u1} R (MulZeroOneClass.toMulZeroClass.{u1} R (MonoidWithZero.toMulZeroOneClass.{u1} R (CommMonoidWithZero.toMonoidWithZero.{u1} R (CancelCommMonoidWithZero.toCommMonoidWithZero.{u1} R _inst_1)))))) b c)) (And (Eq.{succ u1} R x (HMul.hMul.{u1, u1, u1} R R R (instHMul.{u1} R (MulZeroClass.toHasMul.{u1} R (MulZeroOneClass.toMulZeroClass.{u1} R (MonoidWithZero.toMulZeroOneClass.{u1} R (CommMonoidWithZero.toMonoidWithZero.{u1} R (CancelCommMonoidWithZero.toCommMonoidWithZero.{u1} R _inst_1)))))) b (HPow.hPow.{u1, 0, u1} R Nat R (instHPow.{u1, 0} R Nat (Monoid.Pow.{u1} R (MonoidWithZero.toMonoid.{u1} R (CommMonoidWithZero.toMonoidWithZero.{u1} R (CancelCommMonoidWithZero.toCommMonoidWithZero.{u1} R _inst_1))))) p i))) (Eq.{succ u1} R y (HMul.hMul.{u1, u1, u1} R R R (instHMul.{u1} R (MulZeroClass.toHasMul.{u1} R (MulZeroOneClass.toMulZeroClass.{u1} R (MonoidWithZero.toMulZeroOneClass.{u1} R (CommMonoidWithZero.toMonoidWithZero.{u1} R (CancelCommMonoidWithZero.toCommMonoidWithZero.{u1} R _inst_1)))))) c (HPow.hPow.{u1, 0, u1} R Nat R (instHPow.{u1, 0} R Nat (Monoid.Pow.{u1} R (MonoidWithZero.toMonoid.{u1} R (CommMonoidWithZero.toMonoidWithZero.{u1} R (CancelCommMonoidWithZero.toCommMonoidWithZero.{u1} R _inst_1))))) p j))))))))))
but is expected to have type
  forall {R : Type.{u1}} [_inst_1 : CancelCommMonoidWithZero.{u1} R] {x : R} {y : R} {a : R} {p : R} {n : Nat}, (Prime.{u1} R (CancelCommMonoidWithZero.toCommMonoidWithZero.{u1} R _inst_1) p) -> (Eq.{succ u1} R (HMul.hMul.{u1, u1, u1} R R R (instHMul.{u1} R (MulZeroClass.toMul.{u1} R (MulZeroOneClass.toMulZeroClass.{u1} R (MonoidWithZero.toMulZeroOneClass.{u1} R (CommMonoidWithZero.toMonoidWithZero.{u1} R (CancelCommMonoidWithZero.toCommMonoidWithZero.{u1} R _inst_1)))))) x y) (HMul.hMul.{u1, u1, u1} R R R (instHMul.{u1} R (MulZeroClass.toMul.{u1} R (MulZeroOneClass.toMulZeroClass.{u1} R (MonoidWithZero.toMulZeroOneClass.{u1} R (CommMonoidWithZero.toMonoidWithZero.{u1} R (CancelCommMonoidWithZero.toCommMonoidWithZero.{u1} R _inst_1)))))) a (HPow.hPow.{u1, 0, u1} R Nat R (instHPow.{u1, 0} R Nat (Monoid.Pow.{u1} R (MonoidWithZero.toMonoid.{u1} R (CommMonoidWithZero.toMonoidWithZero.{u1} R (CancelCommMonoidWithZero.toCommMonoidWithZero.{u1} R _inst_1))))) p n))) -> (Exists.{1} Nat (fun (i : Nat) => Exists.{1} Nat (fun (j : Nat) => Exists.{succ u1} R (fun (b : R) => Exists.{succ u1} R (fun (c : R) => And (Eq.{1} Nat (HAdd.hAdd.{0, 0, 0} Nat Nat Nat (instHAdd.{0} Nat instAddNat) i j) n) (And (Eq.{succ u1} R a (HMul.hMul.{u1, u1, u1} R R R (instHMul.{u1} R (MulZeroClass.toMul.{u1} R (MulZeroOneClass.toMulZeroClass.{u1} R (MonoidWithZero.toMulZeroOneClass.{u1} R (CommMonoidWithZero.toMonoidWithZero.{u1} R (CancelCommMonoidWithZero.toCommMonoidWithZero.{u1} R _inst_1)))))) b c)) (And (Eq.{succ u1} R x (HMul.hMul.{u1, u1, u1} R R R (instHMul.{u1} R (MulZeroClass.toMul.{u1} R (MulZeroOneClass.toMulZeroClass.{u1} R (MonoidWithZero.toMulZeroOneClass.{u1} R (CommMonoidWithZero.toMonoidWithZero.{u1} R (CancelCommMonoidWithZero.toCommMonoidWithZero.{u1} R _inst_1)))))) b (HPow.hPow.{u1, 0, u1} R Nat R (instHPow.{u1, 0} R Nat (Monoid.Pow.{u1} R (MonoidWithZero.toMonoid.{u1} R (CommMonoidWithZero.toMonoidWithZero.{u1} R (CancelCommMonoidWithZero.toCommMonoidWithZero.{u1} R _inst_1))))) p i))) (Eq.{succ u1} R y (HMul.hMul.{u1, u1, u1} R R R (instHMul.{u1} R (MulZeroClass.toMul.{u1} R (MulZeroOneClass.toMulZeroClass.{u1} R (MonoidWithZero.toMulZeroOneClass.{u1} R (CommMonoidWithZero.toMonoidWithZero.{u1} R (CancelCommMonoidWithZero.toCommMonoidWithZero.{u1} R _inst_1)))))) c (HPow.hPow.{u1, 0, u1} R Nat R (instHPow.{u1, 0} R Nat (Monoid.Pow.{u1} R (MonoidWithZero.toMonoid.{u1} R (CommMonoidWithZero.toMonoidWithZero.{u1} R (CancelCommMonoidWithZero.toCommMonoidWithZero.{u1} R _inst_1))))) p j))))))))))
Case conversion may be inaccurate. Consider using '#align mul_eq_mul_prime_pow mul_eq_mul_prime_powₓ'. -/
/-- If ` x * y = a * p ^ n` where `p` is prime, then `x` and `y` can both be written
  as the product of a power of `p` and a divisor of `a`. -/
theorem mul_eq_mul_prime_pow {x y a p : R} {n : ℕ} (hp : Prime p) (hx : x * y = a * p ^ n) :
    ∃ (i j : ℕ)(b c : R), i + j = n ∧ a = b * c ∧ x = b * p ^ i ∧ y = c * p ^ j :=
  by
  rcases mul_eq_mul_prime_prod (fun _ _ => hp)
      (show x * y = a * (range n).Prod fun _ => p by simpa) with
    ⟨t, u, b, c, htus, htu, rfl, rfl, rfl⟩
  exact ⟨t.card, u.card, b, c, by rw [← card_disjoint_union htu, htus, card_range], by simp⟩
#align mul_eq_mul_prime_pow mul_eq_mul_prime_pow

end CancelCommMonoidWithZero

section CommRing

variable {α : Type _} [CommRing α]

/- warning: prime.neg -> Prime.neg is a dubious translation:
lean 3 declaration is
  forall {α : Type.{u1}} [_inst_1 : CommRing.{u1} α] {p : α}, (Prime.{u1} α (CommSemiring.toCommMonoidWithZero.{u1} α (CommRing.toCommSemiring.{u1} α _inst_1)) p) -> (Prime.{u1} α (CommSemiring.toCommMonoidWithZero.{u1} α (CommRing.toCommSemiring.{u1} α _inst_1)) (Neg.neg.{u1} α (SubNegMonoid.toHasNeg.{u1} α (AddGroup.toSubNegMonoid.{u1} α (AddGroupWithOne.toAddGroup.{u1} α (AddCommGroupWithOne.toAddGroupWithOne.{u1} α (Ring.toAddCommGroupWithOne.{u1} α (CommRing.toRing.{u1} α _inst_1)))))) p))
but is expected to have type
  forall {α : Type.{u1}} [_inst_1 : CommRing.{u1} α] {p : α}, (Prime.{u1} α (CommSemiring.toCommMonoidWithZero.{u1} α (CommRing.toCommSemiring.{u1} α _inst_1)) p) -> (Prime.{u1} α (CommSemiring.toCommMonoidWithZero.{u1} α (CommRing.toCommSemiring.{u1} α _inst_1)) (Neg.neg.{u1} α (Ring.toNeg.{u1} α (CommRing.toRing.{u1} α _inst_1)) p))
Case conversion may be inaccurate. Consider using '#align prime.neg Prime.negₓ'. -/
theorem Prime.neg {p : α} (hp : Prime p) : Prime (-p) :=
  by
  obtain ⟨h1, h2, h3⟩ := hp
  exact ⟨neg_ne_zero.mpr h1, by rwa [IsUnit.neg_iff], by simpa [neg_dvd] using h3⟩
#align prime.neg Prime.neg

/- warning: prime.abs -> Prime.abs is a dubious translation:
lean 3 declaration is
  forall {α : Type.{u1}} [_inst_1 : CommRing.{u1} α] [_inst_2 : LinearOrder.{u1} α] {p : α}, (Prime.{u1} α (CommSemiring.toCommMonoidWithZero.{u1} α (CommRing.toCommSemiring.{u1} α _inst_1)) p) -> (Prime.{u1} α (CommSemiring.toCommMonoidWithZero.{u1} α (CommRing.toCommSemiring.{u1} α _inst_1)) (Abs.abs.{u1} α (Neg.toHasAbs.{u1} α (SubNegMonoid.toHasNeg.{u1} α (AddGroup.toSubNegMonoid.{u1} α (AddGroupWithOne.toAddGroup.{u1} α (AddCommGroupWithOne.toAddGroupWithOne.{u1} α (Ring.toAddCommGroupWithOne.{u1} α (CommRing.toRing.{u1} α _inst_1)))))) (SemilatticeSup.toHasSup.{u1} α (Lattice.toSemilatticeSup.{u1} α (LinearOrder.toLattice.{u1} α _inst_2)))) p))
but is expected to have type
  forall {α : Type.{u1}} [_inst_1 : CommRing.{u1} α] [_inst_2 : LinearOrder.{u1} α] {p : α}, (Prime.{u1} α (CommSemiring.toCommMonoidWithZero.{u1} α (CommRing.toCommSemiring.{u1} α _inst_1)) p) -> (Prime.{u1} α (CommSemiring.toCommMonoidWithZero.{u1} α (CommRing.toCommSemiring.{u1} α _inst_1)) (Abs.abs.{u1} α (Neg.toHasAbs.{u1} α (Ring.toNeg.{u1} α (CommRing.toRing.{u1} α _inst_1)) (SemilatticeSup.toSup.{u1} α (Lattice.toSemilatticeSup.{u1} α (DistribLattice.toLattice.{u1} α (instDistribLattice.{u1} α _inst_2))))) p))
Case conversion may be inaccurate. Consider using '#align prime.abs Prime.absₓ'. -/
theorem Prime.abs [LinearOrder α] {p : α} (hp : Prime p) : Prime (abs p) :=
  by
  obtain h | h := abs_choice p <;> rw [h]
  · exact hp
  · exact hp.neg
#align prime.abs Prime.abs

end CommRing


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

Type classes for traversing collections. The concepts and laws are taken from
http://hackage.haskell.org/package/base-4.11.1.0/docs/Data-Traversable.html
-/

import tactic.cache
import category.applicative

open function (hiding comp)

universes u v w

section applicative_transformation

variables (F : Type u → Type v) [applicative F] [is_lawful_applicative F]
variables (G : Type u → Type w) [applicative G] [is_lawful_applicative G]

structure applicative_transformation : Type (max (u+1) v w) :=
(app : ∀ α : Type u, F α → G α)
(preserves_pure' : ∀ {α : Type u} (x : α), app _ (pure x) = pure x)
(preserves_seq' : ∀ {α β : Type u} (x : F (α → β)) (y : F α), app _ (x <*> y) = app _ x <*> app _ y)

end applicative_transformation

namespace applicative_transformation

variables (F : Type u → Type v) [applicative F] [is_lawful_applicative F]
variables (G : Type u → Type w) [applicative G] [is_lawful_applicative G]

instance : has_coe_to_fun (applicative_transformation F G) :=
{ F := λ _, Π {α}, F α → G α,
  coe := λ a, a.app }

variables {F G}
variables (η : applicative_transformation F G)

@[functor_norm]
lemma preserves_pure : ∀ {α} (x : α), η (pure x) = pure x := η.preserves_pure'

@[functor_norm]
lemma preserves_seq :
  ∀ {α β : Type u} (x : F (α → β)) (y : F α), η (x <*> y) = η x <*> η y :=
η.preserves_seq'

@[functor_norm]
lemma preserves_map {α β} (x : α → β) (y : F α) : η (x <$> y) = x <$> η y :=
by rw [← pure_seq_eq_map, η.preserves_seq]; simp with functor_norm

end applicative_transformation

open applicative_transformation

class traversable (t : Type u → Type u) extends functor t :=
(traverse : Π {m : Type u → Type u} [applicative m] {α β},
   (α → m β) → t α → m (t β))

open functor

export traversable (traverse)

section functions

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

variables {f : Type u → Type u} [applicative f]

def sequence [traversable t] : t (f α) → f (t α) := traverse id

end functions

class is_lawful_traversable (t : Type u → Type u) [traversable t]
  extends is_lawful_functor t : Type (u+1) :=
(id_traverse : ∀ {α} (x : t α), traverse id.mk x = x )
(comp_traverse : ∀ {F G} [applicative F] [applicative G]
    [is_lawful_applicative F] [is_lawful_applicative G]
    {α β γ} (f : β → F γ) (g : α → G β) (x : t α),
  traverse (comp.mk ∘ map f ∘ g) x =
  comp.mk (map (traverse f) (traverse g x)))
(traverse_eq_map_id : ∀ {α β} (f : α → β) (x : t α),
  traverse (id.mk ∘ f) x = id.mk (f <$> x))
(naturality : ∀ {F G} [applicative F] [applicative G]
    [is_lawful_applicative F] [is_lawful_applicative G]
    (η : applicative_transformation F G) {α β} (f : α → F β) (x : t α),
  η (traverse f x) = traverse (@η _ ∘ f) x)

instance : traversable id := ⟨λ _ _ _ _, id⟩
instance : is_lawful_traversable id := by refine {..}; intros; refl

section

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

instance : traversable option := ⟨@option.traverse⟩

instance : traversable list := ⟨@list.traverse⟩

end

namespace sum

variables {σ : Type u}
variables {F : Type u → Type u}
variables [applicative F]

protected def traverse {α β} (f : α → F β) : σ ⊕ α → F (σ ⊕ β)
| (sum.inl x) := pure (sum.inl x)
| (sum.inr x) := sum.inr <$> f x

end sum

instance {σ : Type u} : traversable.{u} (sum σ) := ⟨@sum.traverse _⟩


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

open category_theory category_theory.limits

noncomputable theory

namespace category_theory

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

/--
When `F` is fully faithful, and `has_colimit (K ⋙ F)`, to show that `F` creates the colimit for `K`
it suffices to show that the chosen colimit point is in the essential image of `F`.
-/
-- Notice however that even if the isomorphism is `iso.refl _`,
-- this construction will insert additional identity morphisms in the cocone maps,
-- so the constructed colimits may not be ideal, definitionally.
def creates_colimit_of_fully_faithful_of_iso {K : J ⥤ C} {F : C ⥤ D}
  [full F] [faithful F] [has_colimit (K ⋙ F)]
  (X : C) (i : F.obj X ≅ colimit (K ⋙ F)) : creates_colimit K F :=
creates_colimit_of_fully_faithful_of_lift
({ X := X,
  ι :=
  { app := λ j, F.preimage (colimit.ι (K ⋙ F) j ≫ i.inv : _),
    naturality' := λ Y Z f, F.map_injective
      (by { erw category.comp_id, simp only [functor.map_comp, functor.image_preimage],
        erw colimit.w_assoc (K ⋙ F) }) }} : cocone K)
(by { fapply cocones.ext, exact i, tidy, })

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

section comp

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

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

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

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

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

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

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

end comp

end creates

end category_theory


import minimal_sub_pq
import sub_pq_normal

universe u

section pq_like_normal

variables {Q : Type u} [power_quandle Q]

theorem pq_like_normal : sub_pq_normal (gen_group_sub_pq (@of_gen_group_sub_pq Q _)) :=
begin
  intros x y,
  cases y with y hy,
  simp only [subtype.coe_mk],
  cases hy with z hz,
  rw hz,
  rw set.mem_def,
  unfold gen_group_sub_pq,
  simp only,
  unfold of_gen_group_sub_pq,
  simp only,
  unfold of_gen,
  sorry,
  --use ((counit x) ▷ z : Q),

end

end pq_like_normal


import o_minimal.sheaf.yoneda
import o_minimal.order

namespace o_minimal

variables {R : Type*} [preorder R] {S : struc R} [is_definable_le S R]

lemma definable_Ioo : definable S (set.Ioo : R → R → set R) :=
begin [defin]
  intro a,
  intro b,
  intro x,
  app, app, exact definable.and.definable _,
  { app, app, exact (definable_iff_def_rel₂.mpr definable_lt').definable _,
    var, var },
  { app, app, exact (definable_iff_def_rel₂.mpr definable_lt').definable _,
    var, var }
end

lemma definable_Iio : definable S (set.Iio : R → set R) :=
begin [defin]
  intro b,
  intro x,
  app, app, exact (definable_iff_def_rel₂.mpr definable_lt').definable _,
  var, var
end

end o_minimal


/-
Copyright (c) 2019 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Scott Morrison, Bhavik Mehta, Adam Topaz
-/
import category_theory.functor.category
import category_theory.functor.fully_faithful
import category_theory.functor.reflects_isomorphisms

/-!
# Monads

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

We construct the categories of monads and comonads, and their forgetful functors to endofunctors.

(Note that these are the category theorist's monads, not the programmers monads.
For the translation, see the file `category_theory.monad.types`.)

For the fact that monads are "just" monoids in the category of endofunctors, see the file
`category_theory.monad.equiv_mon`.
-/

namespace category_theory
open category

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

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

/--
The data of a monad on C consists of an endofunctor T together with natural transformations
η : 𝟭 C ⟶ T and μ : T ⋙ T ⟶ T satisfying three equations:
- T μ_X ≫ μ_X = μ_(TX) ≫ μ_X (associativity)
- η_(TX) ≫ μ_X = 1_X (left unit)
- Tη_X ≫ μ_X = 1_X (right unit)
-/
structure monad extends C ⥤ C :=
(η' [] : 𝟭 _ ⟶ to_functor)
(μ' [] : to_functor ⋙ to_functor ⟶ to_functor)
(assoc' : ∀ X, to_functor.map (nat_trans.app μ' X) ≫ μ'.app _ = μ'.app _ ≫ μ'.app _ . obviously)
(left_unit' : ∀ X : C, η'.app (to_functor.obj X) ≫ μ'.app _ = 𝟙 _ . obviously)
(right_unit' : ∀ X : C, to_functor.map (η'.app X) ≫ μ'.app _ = 𝟙 _ . obviously)

/--
The data of a comonad on C consists of an endofunctor G together with natural transformations
ε : G ⟶ 𝟭 C and δ : G ⟶ G ⋙ G satisfying three equations:
- δ_X ≫ G δ_X = δ_X ≫ δ_(GX) (coassociativity)
- δ_X ≫ ε_(GX) = 1_X (left counit)
- δ_X ≫ G ε_X = 1_X (right counit)
-/
structure comonad extends C ⥤ C :=
(ε' [] : to_functor ⟶ 𝟭 _)
(δ' [] : to_functor ⟶ to_functor ⋙ to_functor)
(coassoc' : ∀ X, nat_trans.app δ' _ ≫ to_functor.map (δ'.app X) = δ'.app _ ≫ δ'.app _ . obviously)
(left_counit' : ∀ X : C, δ'.app X ≫ ε'.app (to_functor.obj X) = 𝟙 _ . obviously)
(right_counit' : ∀ X : C, δ'.app X ≫ to_functor.map (ε'.app X) = 𝟙 _ . obviously)

variables {C} (T : monad C) (G : comonad C)

instance coe_monad : has_coe (monad C) (C ⥤ C) := ⟨λ T, T.to_functor⟩
instance coe_comonad : has_coe (comonad C) (C ⥤ C) := ⟨λ G, G.to_functor⟩

@[simp] lemma monad_to_functor_eq_coe : T.to_functor = T := rfl
@[simp] lemma comonad_to_functor_eq_coe : G.to_functor = G := rfl

/-- The unit for the monad `T`. -/
def monad.η : 𝟭 _ ⟶ (T : C ⥤ C) := T.η'
/-- The multiplication for the monad `T`. -/
def monad.μ : (T : C ⥤ C) ⋙ (T : C ⥤ C) ⟶ T := T.μ'

/-- The counit for the comonad `G`. -/
def comonad.ε : (G : C ⥤ C) ⟶ 𝟭 _  := G.ε'
/-- The comultiplication for the comonad `G`. -/
def comonad.δ : (G : C ⥤ C) ⟶ (G : C ⥤ C) ⋙ G := G.δ'

/-- A custom simps projection for the functor part of a monad, as a coercion. -/
def monad.simps.coe := (T : C ⥤ C)
/-- A custom simps projection for the unit of a monad, in simp normal form. -/
def monad.simps.η : 𝟭 _ ⟶ (T : C ⥤ C) := T.η
/-- A custom simps projection for the multiplication of a monad, in simp normal form. -/
def monad.simps.μ : (T : C ⥤ C) ⋙ (T : C ⥤ C) ⟶ (T : C ⥤ C) := T.μ

/-- A custom simps projection for the functor part of a comonad, as a coercion. -/
def comonad.simps.coe := (G : C ⥤ C)
/-- A custom simps projection for the counit of a comonad, in simp normal form. -/
def comonad.simps.ε : (G : C ⥤ C) ⟶ 𝟭 _ := G.ε
/-- A custom simps projection for the comultiplication of a comonad, in simp normal form. -/
def comonad.simps.δ : (G : C ⥤ C) ⟶ (G : C ⥤ C) ⋙ (G : C ⥤ C) := G.δ

initialize_simps_projections category_theory.monad (to_functor → coe, η' → η, μ' → μ)
initialize_simps_projections category_theory.comonad (to_functor → coe, ε' → ε, δ' → δ)

@[reassoc]
lemma monad.assoc (T : monad C) (X : C) :
  (T : C ⥤ C).map (T.μ.app X) ≫ T.μ.app _ = T.μ.app _ ≫ T.μ.app _ :=
T.assoc' X

@[simp, reassoc] lemma monad.left_unit (T : monad C) (X : C) :
  T.η.app ((T : C ⥤ C).obj X) ≫ T.μ.app X = 𝟙 ((T : C ⥤ C).obj X) :=
T.left_unit' X

@[simp, reassoc] lemma monad.right_unit (T : monad C) (X : C) :
  (T : C ⥤ C).map (T.η.app X) ≫ T.μ.app X = 𝟙 ((T : C ⥤ C).obj X) :=
T.right_unit' X

@[reassoc]
lemma comonad.coassoc (G : comonad C) (X : C) :
  G.δ.app _ ≫ (G : C ⥤ C).map (G.δ.app X) = G.δ.app _ ≫ G.δ.app _ :=
G.coassoc' X

@[simp, reassoc] lemma comonad.left_counit (G : comonad C) (X : C) :
  G.δ.app X ≫ G.ε.app ((G : C ⥤ C).obj X) = 𝟙 ((G : C ⥤ C).obj X) :=
G.left_counit' X

@[simp, reassoc] lemma comonad.right_counit (G : comonad C) (X : C) :
  G.δ.app X ≫ (G : C ⥤ C).map (G.ε.app X) = 𝟙 ((G : C ⥤ C).obj X) :=
G.right_counit' X

/-- A morphism of monads is a natural transformation compatible with η and μ. -/
@[ext]
structure monad_hom (T₁ T₂ : monad C) extends nat_trans (T₁ : C ⥤ C) T₂ :=
(app_η' : ∀ X, T₁.η.app X ≫ app X = T₂.η.app X . obviously)
(app_μ' : ∀ X, T₁.μ.app X ≫ app X = ((T₁ : C ⥤ C).map (app X) ≫ app _) ≫ T₂.μ.app X . obviously)

/-- A morphism of comonads is a natural transformation compatible with ε and δ. -/
@[ext]
structure comonad_hom (M N : comonad C) extends nat_trans (M : C ⥤ C) N :=
(app_ε' : ∀ X, app X ≫ N.ε.app X = M.ε.app X . obviously)
(app_δ' : ∀ X, app X ≫ N.δ.app X = M.δ.app X ≫ app _ ≫ (N : C ⥤ C).map (app X) . obviously)

restate_axiom monad_hom.app_η'
restate_axiom monad_hom.app_μ'
attribute [simp, reassoc] monad_hom.app_η monad_hom.app_μ

restate_axiom comonad_hom.app_ε'
restate_axiom comonad_hom.app_δ'
attribute [simp, reassoc] comonad_hom.app_ε comonad_hom.app_δ

instance : category (monad C) :=
{ hom := monad_hom,
  id := λ M, { to_nat_trans := 𝟙 (M : C ⥤ C) },
  comp := λ _ _ _ f g,
  { to_nat_trans :=
    { app := λ X, f.app X ≫ g.app X,
      naturality' := λ X Y h, by rw [assoc, f.1.naturality_assoc, g.1.naturality] } },
  id_comp' := λ _ _ _, by {ext, apply id_comp},
  comp_id' := λ _ _ _, by {ext, apply comp_id},
  assoc' := λ _ _ _ _ _ _ _, by {ext, apply assoc} }

instance : category (comonad C) :=
{ hom := comonad_hom,
  id := λ M, { to_nat_trans := 𝟙 (M : C ⥤ C) },
  comp := λ _ _ _ f g,
  { to_nat_trans :=
    { app := λ X, f.app X ≫ g.app X,
      naturality' := λ X Y h, by rw [assoc, f.1.naturality_assoc, g.1.naturality] } },
  id_comp' := λ _ _ _, by {ext, apply id_comp},
  comp_id' := λ _ _ _, by {ext, apply comp_id},
  assoc' := λ _ _ _ _ _ _ _, by {ext, apply assoc} }

instance {T : monad C} : inhabited (monad_hom T T) := ⟨𝟙 T⟩

@[simp]

instance {G : comonad C} : inhabited (comonad_hom G G) := ⟨𝟙 G⟩

@[simp] lemma comonad_hom.id_to_nat_trans (T : comonad C) :
  (𝟙 T : T ⟶ T).to_nat_trans = 𝟙 (T : C ⥤ C) :=
rfl
@[simp] lemma comp_to_nat_trans {T₁ T₂ T₃ : comonad C} (f : T₁ ⟶ T₂) (g : T₂ ⟶ T₃) :
  (f ≫ g).to_nat_trans =
    ((f.to_nat_trans : _ ⟶ (T₂ : C ⥤ C)) ≫ g.to_nat_trans : (T₁ : C ⥤ C) ⟶ T₃) :=
rfl

/-- Construct a monad isomorphism from a natural isomorphism of functors where the forward
direction is a monad morphism. -/
@[simps]
def monad_iso.mk {M N : monad C} (f : (M : C ⥤ C) ≅ N) (f_η f_μ) :
  M ≅ N :=
{ hom := { to_nat_trans := f.hom, app_η' := f_η, app_μ' := f_μ },
  inv :=
  { to_nat_trans := f.inv,
    app_η' := λ X, by simp [←f_η],
    app_μ' := λ X,
    begin
      rw ←nat_iso.cancel_nat_iso_hom_right f,
      simp only [nat_trans.naturality, iso.inv_hom_id_app, assoc, comp_id, f_μ,
        nat_trans.naturality_assoc, iso.inv_hom_id_app_assoc, ←functor.map_comp_assoc],
      simp,
    end } }

/-- Construct a comonad isomorphism from a natural isomorphism of functors where the forward
direction is a comonad morphism. -/
@[simps]
def comonad_iso.mk {M N : comonad C} (f : (M : C ⥤ C) ≅ N) (f_ε f_δ) :
  M ≅ N :=
{ hom := { to_nat_trans := f.hom, app_ε' := f_ε, app_δ' := f_δ },
  inv :=
  { to_nat_trans := f.inv,
    app_ε' := λ X, by simp [←f_ε],
    app_δ' := λ X,
    begin
      rw ←nat_iso.cancel_nat_iso_hom_left f,
      simp only [reassoc_of (f_δ X), iso.hom_inv_id_app_assoc, nat_trans.naturality_assoc],
      rw [←functor.map_comp, iso.hom_inv_id_app, functor.map_id],
      apply (comp_id _).symm
    end } }

variable (C)

/--
The forgetful functor from the category of monads to the category of endofunctors.
-/
@[simps]
def monad_to_functor : monad C ⥤ (C ⥤ C) :=
{ obj := λ T, T,
  map := λ M N f, f.to_nat_trans }

instance : faithful (monad_to_functor C) := {}.

@[simp]
lemma monad_to_functor_map_iso_monad_iso_mk {M N : monad C} (f : (M : C ⥤ C) ≅ N) (f_η f_μ) :
  (monad_to_functor _).map_iso (monad_iso.mk f f_η f_μ) = f :=
by { ext, refl }

instance : reflects_isomorphisms (monad_to_functor C) :=
{ reflects := λ M N f i,
  begin
    resetI,
    convert is_iso.of_iso (monad_iso.mk (as_iso ((monad_to_functor C).map f)) f.app_η f.app_μ),
    ext; refl,
  end }

/--
The forgetful functor from the category of comonads to the category of endofunctors.
-/
@[simps]
def comonad_to_functor : comonad C ⥤ (C ⥤ C) :=
{ obj := λ G, G,
  map := λ M N f, f.to_nat_trans }

instance : faithful (comonad_to_functor C) := {}.

@[simp]
lemma comonad_to_functor_map_iso_comonad_iso_mk {M N : comonad C} (f : (M : C ⥤ C) ≅ N) (f_ε f_δ) :
  (comonad_to_functor _).map_iso (comonad_iso.mk f f_ε f_δ) = f :=
by { ext, refl }

instance : reflects_isomorphisms (comonad_to_functor C) :=
{ reflects := λ M N f i,
  begin
    resetI,
    convert is_iso.of_iso (comonad_iso.mk (as_iso ((comonad_to_functor C).map f)) f.app_ε f.app_δ),
    ext; refl,
  end }

variable {C}

/--
An isomorphism of monads gives a natural isomorphism of the underlying functors.
-/
@[simps {rhs_md := semireducible}]
def monad_iso.to_nat_iso {M N : monad C} (h : M ≅ N) : (M : C ⥤ C) ≅ N :=
(monad_to_functor C).map_iso h

/--
An isomorphism of comonads gives a natural isomorphism of the underlying functors.
-/
@[simps {rhs_md := semireducible}]
def comonad_iso.to_nat_iso {M N : comonad C} (h : M ≅ N) : (M : C ⥤ C) ≅ N :=
(comonad_to_functor C).map_iso h

variable (C)

namespace monad

/-- The identity monad. -/
@[simps]
def id : monad C :=
{ to_functor := 𝟭 C,
  η' := 𝟙 (𝟭 C),
  μ' := 𝟙 (𝟭 C) }

instance : inhabited (monad C) := ⟨monad.id C⟩

end monad

namespace comonad

/-- The identity comonad. -/
@[simps]
def id : comonad C :=
{ to_functor := 𝟭 _,
  ε' := 𝟙 (𝟭 C),
  δ' := 𝟙 (𝟭 C) }

instance : inhabited (comonad C) := ⟨comonad.id C⟩

end comonad

end category_theory


theorem bad : ∀ (m n : Nat), (if m = n then Ordering.eq else Ordering.gt) = Ordering.lt → False := by
  intros m n
  cases (Nat.decEq m n) with -- an error as expected: "alternative `isFalse` has not bee provided"
  | isTrue h =>
    set_option trace.Meta.Tactic.simp true in
    simp [h]

theorem bad' : ∀ (m n : Nat), (if m = n then Ordering.eq else Ordering.gt) = Ordering.lt → False := by
  intros m n
  cases (Nat.decEq m n) with
  | isTrue h =>
    simp [h]
  | isFalse h =>
    simp [h]