/-
Copyright (c) 2018 Johannes Hölzl. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Johannes Hölzl, Callum Sutton, Yury Kudryashov
Ported by: Anatole Dedecker

! This file was ported from Lean 3 source module algebra.ring.equiv
! leanprover-community/mathlib commit a59dad53320b73ef180174aae867addd707ef00e
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathlib.Algebra.Group.Opposite
import Mathlib.Algebra.Hom.Ring
import Mathlib.Logic.Equiv.Set

/-!
# (Semi)ring equivs

In this file we define an extension of `Equiv` called `RingEquiv`, which is a datatype representing
an isomorphism of `Semiring`s, `Ring`s, `DivisionRing`s, or `Field`s.

## Notations

* ``infixl ` ≃+* `:25 := RingEquiv``

The extended equiv have coercions to functions, and the coercion is the canonical notation when
treating the isomorphism as maps.

## Implementation notes

The fields for `RingEquiv` now avoid the unbundled `isMulHom` and `isAddHom`, as these are
deprecated.

Definition of multiplication in the groups of automorphisms agrees with function composition,
multiplication in `Equiv.Perm`, and multiplication in `CategoryTheory.End`, not with
`CategoryTheory.CategoryStruct.comp`.

## Tags

Equiv, MulEquiv, AddEquiv, RingEquiv, MulAut, AddAut, RingAut
-/

variable {F α β R S S' : Type _}

/-- An equivalence between two (non-unital non-associative semi)rings that preserves the
algebraic structure. -/
structure RingEquiv (R S : Type _) [Mul R] [Mul S] [Add R] [Add S] extends R ≃ S, R ≃* S, R ≃+ S
#align ring_equiv RingEquiv

-- mathport name: «expr ≃+* »*
/-- Notation for `RingEquiv`. -/
infixl:25 " ≃+* " => RingEquiv

/-- The "plain" equivalence of types underlying an equivalence of (semi)rings. -/
add_decl_doc RingEquiv.toEquiv
#align ring_equiv.to_equiv RingEquiv.toEquiv

/-- The equivalence of additive monoids underlying an equivalence of (semi)rings. -/
add_decl_doc RingEquiv.toAddEquiv
#align ring_equiv.to_add_equiv RingEquiv.toAddEquiv

/-- The equivalence of multiplicative monoids underlying an equivalence of (semi)rings. -/
add_decl_doc RingEquiv.toMulEquiv
#align ring_equiv.to_mul_equiv RingEquiv.toMulEquiv

/-- `RingEquivClass F R S` states that `F` is a type of ring structure preserving equivalences.
You should extend this class when you extend `RingEquiv`. -/
class RingEquivClass (F : Type _) (R S : outParam (Type _)) [Mul R] [Add R] [Mul S] [Add S] extends
  MulEquivClass F R S where
  /-- By definition, a ring isomorphism preserves the additive structure. -/
  map_add : ∀ (f : F) (a b), f (a + b) = f a + f b
#align ring_equiv_class RingEquivClass

namespace RingEquivClass

-- See note [lower instance priority]
instance (priority := 100) toAddEquivClass {_ : Mul R} {_ : Add R}
    {_ : Mul S} {_ : Add S} [h : RingEquivClass F R S] : AddEquivClass F R S :=
  { h with coe := h.coe }
#align ring_equiv_class.to_add_equiv_class RingEquivClass.toAddEquivClass

-- See note [lower instance priority]
instance (priority := 100) toRingHomClass {_ : NonAssocSemiring R} {_ : NonAssocSemiring S}
    [h : RingEquivClass F R S] : RingHomClass F R S :=
  { h with
    coe := h.coe
    coe_injective' := FunLike.coe_injective
    map_zero := map_zero
    map_one := map_one }
#align ring_equiv_class.to_ring_hom_class RingEquivClass.toRingHomClass

-- See note [lower instance priority]
instance (priority := 100) toNonUnitalRingHomClass {_ : NonUnitalNonAssocSemiring R}
    {_ : NonUnitalNonAssocSemiring S} [h : RingEquivClass F R S] : NonUnitalRingHomClass F R S :=
  { h with
    coe := h.coe
    coe_injective' := FunLike.coe_injective
    map_zero := map_zero }
#align ring_equiv_class.to_non_unital_ring_hom_class RingEquivClass.toNonUnitalRingHomClass

/-- Turn an element of a type `F` satisfying `RingEquivClass F α β` into an actual
`RingEquiv`. This is declared as the default coercion from `F` to `α ≃+* β`. -/
@[coe]
def toRingEquiv [Mul α] [Add α] [Mul β] [Add β] [RingEquivClass F α β] (f : F) :
  α ≃+* β :=
{ (f : α ≃* β), (f : α ≃+ β) with }

end RingEquivClass

/-- Any type satisfying `RingEquivClass` can be cast into `RingEquiv` via
`RingEquivClass.toRingEquiv`. -/
instance [Mul α] [Add α] [Mul β] [Add β] [RingEquivClass F α β] : CoeTC F (α ≃+* β) :=
  ⟨RingEquivClass.toRingEquiv⟩

namespace RingEquiv

section Basic

variable [Mul R] [Mul S] [Add R] [Add S] [Mul S'] [Add S']

instance : RingEquivClass (R ≃+* S) R S where
  coe f := f.toFun
  inv f := f.invFun
  coe_injective' e f h₁ h₂ := by
    cases e
    cases f
    congr
    apply Equiv.coe_fn_injective h₁
  map_add := map_add'
  map_mul := map_mul'
  left_inv f := f.left_inv
  right_inv f := f.right_inv

@[simp]
theorem toEquiv_eq_coe (f : R ≃+* S) : f.toEquiv = f :=
  rfl
#align ring_equiv.to_equiv_eq_coe RingEquiv.toEquiv_eq_coe

-- Porting note: `toFun_eq_coe` no longer needed in Lean4
#noalign ring_equiv.to_fun_eq_coe

@[simp]
theorem coe_toEquiv (f : R ≃+* S) : ⇑(f : R ≃ S) = f :=
  rfl
#align ring_equiv.coe_to_equiv RingEquiv.coe_toEquiv

/-- A ring isomorphism preserves multiplication. -/
protected theorem map_mul (e : R ≃+* S) (x y : R) : e (x * y) = e x * e y :=
  map_mul e x y
#align ring_equiv.map_mul RingEquiv.map_mul

/-- A ring isomorphism preserves addition. -/
protected theorem map_add (e : R ≃+* S) (x y : R) : e (x + y) = e x + e y :=
  map_add e x y
#align ring_equiv.map_add RingEquiv.map_add

/-- Two ring isomorphisms agree if they are defined by the
    same underlying function. -/
@[ext]
theorem ext {f g : R ≃+* S} (h : ∀ x, f x = g x) : f = g :=
  FunLike.ext f g h
#align ring_equiv.ext RingEquiv.ext

@[simp]
theorem coe_mk (e h₃ h₄) : ⇑(⟨e, h₃, h₄⟩ : R ≃+* S) = e :=
  rfl
#align ring_equiv.coe_mk RingEquiv.coe_mkₓ

-- Porting note: `toEquiv_mk` no longer needed in Lean4
#noalign ring_equiv.to_equiv_mk

@[simp]
theorem mk_coe (e : R ≃+* S) (e' h₁ h₂ h₃ h₄) : (⟨⟨e, e', h₁, h₂⟩, h₃, h₄⟩ : R ≃+* S) = e :=
  ext fun _ => rfl
#align ring_equiv.mk_coe RingEquiv.mk_coe

protected theorem congr_arg {f : R ≃+* S} {x x' : R} : x = x' → f x = f x' :=
  FunLike.congr_arg f
#align ring_equiv.congr_arg RingEquiv.congr_arg

protected theorem congr_fun {f g : R ≃+* S} (h : f = g) (x : R) : f x = g x :=
  FunLike.congr_fun h x
#align ring_equiv.congr_fun RingEquiv.congr_fun

protected theorem ext_iff {f g : R ≃+* S} : f = g ↔ ∀ x, f x = g x :=
  FunLike.ext_iff
#align ring_equiv.ext_iff RingEquiv.ext_iff

@[simp]
theorem toAddEquiv_eq_coe (f : R ≃+* S) : f.toAddEquiv = ↑f :=
  rfl
#align ring_equiv.to_add_equiv_eq_coe RingEquiv.toAddEquiv_eq_coe

@[simp]
theorem toMulEquiv_eq_coe (f : R ≃+* S) : f.toMulEquiv = ↑f :=
  rfl
#align ring_equiv.to_mul_equiv_eq_coe RingEquiv.toMulEquiv_eq_coe

@[simp, norm_cast]
theorem coe_toMulEquiv (f : R ≃+* S) : ⇑(f : R ≃* S) = f :=
  rfl
#align ring_equiv.coe_to_mul_equiv RingEquiv.coe_toMulEquiv

@[simp]
theorem coe_toAddEquiv (f : R ≃+* S) : ⇑(f : R ≃+ S) = f :=
  rfl
#align ring_equiv.coe_to_add_equiv RingEquiv.coe_toAddEquiv

/-- The `RingEquiv` between two semirings with a unique element. -/
def ringEquivOfUnique {M N} [Unique M] [Unique N] [Add M] [Mul M] [Add N] [Mul N] : M ≃+* N :=
  { AddEquiv.addEquivOfUnique, MulEquiv.mulEquivOfUnique with }
#align ring_equiv.ring_equiv_of_unique RingEquiv.ringEquivOfUnique

instance {M N} [Unique M] [Unique N] [Add M] [Mul M] [Add N] [Mul N] :
    Unique (M ≃+* N) where
  default := ringEquivOfUnique
  uniq _ := ext fun _ => Subsingleton.elim _ _

variable (R)

/-- The identity map is a ring isomorphism. -/
@[refl]
def refl : R ≃+* R :=
  { MulEquiv.refl R, AddEquiv.refl R with }
#align ring_equiv.refl RingEquiv.refl

@[simp]
theorem refl_apply (x : R) : RingEquiv.refl R x = x :=
  rfl
#align ring_equiv.refl_apply RingEquiv.refl_apply

@[simp]
theorem coe_addEquiv_refl : (RingEquiv.refl R : R ≃+ R) = AddEquiv.refl R :=
  rfl
#align ring_equiv.coe_add_equiv_refl RingEquiv.coe_addEquiv_refl

@[simp]
theorem coe_mulEquiv_refl : (RingEquiv.refl R : R ≃* R) = MulEquiv.refl R :=
  rfl
#align ring_equiv.coe_mul_equiv_refl RingEquiv.coe_mulEquiv_refl

instance : Inhabited (R ≃+* R) :=
  ⟨RingEquiv.refl R⟩

variable {R}

/-- The inverse of a ring isomorphism is a ring isomorphism. -/
@[symm]
protected def symm (e : R ≃+* S) : S ≃+* R :=
  { e.toMulEquiv.symm, e.toAddEquiv.symm with }
#align ring_equiv.symm RingEquiv.symm

/-- See Note [custom simps projection] -/
def Simps.symm_apply (e : R ≃+* S) : S → R :=
  e.symm
#align ring_equiv.simps.symm_apply RingEquiv.Simps.symm_apply

initialize_simps_projections RingEquiv (toFun → apply, invFun → symm_apply)

@[simp]
theorem invFun_eq_symm (f : R ≃+* S) : EquivLike.inv f = f.symm :=
  rfl
#align ring_equiv.inv_fun_eq_symm RingEquiv.invFun_eq_symm

@[simp]
theorem symm_symm (e : R ≃+* S) : e.symm.symm = e :=
  ext fun _ => rfl
#align ring_equiv.symm_symm RingEquiv.symm_symm

--Porting note: new theorem
@[simp]
theorem symm_refl : (RingEquiv.refl R).symm = RingEquiv.refl R :=
  rfl

@[simp]
theorem coe_toEquiv_symm (e : R ≃+* S) : (e.symm : S ≃ R) = (e : R ≃ S).symm :=
  rfl
#align ring_equiv.coe_to_equiv_symm RingEquiv.coe_toEquiv_symm

theorem symm_bijective : Function.Bijective (RingEquiv.symm : R ≃+* S → S ≃+* R) :=
  Equiv.bijective ⟨RingEquiv.symm, RingEquiv.symm, symm_symm, symm_symm⟩
#align ring_equiv.symm_bijective RingEquiv.symm_bijective

@[simp]
theorem mk_coe' (e : R ≃+* S) (f h₁ h₂ h₃ h₄) :
    (⟨⟨f, ⇑e, h₁, h₂⟩, h₃, h₄⟩ : S ≃+* R) = e.symm :=
  symm_bijective.injective <| ext fun _ => rfl
#align ring_equiv.mk_coe' RingEquiv.mk_coe'

@[simp]
theorem symm_mk (f : R → S) (g h₁ h₂ h₃ h₄) :
    (mk ⟨f, g, h₁, h₂⟩ h₃ h₄).symm =
      { (mk ⟨f, g, h₁, h₂⟩ h₃ h₄).symm with
        toFun := g
        invFun := f } :=
  rfl
#align ring_equiv.symm_mk RingEquiv.symm_mk

/-- Transitivity of `RingEquiv`. -/
@[trans]
protected def trans (e₁ : R ≃+* S) (e₂ : S ≃+* S') : R ≃+* S' :=
  { e₁.toMulEquiv.trans e₂.toMulEquiv, e₁.toAddEquiv.trans e₂.toAddEquiv with }
#align ring_equiv.trans RingEquiv.trans

theorem trans_apply (e₁ : R ≃+* S) (e₂ : S ≃+* S') (a : R) : e₁.trans e₂ a = e₂ (e₁ a) :=
  rfl
#align ring_equiv.trans_apply RingEquiv.trans_apply

@[simp]
theorem coe_trans (e₁ : R ≃+* S) (e₂ : S ≃+* S') : (e₁.trans e₂ : R → S') = e₂ ∘ e₁ :=
  rfl
#align ring_equiv.coe_trans RingEquiv.coe_trans

@[simp]
theorem symm_trans_apply (e₁ : R ≃+* S) (e₂ : S ≃+* S') (a : S') :
    (e₁.trans e₂).symm a = e₁.symm (e₂.symm a) :=
  rfl
#align ring_equiv.symm_trans_apply RingEquiv.symm_trans_apply

theorem symm_trans (e₁ : R ≃+* S) (e₂ : S ≃+* S') : (e₁.trans e₂).symm = e₂.symm.trans e₁.symm :=
  rfl
#align ring_equiv.symm_trans RingEquiv.symm_trans

protected theorem bijective (e : R ≃+* S) : Function.Bijective e :=
  EquivLike.bijective e
#align ring_equiv.bijective RingEquiv.bijective

protected theorem injective (e : R ≃+* S) : Function.Injective e :=
  EquivLike.injective e
#align ring_equiv.injective RingEquiv.injective

protected theorem surjective (e : R ≃+* S) : Function.Surjective e :=
  EquivLike.surjective e
#align ring_equiv.surjective RingEquiv.surjective

@[simp]
theorem apply_symm_apply (e : R ≃+* S) : ∀ x, e (e.symm x) = x :=
  e.toEquiv.apply_symm_apply
#align ring_equiv.apply_symm_apply RingEquiv.apply_symm_apply

@[simp]
theorem symm_apply_apply (e : R ≃+* S) : ∀ x, e.symm (e x) = x :=
  e.toEquiv.symm_apply_apply
#align ring_equiv.symm_apply_apply RingEquiv.symm_apply_apply

theorem image_eq_preimage (e : R ≃+* S) (s : Set R) : e '' s = e.symm ⁻¹' s :=
  e.toEquiv.image_eq_preimage s
#align ring_equiv.image_eq_preimage RingEquiv.image_eq_preimage

@[simp]
theorem coe_mulEquiv_trans (e₁ : R ≃+* S) (e₂ : S ≃+* S') :
    (e₁.trans e₂ : R ≃* S') = (e₁ : R ≃* S).trans ↑e₂ :=
  rfl
#align ring_equiv.coe_mul_equiv_trans RingEquiv.coe_mulEquiv_trans

@[simp]
theorem coe_addEquiv_trans (e₁ : R ≃+* S) (e₂ : S ≃+* S') :
    (e₁.trans e₂ : R ≃+ S') = (e₁ : R ≃+ S).trans ↑e₂ :=
  rfl
#align ring_equiv.coe_add_equiv_trans RingEquiv.coe_addEquiv_trans

end Basic

section Opposite

open MulOpposite

/-- A ring iso `α ≃+* β` can equivalently be viewed as a ring iso `αᵐᵒᵖ ≃+* βᵐᵒᵖ`. -/
@[simps!]
protected def op {α β} [Add α] [Mul α] [Add β] [Mul β] :
    α ≃+* β ≃ (αᵐᵒᵖ ≃+* βᵐᵒᵖ) where
  toFun f := { AddEquiv.mulOp f.toAddEquiv, MulEquiv.op f.toMulEquiv with }
  invFun f := { AddEquiv.mulOp.symm f.toAddEquiv, MulEquiv.op.symm f.toMulEquiv with }
  left_inv f := by
    ext
    rfl
  right_inv f := by
    ext
    rfl
#align ring_equiv.op RingEquiv.op
#align ring_equiv.op_symm_apply_apply RingEquiv.op_symm_apply_apply
#align ring_equiv.op_symm_apply_symm_apply RingEquiv.op_symm_apply_symm_apply

/-- The 'unopposite' of a ring iso `αᵐᵒᵖ ≃+* βᵐᵒᵖ`. Inverse to `RingEquiv.op`. -/
@[simp]
protected def unop {α β} [Add α] [Mul α] [Add β] [Mul β] : αᵐᵒᵖ ≃+* βᵐᵒᵖ ≃ (α ≃+* β) :=
  RingEquiv.op.symm
#align ring_equiv.unop RingEquiv.unop

section NonUnitalCommSemiring

variable (R) [NonUnitalCommSemiring R]

/-- A non-unital commutative ring is isomorphic to its opposite. -/
def toOpposite : R ≃+* Rᵐᵒᵖ :=
  { MulOpposite.opEquiv with
    map_add' := fun _ _ => rfl
    map_mul' := fun x y => mul_comm (op y) (op x) }
#align ring_equiv.to_opposite RingEquiv.toOpposite

@[simp]
theorem toOpposite_apply (r : R) : toOpposite R r = op r :=
  rfl
#align ring_equiv.to_opposite_apply RingEquiv.toOpposite_apply

@[simp]
theorem toOpposite_symm_apply (r : Rᵐᵒᵖ) : (toOpposite R).symm r = unop r :=
  rfl
#align ring_equiv.to_opposite_symm_apply RingEquiv.toOpposite_symm_apply

end NonUnitalCommSemiring

end Opposite

section NonUnitalSemiring

variable [NonUnitalNonAssocSemiring R] [NonUnitalNonAssocSemiring S] (f : R ≃+* S) (x y : R)

/-- A ring isomorphism sends zero to zero. -/
protected theorem map_zero : f 0 = 0 :=
  map_zero f
#align ring_equiv.map_zero RingEquiv.map_zero

variable {x}

protected theorem map_eq_zero_iff : f x = 0 ↔ x = 0 :=
  AddEquivClass.map_eq_zero_iff f
#align ring_equiv.map_eq_zero_iff RingEquiv.map_eq_zero_iff

theorem map_ne_zero_iff : f x ≠ 0 ↔ x ≠ 0 :=
  AddEquivClass.map_ne_zero_iff f
#align ring_equiv.map_ne_zero_iff RingEquiv.map_ne_zero_iff

/-- Produce a ring isomorphism from a bijective ring homomorphism. -/
noncomputable def ofBijective [NonUnitalRingHomClass F R S] (f : F) (hf : Function.Bijective f) :
    R ≃+* S :=
  { Equiv.ofBijective f hf with
    map_mul' := map_mul f
    map_add' := map_add f }
#align ring_equiv.of_bijective RingEquiv.ofBijective

@[simp]
theorem coe_ofBijective [NonUnitalRingHomClass F R S] (f : F) (hf : Function.Bijective f) :
    (ofBijective f hf : R → S) = f :=
  rfl
#align ring_equiv.coe_of_bijective RingEquiv.coe_ofBijective

theorem ofBijective_apply [NonUnitalRingHomClass F R S] (f : F) (hf : Function.Bijective f)
    (x : R) : ofBijective f hf x = f x :=
  rfl
#align ring_equiv.of_bijective_apply RingEquiv.ofBijective_apply

/-- A family of ring isomorphisms `∀ j, (R j ≃+* S j)` generates a
ring isomorphisms between `∀ j, R j` and `∀ j, S j`.

This is the `RingEquiv` version of `Equiv.piCongrRight`, and the dependent version of
`RingEquiv.arrowCongr`.
-/
@[simps apply]
def piCongrRight {ι : Type _} {R S : ι → Type _} [∀ i, NonUnitalNonAssocSemiring (R i)]
    [∀ i, NonUnitalNonAssocSemiring (S i)] (e : ∀ i, R i ≃+* S i) : (∀ i, R i) ≃+* ∀ i, S i :=
  { @MulEquiv.piCongrRight ι R S _ _ fun i => (e i).toMulEquiv,
    @AddEquiv.piCongrRight ι R S _ _ fun i => (e i).toAddEquiv with
    toFun := fun x j => e j (x j)
    invFun := fun x j => (e j).symm (x j) }
#align ring_equiv.Pi_congr_right RingEquiv.piCongrRight
#align ring_equiv.Pi_congr_right_apply RingEquiv.piCongrRight_apply

@[simp]
theorem piCongrRight_refl {ι : Type _} {R : ι → Type _} [∀ i, NonUnitalNonAssocSemiring (R i)] :
    (piCongrRight fun i => RingEquiv.refl (R i)) = RingEquiv.refl _ :=
  rfl
#align ring_equiv.Pi_congr_right_refl RingEquiv.piCongrRight_refl

@[simp]
theorem piCongrRight_symm {ι : Type _} {R S : ι → Type _} [∀ i, NonUnitalNonAssocSemiring (R i)]
    [∀ i, NonUnitalNonAssocSemiring (S i)] (e : ∀ i, R i ≃+* S i) :
    (piCongrRight e).symm = piCongrRight fun i => (e i).symm :=
  rfl
#align ring_equiv.Pi_congr_right_symm RingEquiv.piCongrRight_symm

@[simp]
theorem piCongrRight_trans {ι : Type _} {R S T : ι → Type _}
    [∀ i, NonUnitalNonAssocSemiring (R i)] [∀ i, NonUnitalNonAssocSemiring (S i)]
    [∀ i, NonUnitalNonAssocSemiring (T i)] (e : ∀ i, R i ≃+* S i) (f : ∀ i, S i ≃+* T i) :
    (piCongrRight e).trans (piCongrRight f) = piCongrRight fun i => (e i).trans (f i) :=
  rfl
#align ring_equiv.Pi_congr_right_trans RingEquiv.piCongrRight_trans

end NonUnitalSemiring

section Semiring

variable [NonAssocSemiring R] [NonAssocSemiring S] (f : R ≃+* S) (x y : R)

/-- A ring isomorphism sends one to one. -/
protected theorem map_one : f 1 = 1 :=
  map_one f
#align ring_equiv.map_one RingEquiv.map_one

variable {x}

protected theorem map_eq_one_iff : f x = 1 ↔ x = 1 :=
  MulEquivClass.map_eq_one_iff f
#align ring_equiv.map_eq_one_iff RingEquiv.map_eq_one_iff

theorem map_ne_one_iff : f x ≠ 1 ↔ x ≠ 1 :=
  MulEquivClass.map_ne_one_iff f
#align ring_equiv.map_ne_one_iff RingEquiv.map_ne_one_iff

theorem coe_monoidHom_refl : (RingEquiv.refl R : R →* R) = MonoidHom.id R :=
  rfl
#align ring_equiv.coe_monoid_hom_refl RingEquiv.coe_monoidHom_refl

@[simp]
theorem coe_addMonoidHom_refl : (RingEquiv.refl R : R →+ R) = AddMonoidHom.id R :=
  rfl
#align ring_equiv.coe_add_monoid_hom_refl RingEquiv.coe_addMonoidHom_refl

/-! `RingEquiv.coe_mulEquiv_refl` and `RingEquiv.coe_addEquiv_refl` are proved above
in higher generality -/

@[simp]

@[simp]
theorem coe_monoidHom_trans [NonAssocSemiring S'] (e₁ : R ≃+* S) (e₂ : S ≃+* S') :
    (e₁.trans e₂ : R →* S') = (e₂ : S →* S').comp ↑e₁ :=
  rfl
#align ring_equiv.coe_monoid_hom_trans RingEquiv.coe_monoidHom_trans

@[simp]
theorem coe_addMonoidHom_trans [NonAssocSemiring S'] (e₁ : R ≃+* S) (e₂ : S ≃+* S') :
    (e₁.trans e₂ : R →+ S') = (e₂ : S →+ S').comp ↑e₁ :=
  rfl
#align ring_equiv.coe_add_monoid_hom_trans RingEquiv.coe_addMonoidHom_trans

/-! `RingEquiv.coe_mulEquiv_trans` and `RingEquiv.coe_addEquiv_trans` are proved above
in higher generality -/

@[simp]
theorem coe_ringHom_trans [NonAssocSemiring S'] (e₁ : R ≃+* S) (e₂ : S ≃+* S') :
    (e₁.trans e₂ : R →+* S') = (e₂ : S →+* S').comp ↑e₁ :=
  rfl
#align ring_equiv.coe_ring_hom_trans RingEquiv.coe_ringHom_trans

@[simp]
theorem comp_symm (e : R ≃+* S) : (e : R →+* S).comp (e.symm : S →+* R) = RingHom.id S :=
  RingHom.ext e.apply_symm_apply
#align ring_equiv.comp_symm RingEquiv.comp_symm

@[simp]
theorem symm_comp (e : R ≃+* S) : (e.symm : S →+* R).comp (e : R →+* S) = RingHom.id R :=
  RingHom.ext e.symm_apply_apply
#align ring_equiv.symm_comp RingEquiv.symm_comp

end Semiring

section NonUnitalRing

variable [NonUnitalNonAssocRing R] [NonUnitalNonAssocRing S] (f : R ≃+* S) (x y : R)

protected theorem map_neg : f (-x) = -f x :=
  map_neg f x
#align ring_equiv.map_neg RingEquiv.map_neg

protected theorem map_sub : f (x - y) = f x - f y :=
  map_sub f x y
#align ring_equiv.map_sub RingEquiv.map_sub

end NonUnitalRing

section Ring

variable [NonAssocRing R] [NonAssocRing S] (f : R ≃+* S) (x y : R)

-- Porting note: `simp` can now prove that, so we remove the `@[simp]` tag
theorem map_neg_one : f (-1) = -1 :=
  f.map_one ▸ f.map_neg 1
#align ring_equiv.map_neg_one RingEquiv.map_neg_one

end Ring

section NonUnitalSemiringHom

variable [NonUnitalNonAssocSemiring R] [NonUnitalNonAssocSemiring S] [NonUnitalNonAssocSemiring S']

/-- Reinterpret a ring equivalence as a non-unital ring homomorphism. -/
def toNonUnitalRingHom (e : R ≃+* S) : R →ₙ+* S :=
  { e.toMulEquiv.toMulHom, e.toAddEquiv.toAddMonoidHom with }
#align ring_equiv.to_non_unital_ring_hom RingEquiv.toNonUnitalRingHom

theorem toNonUnitalRingHom_injective :
    Function.Injective (toNonUnitalRingHom : R ≃+* S → R →ₙ+* S) := fun _ _ h =>
  RingEquiv.ext (NonUnitalRingHom.ext_iff.1 h)
#align ring_equiv.to_non_unital_ring_hom_injective RingEquiv.toNonUnitalRingHom_injective

/- The instance priority is lowered here so that in the case when `R` and `S` are both unital, Lean
will first find and use `RingEquiv.instCoeToRingHom`. -/
instance (priority := 900) instCoeToNonUnitalRingHom : Coe (R ≃+* S) (R →ₙ+* S) :=
  ⟨RingEquiv.toNonUnitalRingHom⟩
#align ring_equiv.has_coe_to_non_unital_ring_hom RingEquiv.instCoeToNonUnitalRingHom

theorem toNonUnitalRingHom_eq_coe (f : R ≃+* S) : f.toNonUnitalRingHom = ↑f :=
  rfl
#align ring_equiv.to_non_unital_ring_hom_eq_coe RingEquiv.toNonUnitalRingHom_eq_coe

@[simp, norm_cast]
theorem coe_toNonUnitalRingHom (f : R ≃+* S) : ⇑(f : R →ₙ+* S) = f :=
  rfl
#align ring_equiv.coe_to_non_unital_ring_hom RingEquiv.coe_toNonUnitalRingHom

theorem coe_nonUnitalRingHom_inj_iff {R S : Type _} [NonUnitalNonAssocSemiring R]
    [NonUnitalNonAssocSemiring S] (f g : R ≃+* S) : f = g ↔ (f : R →ₙ+* S) = g :=
  ⟨fun h => by rw [h], fun h => ext <| NonUnitalRingHom.ext_iff.mp h⟩
#align ring_equiv.coe_non_unital_ring_hom_inj_iff RingEquiv.coe_nonUnitalRingHom_inj_iff

@[simp]
theorem toNonUnitalRingHom_refl :
    (RingEquiv.refl R).toNonUnitalRingHom = NonUnitalRingHom.id R :=
  rfl
#align ring_equiv.to_non_unital_ring_hom_refl RingEquiv.toNonUnitalRingHom_refl

@[simp]
theorem toNonUnitalRingHom_apply_symm_toNonUnitalRingHom_apply (e : R ≃+* S) :
    ∀ y : S, e.toNonUnitalRingHom (e.symm.toNonUnitalRingHom y) = y :=
  e.toEquiv.apply_symm_apply
#align ring_equiv.to_non_unital_ring_hom_apply_symm_to_non_unital_ring_hom_apply RingEquiv.toNonUnitalRingHom_apply_symm_toNonUnitalRingHom_apply

@[simp]
theorem symm_toNonUnitalRingHom_apply_toNonUnitalRingHom_apply (e : R ≃+* S) :
    ∀ x : R, e.symm.toNonUnitalRingHom (e.toNonUnitalRingHom x) = x :=
  Equiv.symm_apply_apply e.toEquiv
#align ring_equiv.symm_to_non_unital_ring_hom_apply_to_non_unital_ring_hom_apply RingEquiv.symm_toNonUnitalRingHom_apply_toNonUnitalRingHom_apply

@[simp]
theorem toNonUnitalRingHom_trans (e₁ : R ≃+* S) (e₂ : S ≃+* S') :
    (e₁.trans e₂).toNonUnitalRingHom = e₂.toNonUnitalRingHom.comp e₁.toNonUnitalRingHom :=
  rfl
#align ring_equiv.to_non_unital_ring_hom_trans RingEquiv.toNonUnitalRingHom_trans

@[simp]
theorem toNonUnitalRingHomm_comp_symm_toNonUnitalRingHom (e : R ≃+* S) :
    e.toNonUnitalRingHom.comp e.symm.toNonUnitalRingHom = NonUnitalRingHom.id _ := by
  ext
  simp
#align ring_equiv.to_non_unital_ring_hom_comp_symm_to_non_unital_ring_hom RingEquiv.toNonUnitalRingHomm_comp_symm_toNonUnitalRingHom

@[simp]
theorem symm_toNonUnitalRingHom_comp_toNonUnitalRingHom (e : R ≃+* S) :
    e.symm.toNonUnitalRingHom.comp e.toNonUnitalRingHom = NonUnitalRingHom.id _ := by
  ext
  simp
#align ring_equiv.symm_to_non_unital_ring_hom_comp_to_non_unital_ring_hom RingEquiv.symm_toNonUnitalRingHom_comp_toNonUnitalRingHom

end NonUnitalSemiringHom

section SemiringHom

variable [NonAssocSemiring R] [NonAssocSemiring S] [NonAssocSemiring S']

/-- Reinterpret a ring equivalence as a ring homomorphism. -/
def toRingHom (e : R ≃+* S) : R →+* S :=
  { e.toMulEquiv.toMonoidHom, e.toAddEquiv.toAddMonoidHom with }
#align ring_equiv.to_ring_hom RingEquiv.toRingHom

theorem toRingHom_injective : Function.Injective (toRingHom : R ≃+* S → R →+* S) := fun _ _ h =>
  RingEquiv.ext (RingHom.ext_iff.1 h)
#align ring_equiv.to_ring_hom_injective RingEquiv.toRingHom_injective

instance instCoeToRingHom : Coe (R ≃+* S) (R →+* S) :=
  ⟨RingEquiv.toRingHom⟩
#align ring_equiv.has_coe_to_ring_hom RingEquiv.instCoeToRingHom

theorem toRingHom_eq_coe (f : R ≃+* S) : f.toRingHom = ↑f :=
  rfl
#align ring_equiv.to_ring_hom_eq_coe RingEquiv.toRingHom_eq_coe

@[simp, norm_cast]
theorem coe_toRingHom (f : R ≃+* S) : ⇑(f : R →+* S) = f :=
  rfl
#align ring_equiv.coe_to_ring_hom RingEquiv.coe_toRingHom

theorem coe_ringHom_inj_iff {R S : Type _} [NonAssocSemiring R] [NonAssocSemiring S]
    (f g : R ≃+* S) : f = g ↔ (f : R →+* S) = g :=
  ⟨fun h => by rw [h], fun h => ext <| RingHom.ext_iff.mp h⟩
#align ring_equiv.coe_ring_hom_inj_iff RingEquiv.coe_ringHom_inj_iff

/-- The two paths coercion can take to a `NonUnitalRingEquiv` are equivalent -/
@[simp, norm_cast]
theorem toNonUnitalRingHom_commutes (f : R ≃+* S) :
    ((f : R →+* S) : R →ₙ+* S) = (f : R →ₙ+* S) :=
  rfl
#align ring_equiv.to_non_unital_ring_hom_commutes RingEquiv.toNonUnitalRingHom_commutes

/-- Reinterpret a ring equivalence as a monoid homomorphism. -/
abbrev toMonoidHom (e : R ≃+* S) : R →* S :=
  e.toRingHom.toMonoidHom
#align ring_equiv.to_monoid_hom RingEquiv.toMonoidHom

/-- Reinterpret a ring equivalence as an `AddMonoid` homomorphism. -/
abbrev toAddMonoidHom (e : R ≃+* S) : R →+ S :=
  e.toRingHom.toAddMonoidHom
#align ring_equiv.to_add_monoid_hom RingEquiv.toAddMonoidHom

/-- The two paths coercion can take to an `AddMonoidHom` are equivalent -/
theorem toAddMonoidMom_commutes (f : R ≃+* S) :
    (f : R →+* S).toAddMonoidHom = (f : R ≃+ S).toAddMonoidHom :=
  rfl
#align ring_equiv.to_add_monoid_hom_commutes RingEquiv.toAddMonoidMom_commutes

/-- The two paths coercion can take to an `MonoidHom` are equivalent -/
theorem toMonoidHom_commutes (f : R ≃+* S) :
    (f : R →+* S).toMonoidHom = (f : R ≃* S).toMonoidHom :=
  rfl
#align ring_equiv.to_monoid_hom_commutes RingEquiv.toMonoidHom_commutes

/-- The two paths coercion can take to an `Equiv` are equivalent -/
theorem toEquiv_commutes (f : R ≃+* S) : (f : R ≃+ S).toEquiv = (f : R ≃* S).toEquiv :=
  rfl
#align ring_equiv.to_equiv_commutes RingEquiv.toEquiv_commutes

@[simp]
theorem toRingHom_refl : (RingEquiv.refl R).toRingHom = RingHom.id R :=
  rfl
#align ring_equiv.to_ring_hom_refl RingEquiv.toRingHom_refl

@[simp]
theorem toMonoidHom_refl : (RingEquiv.refl R).toMonoidHom = MonoidHom.id R :=
  rfl
#align ring_equiv.to_monoid_hom_refl RingEquiv.toMonoidHom_refl

@[simp]
theorem toAddMonoidHom_refl : (RingEquiv.refl R).toAddMonoidHom = AddMonoidHom.id R :=
  rfl
#align ring_equiv.to_add_monoid_hom_refl RingEquiv.toAddMonoidHom_refl

@[simp]
theorem toRingHom_apply_symm_toRingHom_apply (e : R ≃+* S) :
    ∀ y : S, e.toRingHom (e.symm.toRingHom y) = y :=
  e.toEquiv.apply_symm_apply
#align ring_equiv.to_ring_hom_apply_symm_to_ring_hom_apply RingEquiv.toRingHom_apply_symm_toRingHom_apply

@[simp]
theorem symm_toRingHom_apply_toRingHom_apply (e : R ≃+* S) :
    ∀ x : R, e.symm.toRingHom (e.toRingHom x) = x :=
  Equiv.symm_apply_apply e.toEquiv
#align ring_equiv.symm_to_ring_hom_apply_to_ring_hom_apply RingEquiv.symm_toRingHom_apply_toRingHom_apply

@[simp]
theorem toRingHom_trans (e₁ : R ≃+* S) (e₂ : S ≃+* S') :
    (e₁.trans e₂).toRingHom = e₂.toRingHom.comp e₁.toRingHom :=
  rfl
#align ring_equiv.to_ring_hom_trans RingEquiv.toRingHom_trans

@[simp]
theorem toRingHom_comp_symm_toRingHom (e : R ≃+* S) :
    e.toRingHom.comp e.symm.toRingHom = RingHom.id _ := by
  ext
  simp
#align ring_equiv.to_ring_hom_comp_symm_to_ring_hom RingEquiv.toRingHom_comp_symm_toRingHom

@[simp]
theorem symm_toRingHom_comp_toRingHom (e : R ≃+* S) :
    e.symm.toRingHom.comp e.toRingHom = RingHom.id _ := by
  ext
  simp
#align ring_equiv.symm_to_ring_hom_comp_to_ring_hom RingEquiv.symm_toRingHom_comp_toRingHom

/-- Construct an equivalence of rings from homomorphisms in both directions, which are inverses.
-/
@[simps]
def ofHomInv' {R S F G : Type _} [NonUnitalNonAssocSemiring R] [NonUnitalNonAssocSemiring S]
    [NonUnitalRingHomClass F R S] [NonUnitalRingHomClass G S R] (hom : F) (inv : G)
    (hom_inv_id : (inv : S →ₙ+* R).comp (hom : R →ₙ+* S) = NonUnitalRingHom.id R)
    (inv_hom_id : (hom : R →ₙ+* S).comp (inv : S →ₙ+* R) = NonUnitalRingHom.id S) :
    R ≃+* S where
  toFun := hom
  invFun := inv
  left_inv := FunLike.congr_fun hom_inv_id
  right_inv := FunLike.congr_fun inv_hom_id
  map_mul' := map_mul hom
  map_add' := map_add hom
#align ring_equiv.of_hom_inv' RingEquiv.ofHomInv'
#align ring_equiv.of_hom_inv'_symm_apply RingEquiv.ofHomInv'_symm_apply
#align ring_equiv.of_hom_inv'_apply RingEquiv.ofHomInv'_apply

/--
Construct an equivalence of rings from unital homomorphisms in both directions, which are inverses.
-/
@[simps]
def ofHomInv {R S F G : Type _} [NonAssocSemiring R] [NonAssocSemiring S] [RingHomClass F R S]
    [RingHomClass G S R] (hom : F) (inv : G)
    (hom_inv_id : (inv : S →+* R).comp (hom : R →+* S) = RingHom.id R)
    (inv_hom_id : (hom : R →+* S).comp (inv : S →+* R) = RingHom.id S) :
    R ≃+* S where
  toFun := hom
  invFun := inv
  left_inv := FunLike.congr_fun hom_inv_id
  right_inv := FunLike.congr_fun inv_hom_id
  map_mul' := map_mul hom
  map_add' := map_add hom
#align ring_equiv.of_hom_inv RingEquiv.ofHomInv
#align ring_equiv.of_hom_inv_apply RingEquiv.ofHomInv_apply
#align ring_equiv.of_hom_inv_symm_apply RingEquiv.ofHomInv_symm_apply

end SemiringHom

section GroupPower

variable [Semiring R] [Semiring S]

protected theorem map_pow (f : R ≃+* S) (a) : ∀ n : ℕ, f (a ^ n) = f a ^ n :=
  map_pow f a
#align ring_equiv.map_pow RingEquiv.map_pow

end GroupPower

end RingEquiv

namespace MulEquiv

/-- Gives a `RingEquiv` from an element of a `MulEquivClass` preserving addition.-/
def toRingEquiv {R S F : Type _} [Add R] [Add S] [Mul R] [Mul S] [MulEquivClass F R S] (f : F)
    (H : ∀ x y : R, f (x + y) = f x + f y) : R ≃+* S :=
  { (f : R ≃* S).toEquiv, (f : R ≃* S), AddEquiv.mk' (f : R ≃* S).toEquiv H with }
#align mul_equiv.to_ring_equiv MulEquiv.toRingEquiv

end MulEquiv

namespace AddEquiv

/-- Gives a `RingEquiv` from an element of an `AddEquivClass` preserving addition.-/
def toRingEquiv {R S F : Type _} [Add R] [Add S] [Mul R] [Mul S] [AddEquivClass F R S] (f : F)
    (H : ∀ x y : R, f (x * y) = f x * f y) : R ≃+* S :=
  { (f : R ≃+ S).toEquiv, (f : R ≃+ S), MulEquiv.mk' (f : R ≃+ S).toEquiv H with }
#align add_equiv.to_ring_equiv AddEquiv.toRingEquiv

end AddEquiv

namespace RingEquiv

variable [Add R] [Add S] [Mul R] [Mul S]

@[simp]
theorem self_trans_symm (e : R ≃+* S) : e.trans e.symm = RingEquiv.refl R :=
  ext e.left_inv
#align ring_equiv.self_trans_symm RingEquiv.self_trans_symm

@[simp]
theorem symm_trans_self (e : R ≃+* S) : e.symm.trans e = RingEquiv.refl S :=
  ext e.right_inv
#align ring_equiv.symm_trans_self RingEquiv.symm_trans_self

/-- If two rings are isomorphic, and the second doesn't have zero divisors,
then so does the first. -/
protected theorem noZeroDivisors {A : Type _} (B : Type _) [Ring A] [Ring B] [NoZeroDivisors B]
    (e : A ≃+* B) : NoZeroDivisors A :=
  { eq_zero_or_eq_zero_of_mul_eq_zero := fun {x y} hxy => by
      have : e x * e y = 0 := by rw [← e.map_mul, hxy, e.map_zero]
      simpa using eq_zero_or_eq_zero_of_mul_eq_zero this }
#align ring_equiv.no_zero_divisors RingEquiv.noZeroDivisors

/-- If two rings are isomorphic, and the second is a domain, then so is the first. -/
protected theorem isDomain {A : Type _} (B : Type _) [Ring A] [Ring B] [IsDomain B] (e : A ≃+* B) :
    IsDomain A := by
  haveI : Nontrivial A := ⟨⟨e.symm 0, e.symm 1, e.symm.injective.ne zero_ne_one⟩⟩
  haveI := e.noZeroDivisors B
  exact NoZeroDivisors.to_isDomain _
#align ring_equiv.is_domain RingEquiv.isDomain

end RingEquiv

-- guard against import creep
-- Porting note: not implemented yet
-- assert_not_exists fintype


/-
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

! This file was ported from Lean 3 source module category_theory.monad.algebra
! leanprover-community/mathlib commit 14b69e9f3c16630440a2cbd46f1ddad0d561dee7
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.CategoryTheory.Monad.Basic
import Mathbin.CategoryTheory.Adjunction.Basic
import Mathbin.CategoryTheory.Functor.EpiMono

/-!
# Eilenberg-Moore (co)algebras for a (co)monad

This file defines Eilenberg-Moore (co)algebras for a (co)monad,
and provides the category instance for them.

Further it defines the adjoint pair of free and forgetful functors, respectively
from and to the original category, as well as the adjoint pair of forgetful and
cofree functors, respectively from and to the original category.

## References
* [Riehl, *Category theory in context*, Section 5.2.4][riehl2017]
-/

namespace CategoryTheory

open Category

universe v₁ u₁

-- morphism levels before object levels. See note [category_theory universes].
variable {C : Type u₁} [Category.{v₁} C]

namespace Monad

/-- An Eilenberg-Moore algebra for a monad `T`.
    cf Definition 5.2.3 in [Riehl][riehl2017]. -/
structure Algebra (T : Monad C) : Type max u₁ v₁ where
  a : C
  a : (T : C ⥤ C).obj A ⟶ A
  unit' : T.η.app A ≫ a = 𝟙 A := by obviously
  assoc' : T.μ.app A ≫ a = (T : C ⥤ C).map a ≫ a := by obviously
#align category_theory.monad.algebra CategoryTheory.Monad.Algebra

restate_axiom algebra.unit'

restate_axiom algebra.assoc'

attribute [reassoc.1] algebra.unit algebra.assoc

namespace Algebra

variable {T : Monad C}

/-- A morphism of Eilenberg–Moore algebras for the monad `T`. -/
@[ext]
structure Hom (A B : Algebra T) where
  f : A.a ⟶ B.a
  h' : (T : C ⥤ C).map f ≫ B.a = A.a ≫ f := by obviously
#align category_theory.monad.algebra.hom CategoryTheory.Monad.Algebra.Hom

restate_axiom hom.h'

attribute [simp, reassoc.1] hom.h

namespace Hom

/-- The identity homomorphism for an Eilenberg–Moore algebra. -/
def id (A : Algebra T) : Hom A A where f := 𝟙 A.a
#align category_theory.monad.algebra.hom.id CategoryTheory.Monad.Algebra.Hom.id

instance (A : Algebra T) : Inhabited (Hom A A) :=
  ⟨{ f := 𝟙 _ }⟩

/-- Composition of Eilenberg–Moore algebra homomorphisms. -/
def comp {P Q R : Algebra T} (f : Hom P Q) (g : Hom Q R) : Hom P R where f := f.f ≫ g.f
#align category_theory.monad.algebra.hom.comp CategoryTheory.Monad.Algebra.Hom.comp

end Hom

instance : CategoryStruct (Algebra T) where
  Hom := Hom
  id := Hom.id
  comp := @Hom.comp _ _ _

@[simp]
theorem comp_eq_comp {A A' A'' : Algebra T} (f : A ⟶ A') (g : A' ⟶ A'') :
    Algebra.Hom.comp f g = f ≫ g :=
  rfl
#align category_theory.monad.algebra.comp_eq_comp CategoryTheory.Monad.Algebra.comp_eq_comp

@[simp]
theorem id_eq_id (A : Algebra T) : Algebra.Hom.id A = 𝟙 A :=
  rfl
#align category_theory.monad.algebra.id_eq_id CategoryTheory.Monad.Algebra.id_eq_id

@[simp]
theorem id_f (A : Algebra T) : (𝟙 A : A ⟶ A).f = 𝟙 A.a :=
  rfl
#align category_theory.monad.algebra.id_f CategoryTheory.Monad.Algebra.id_f

@[simp]
theorem comp_f {A A' A'' : Algebra T} (f : A ⟶ A') (g : A' ⟶ A'') : (f ≫ g).f = f.f ≫ g.f :=
  rfl
#align category_theory.monad.algebra.comp_f CategoryTheory.Monad.Algebra.comp_f

/-- The category of Eilenberg-Moore algebras for a monad.
    cf Definition 5.2.4 in [Riehl][riehl2017]. -/
instance eilenbergMoore : Category (Algebra T) where
#align category_theory.monad.algebra.EilenbergMoore CategoryTheory.Monad.Algebra.eilenbergMoore

/--
To construct an isomorphism of algebras, it suffices to give an isomorphism of the carriers which
commutes with the structure morphisms.
-/
@[simps]
def isoMk {A B : Algebra T} (h : A.a ≅ B.a) (w : (T : C ⥤ C).map h.Hom ≫ B.a = A.a ≫ h.Hom) : A ≅ B
    where
  Hom := { f := h.Hom }
  inv :=
    { f := h.inv
      h' := by
        rw [h.eq_comp_inv, category.assoc, ← w, ← functor.map_comp_assoc]
        simp }
#align category_theory.monad.algebra.iso_mk CategoryTheory.Monad.Algebra.isoMk

end Algebra

variable (T : Monad C)

/-- The forgetful functor from the Eilenberg-Moore category, forgetting the algebraic structure. -/
@[simps]
def forget : Algebra T ⥤ C where
  obj A := A.a
  map A B f := f.f
#align category_theory.monad.forget CategoryTheory.Monad.forget

/-- The free functor from the Eilenberg-Moore category, constructing an algebra for any object. -/
@[simps]
def free : C ⥤ Algebra T
    where
  obj X :=
    { a := T.obj X
      a := T.μ.app X
      assoc' := (T.and_assoc _).symm }
  map X Y f :=
    { f := T.map f
      h' := T.μ.naturality _ }
#align category_theory.monad.free CategoryTheory.Monad.free

instance [Inhabited C] : Inhabited (Algebra T) :=
  ⟨(free T).obj default⟩

-- The other two `simps` projection lemmas can be derived from these two, so `simp_nf` complains if
-- those are added too
/-- The adjunction between the free and forgetful constructions for Eilenberg-Moore algebras for
  a monad. cf Lemma 5.2.8 of [Riehl][riehl2017]. -/
@[simps Unit counit]
def adj : T.free ⊣ T.forget :=
  Adjunction.mkOfHomEquiv
    {
      homEquiv := fun X Y =>
        { toFun := fun f => T.η.app X ≫ f.f
          invFun := fun f =>
            { f := T.map f ≫ Y.a
              h' := by
                dsimp
                simp [← Y.assoc, ← T.μ.naturality_assoc] }
          left_inv := fun f => by
            ext
            dsimp
            simp
          right_inv := fun f =>
            by
            dsimp only [forget_obj, monad_to_functor_eq_coe]
            rw [← T.η.naturality_assoc, Y.unit]
            apply category.comp_id } }
#align category_theory.monad.adj CategoryTheory.Monad.adj

/-- Given an algebra morphism whose carrier part is an isomorphism, we get an algebra isomorphism.
-/
theorem algebra_iso_of_iso {A B : Algebra T} (f : A ⟶ B) [IsIso f.f] : IsIso f :=
  ⟨⟨{   f := inv f.f
        h' := by
          rw [is_iso.eq_comp_inv f.f, category.assoc, ← f.h]
          simp },
      by tidy⟩⟩
#align category_theory.monad.algebra_iso_of_iso CategoryTheory.Monad.algebra_iso_of_iso

instance forget_reflects_iso : ReflectsIsomorphisms T.forget
    where reflects A B := algebra_iso_of_iso T
#align category_theory.monad.forget_reflects_iso CategoryTheory.Monad.forget_reflects_iso

instance forget_faithful : Faithful T.forget where
#align category_theory.monad.forget_faithful CategoryTheory.Monad.forget_faithful

/-- Given an algebra morphism whose carrier part is an epimorphism, we get an algebra epimorphism.
-/
theorem algebra_epi_of_epi {X Y : Algebra T} (f : X ⟶ Y) [h : Epi f.f] : Epi f :=
  (forget T).epi_of_epi_map h
#align category_theory.monad.algebra_epi_of_epi CategoryTheory.Monad.algebra_epi_of_epi

/-- Given an algebra morphism whose carrier part is a monomorphism, we get an algebra monomorphism.
-/
theorem algebra_mono_of_mono {X Y : Algebra T} (f : X ⟶ Y) [h : Mono f.f] : Mono f :=
  (forget T).mono_of_mono_map h
#align category_theory.monad.algebra_mono_of_mono CategoryTheory.Monad.algebra_mono_of_mono

instance : IsRightAdjoint T.forget :=
  ⟨T.free, T.adj⟩

@[simp]
theorem leftAdjoint_forget : leftAdjoint T.forget = T.free :=
  rfl
#align category_theory.monad.left_adjoint_forget CategoryTheory.Monad.leftAdjoint_forget

@[simp]
theorem ofRightAdjoint_forget : Adjunction.ofRightAdjoint T.forget = T.adj :=
  rfl
#align category_theory.monad.of_right_adjoint_forget CategoryTheory.Monad.ofRightAdjoint_forget

/--
Given a monad morphism from `T₂` to `T₁`, we get a functor from the algebras of `T₁` to algebras of
`T₂`.
-/
@[simps]
def algebraFunctorOfMonadHom {T₁ T₂ : Monad C} (h : T₂ ⟶ T₁) : Algebra T₁ ⥤ Algebra T₂
    where
  obj A :=
    { a := A.a
      a := h.app A.a ≫ A.a
      unit' := by
        dsimp
        simp [A.unit]
      assoc' := by
        dsimp
        simp [A.assoc] }
  map A₁ A₂ f := { f := f.f }
#align category_theory.monad.algebra_functor_of_monad_hom CategoryTheory.Monad.algebraFunctorOfMonadHom

/--
The identity monad morphism induces the identity functor from the category of algebras to itself.
-/
@[simps (config := { rhsMd := semireducible })]
def algebraFunctorOfMonadHomId {T₁ : Monad C} : algebraFunctorOfMonadHom (𝟙 T₁) ≅ 𝟭 _ :=
  NatIso.ofComponents
    (fun X =>
      Algebra.isoMk (Iso.refl _)
        (by
          dsimp
          simp))
    fun X Y f => by
    ext
    dsimp
    simp
#align category_theory.monad.algebra_functor_of_monad_hom_id CategoryTheory.Monad.algebraFunctorOfMonadHomId

/-- A composition of monad morphisms gives the composition of corresponding functors.
-/
@[simps (config := { rhsMd := semireducible })]
def algebraFunctorOfMonadHomComp {T₁ T₂ T₃ : Monad C} (f : T₁ ⟶ T₂) (g : T₂ ⟶ T₃) :
    algebraFunctorOfMonadHom (f ≫ g) ≅ algebraFunctorOfMonadHom g ⋙ algebraFunctorOfMonadHom f :=
  NatIso.ofComponents
    (fun X =>
      Algebra.isoMk (Iso.refl _)
        (by
          dsimp
          simp))
    fun X Y f => by
    ext
    dsimp
    simp
#align category_theory.monad.algebra_functor_of_monad_hom_comp CategoryTheory.Monad.algebraFunctorOfMonadHomComp

/-- If `f` and `g` are two equal morphisms of monads, then the functors of algebras induced by them
are isomorphic.
We define it like this as opposed to using `eq_to_iso` so that the components are nicer to prove
lemmas about.
-/
@[simps (config := { rhsMd := semireducible })]
def algebraFunctorOfMonadHomEq {T₁ T₂ : Monad C} {f g : T₁ ⟶ T₂} (h : f = g) :
    algebraFunctorOfMonadHom f ≅ algebraFunctorOfMonadHom g :=
  NatIso.ofComponents
    (fun X =>
      Algebra.isoMk (Iso.refl _)
        (by
          dsimp
          simp [h]))
    fun X Y f => by
    ext
    dsimp
    simp
#align category_theory.monad.algebra_functor_of_monad_hom_eq CategoryTheory.Monad.algebraFunctorOfMonadHomEq

/-- Isomorphic monads give equivalent categories of algebras. Furthermore, they are equivalent as
categories over `C`, that is, we have `algebra_equiv_of_iso_monads h ⋙ forget = forget`.
-/
@[simps]
def algebraEquivOfIsoMonads {T₁ T₂ : Monad C} (h : T₁ ≅ T₂) : Algebra T₁ ≌ Algebra T₂
    where
  Functor := algebraFunctorOfMonadHom h.inv
  inverse := algebraFunctorOfMonadHom h.Hom
  unitIso :=
    algebraFunctorOfMonadHomId.symm ≪≫
      algebraFunctorOfMonadHomEq (by simp) ≪≫ algebraFunctorOfMonadHomComp _ _
  counitIso :=
    (algebraFunctorOfMonadHomComp _ _).symm ≪≫
      algebraFunctorOfMonadHomEq (by simp) ≪≫ algebraFunctorOfMonadHomId
#align category_theory.monad.algebra_equiv_of_iso_monads CategoryTheory.Monad.algebraEquivOfIsoMonads

@[simp]
theorem algebra_equiv_of_iso_monads_comp_forget {T₁ T₂ : Monad C} (h : T₁ ⟶ T₂) :
    algebraFunctorOfMonadHom h ⋙ forget _ = forget _ :=
  rfl
#align category_theory.monad.algebra_equiv_of_iso_monads_comp_forget CategoryTheory.Monad.algebra_equiv_of_iso_monads_comp_forget

end Monad

namespace Comonad

/-- An Eilenberg-Moore coalgebra for a comonad `T`. -/
@[nolint has_nonempty_instance]
structure Coalgebra (G : Comonad C) : Type max u₁ v₁ where
  a : C
  a : A ⟶ (G : C ⥤ C).obj A
  counit' : a ≫ G.ε.app A = 𝟙 A := by obviously
  coassoc' : a ≫ G.δ.app A = a ≫ G.map a := by obviously
#align category_theory.comonad.coalgebra CategoryTheory.Comonad.Coalgebra

restate_axiom coalgebra.counit'

restate_axiom coalgebra.coassoc'

attribute [reassoc.1] coalgebra.counit coalgebra.coassoc

namespace Coalgebra

variable {G : Comonad C}

/-- A morphism of Eilenberg-Moore coalgebras for the comonad `G`. -/
@[ext, nolint has_nonempty_instance]
structure Hom (A B : Coalgebra G) where
  f : A.a ⟶ B.a
  h' : A.a ≫ (G : C ⥤ C).map f = f ≫ B.a := by obviously
#align category_theory.comonad.coalgebra.hom CategoryTheory.Comonad.Coalgebra.Hom

restate_axiom hom.h'

attribute [simp, reassoc.1] hom.h

namespace Hom

/-- The identity homomorphism for an Eilenberg–Moore coalgebra. -/
def id (A : Coalgebra G) : Hom A A where f := 𝟙 A.a
#align category_theory.comonad.coalgebra.hom.id CategoryTheory.Comonad.Coalgebra.Hom.id

/-- Composition of Eilenberg–Moore coalgebra homomorphisms. -/
def comp {P Q R : Coalgebra G} (f : Hom P Q) (g : Hom Q R) : Hom P R where f := f.f ≫ g.f
#align category_theory.comonad.coalgebra.hom.comp CategoryTheory.Comonad.Coalgebra.Hom.comp

end Hom

/-- The category of Eilenberg-Moore coalgebras for a comonad. -/
instance : CategoryStruct (Coalgebra G) where
  Hom := Hom
  id := Hom.id
  comp := @Hom.comp _ _ _

@[simp]
theorem comp_eq_comp {A A' A'' : Coalgebra G} (f : A ⟶ A') (g : A' ⟶ A'') :
    Coalgebra.Hom.comp f g = f ≫ g :=
  rfl
#align category_theory.comonad.coalgebra.comp_eq_comp CategoryTheory.Comonad.Coalgebra.comp_eq_comp

@[simp]
theorem id_eq_id (A : Coalgebra G) : Coalgebra.Hom.id A = 𝟙 A :=
  rfl
#align category_theory.comonad.coalgebra.id_eq_id CategoryTheory.Comonad.Coalgebra.id_eq_id

@[simp]
theorem id_f (A : Coalgebra G) : (𝟙 A : A ⟶ A).f = 𝟙 A.a :=
  rfl
#align category_theory.comonad.coalgebra.id_f CategoryTheory.Comonad.Coalgebra.id_f

@[simp]
theorem comp_f {A A' A'' : Coalgebra G} (f : A ⟶ A') (g : A' ⟶ A'') : (f ≫ g).f = f.f ≫ g.f :=
  rfl
#align category_theory.comonad.coalgebra.comp_f CategoryTheory.Comonad.Coalgebra.comp_f

/-- The category of Eilenberg-Moore coalgebras for a comonad. -/
instance eilenbergMoore : Category (Coalgebra G) where
#align category_theory.comonad.coalgebra.EilenbergMoore CategoryTheory.Comonad.Coalgebra.eilenbergMoore

/--
To construct an isomorphism of coalgebras, it suffices to give an isomorphism of the carriers which
commutes with the structure morphisms.
-/
@[simps]
def isoMk {A B : Coalgebra G} (h : A.a ≅ B.a) (w : A.a ≫ (G : C ⥤ C).map h.Hom = h.Hom ≫ B.a) :
    A ≅ B where
  Hom := { f := h.Hom }
  inv :=
    { f := h.inv
      h' := by
        rw [h.eq_inv_comp, ← reassoc_of w, ← functor.map_comp]
        simp }
#align category_theory.comonad.coalgebra.iso_mk CategoryTheory.Comonad.Coalgebra.isoMk

end Coalgebra

variable (G : Comonad C)

/-- The forgetful functor from the Eilenberg-Moore category, forgetting the coalgebraic
structure. -/
@[simps]
def forget : Coalgebra G ⥤ C where
  obj A := A.a
  map A B f := f.f
#align category_theory.comonad.forget CategoryTheory.Comonad.forget

/-- The cofree functor from the Eilenberg-Moore category, constructing a coalgebra for any
object. -/
@[simps]
def cofree : C ⥤ Coalgebra G
    where
  obj X :=
    { a := G.obj X
      a := G.δ.app X
      coassoc' := (G.coassoc _).symm }
  map X Y f :=
    { f := G.map f
      h' := (G.δ.naturality _).symm }
#align category_theory.comonad.cofree CategoryTheory.Comonad.cofree

-- The other two `simps` projection lemmas can be derived from these two, so `simp_nf` complains if
-- those are added too
/-- The adjunction between the cofree and forgetful constructions for Eilenberg-Moore coalgebras
for a comonad.
-/
@[simps Unit counit]
def adj : G.forget ⊣ G.cofree :=
  Adjunction.mkOfHomEquiv
    {
      homEquiv := fun X Y =>
        { toFun := fun f =>
            { f := X.a ≫ G.map f
              h' := by
                dsimp
                simp [← coalgebra.coassoc_assoc] }
          invFun := fun g => g.f ≫ G.ε.app Y
          left_inv := fun f => by
            dsimp
            rw [category.assoc, G.ε.naturality, functor.id_map, X.counit_assoc]
          right_inv := fun g => by
            ext1; dsimp
            rw [functor.map_comp, g.h_assoc, cofree_obj_a, comonad.right_counit]
            apply comp_id } }
#align category_theory.comonad.adj CategoryTheory.Comonad.adj

/-- Given a coalgebra morphism whose carrier part is an isomorphism, we get a coalgebra isomorphism.
-/
theorem coalgebra_iso_of_iso {A B : Coalgebra G} (f : A ⟶ B) [IsIso f.f] : IsIso f :=
  ⟨⟨{   f := inv f.f
        h' := by
          rw [is_iso.eq_inv_comp f.f, ← f.h_assoc]
          simp },
      by tidy⟩⟩
#align category_theory.comonad.coalgebra_iso_of_iso CategoryTheory.Comonad.coalgebra_iso_of_iso

instance forget_reflects_iso : ReflectsIsomorphisms G.forget
    where reflects A B := coalgebra_iso_of_iso G
#align category_theory.comonad.forget_reflects_iso CategoryTheory.Comonad.forget_reflects_iso

instance forget_faithful : Faithful (forget G) where
#align category_theory.comonad.forget_faithful CategoryTheory.Comonad.forget_faithful

/-- Given a coalgebra morphism whose carrier part is an epimorphism, we get an algebra epimorphism.
-/
theorem algebra_epi_of_epi {X Y : Coalgebra G} (f : X ⟶ Y) [h : Epi f.f] : Epi f :=
  (forget G).epi_of_epi_map h
#align category_theory.comonad.algebra_epi_of_epi CategoryTheory.Comonad.algebra_epi_of_epi

/-- Given a coalgebra morphism whose carrier part is a monomorphism, we get an algebra monomorphism.
-/
theorem algebra_mono_of_mono {X Y : Coalgebra G} (f : X ⟶ Y) [h : Mono f.f] : Mono f :=
  (forget G).mono_of_mono_map h
#align category_theory.comonad.algebra_mono_of_mono CategoryTheory.Comonad.algebra_mono_of_mono

instance : IsLeftAdjoint G.forget :=
  ⟨_, G.adj⟩

@[simp]
theorem rightAdjoint_forget : rightAdjoint G.forget = G.cofree :=
  rfl
#align category_theory.comonad.right_adjoint_forget CategoryTheory.Comonad.rightAdjoint_forget

@[simp]
theorem ofLeftAdjoint_forget : Adjunction.ofLeftAdjoint G.forget = G.adj :=
  rfl
#align category_theory.comonad.of_left_adjoint_forget CategoryTheory.Comonad.ofLeftAdjoint_forget

end Comonad

end CategoryTheory


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

import Mathlib.CategoryTheory.Category.Basic
import Mathlib.CategoryTheory.Functor.Basic
import Mathlib.CategoryTheory.Functor.Category

import Moncalc.Data.DVect2.Defs
import Moncalc.Data.DVect2.Basic

/-!
# Category structure on `List`

We show that `List α` admits a canonical structure of a category provided `Category α`
-/

namespace CategoryTheory.List

universe u v

/-!
## Definition of the structure
-/
section Category

variable {α : Type u} [Category α]

/--
`Hom [a₁,a₂, ..., aₘ] [b₁,b₂, ..., bₙ]` is defined so that
  - if `m=n`, then it is isomorphic to `Hom a₁ b₁ × Hom a₂ b₂ × ⋯ × Hom aₘ bₙ`;
  - otherwise, it is the empty type.
 -/
 @[reducible]
def Hom : List α → List α → Type _ :=
  DVect2 Quiver.Hom

protected
def id : (as : List α) → Hom as as :=
  DVect2.fromList (γ:=Quiver.Hom) CategoryStruct.id

--- Due to `Mathlib4` convention, `comp f g` applies `f` "before" `g`.
protected
def comp : {as bs cs : List α} → Hom as bs → Hom bs cs → Hom as cs
| [], [], [], DVect2.nil, DVect2.nil => DVect2.nil
| (_::_), (_::_), (_::_), DVect2.cons f fs, DVect2.cons g gs => DVect2.cons (f ≫ g) (List.comp fs gs)

/-!
### Lemmas for recursion
-/
@[simp]
protected
theorem id_nil' : List.id (α:=α) [] = DVect2.nil := rfl

@[simp]
protected
theorem id_cons' : ∀ {a : α} {as : List α}, List.id (a::as) = DVect2.cons (𝟙 a) (List.id as) := rfl

@[simp]
protected
theorem comp_nil' : List.comp (α:=α) DVect2.nil DVect2.nil = DVect2.nil := rfl

@[simp]
protected
theorem comp_cons' : ∀ {a b c : α} {as bs cs : List α} {f : Quiver.Hom a b} {fs : Hom as bs} {g : Quiver.Hom b c} {gs : Hom bs cs}, List.comp (DVect2.cons f fs) (DVect2.cons g gs) = DVect2.cons (f ≫ g) (List.comp fs gs) := by
  intros; rfl

--- Right unitality of the composition in `List α`; see the comment on `comp` function for the composition order.
protected
theorem id_comp : ∀ {as bs : List α} (fs : Hom as bs), List.comp (List.id as) fs = fs
| [], [], DVect2.nil => rfl
| (_::_), (_::_), DVect2.cons f fs => by
  dsimp
  rw [Category.id_comp, List.id_comp fs]

-- The left unitality of the composition in `List α`; see the comments on `comp` function for the composition order.
protected
theorem comp_id : ∀ {as bs : List α} (fs : Hom as bs), List.comp fs (List.id bs) = fs
| [], [], DVect2.nil => rfl
| (_::_), (_::_), DVect2.cons f fs => by
  dsimp
  rw [Category.comp_id, List.comp_id fs]

-- The associativity of the composition in `List α`.
protected
theorem assoc : ∀ {as bs cs ds : List α} (fs : Hom as bs) (gs : Hom bs cs) (hs : Hom cs ds), List.comp (List.comp fs gs) hs = List.comp fs (List.comp gs hs)
| [], [], [], [], DVect2.nil, DVect2.nil, DVect2.nil => rfl
| (_::_), (_::_), (_::_), (_::_), DVect2.cons f fs, DVect2.cons g gs, DVect2.cons h hs => by
  dsimp
  rw [Category.assoc, List.assoc fs gs hs]

-- `List α` is a `Category` provided `α` is.
instance instCategoryList : CategoryTheory.Category (List α) where
  Hom := Hom
  id := List.id
  comp := List.comp
  id_comp := List.id_comp
  comp_id := List.comp_id
  assoc := List.assoc

/-!
### Lemmas for recursion that do not destruct the `CategoryTheory` notations
-/

@[simp]
theorem id_nil : 𝟙 (List.nil (α:=α)) = DVect2.nil := rfl

@[simp]
theorem id_cons : ∀ {a : α} {as : List α}, 𝟙 (a::as) = DVect2.cons (𝟙 a) (𝟙 as) := rfl

attribute [reducible] List.Hom

@[simp]
theorem comp_nil : CategoryStruct.comp (obj:=List α) (X:=[]) (Y:=[]) (Z:=[]) DVect2.nil DVect2.nil = DVect2.nil := rfl

@[simp]
theorem comp_cons : ∀ {a b c : α} {as bs cs : List α} {f : a ⟶ b} {fs : as ⟶ bs} {g : b ⟶ c} {gs : bs ⟶ cs}, CategoryStruct.comp (obj:=List α) (X:=a::as) (Y:=b::bs) (Z:=c::cs) (DVect2.cons f fs) (DVect2.cons g gs) = DVect2.cons (f ≫ g) (fs ≫ gs) := rfl

--- Functional extensionality for functors into `List α`
theorem eqF_List {β : Type v} [Category β] : (F G : Functor α (List β)) → (∀ (a : α), F.obj a = G.obj a) → (∀ (a₁ a₂ : α) (f : a₁ ⟶ a₂), DVect2.Eq (F.map f) (G.map f)) → F = G
| Functor.mk F _ _, Functor.mk G _ _ => by
  cases F with | mk F_obj F_map =>
  cases G with | mk G_obj G_map =>
  intro hobj
  have : F_obj = G_obj := funext hobj
  cases this
  dsimp
  intro hmap
  have : @F_map = @G_map := by
    apply funext; intro a; apply funext; intro b
    apply funext
    intro f
    exact (hmap a b f).eq_of
  cases this
  rfl

end Category

/-!
## Basic list operations as functors

One can obtain a functor from an operation on `List` together with its counterpart on `DVect2`.
-/

/-!
### Functorial `map`
-/

def mapF {α : Type u} [Category α] {β : Type v} [Category β] : Functor α β ⥤ Functor (List α) (List β) where
  obj := λ F => {
    obj := List.map F.obj
    map := DVect2.map F.obj F.obj F.map
    map_id := by
      intro as
      induction as
      case nil => rfl
      case cons a as h_ind =>
        dsimp [DVect2.map] at *
        rw [h_ind, F.map_id]
    map_comp :=
      let rec map_comp_aux : ∀ {as bs cs : List α} (fs : Hom as bs) (gs : Hom bs cs), List.comp (DVect2.map F.obj F.obj F.map fs) (DVect2.map F.obj F.obj F.map gs) = DVect2.map F.obj F.obj F.map (List.comp fs gs)
      | [], [], [], DVect2.nil, DVect2.nil => rfl
      | (_::_), (_::_), (_::_), DVect2.cons f fs, DVect2.cons g gs => by
        dsimp [DVect2.map, List.comp]
        rw [F.map_comp, map_comp_aux fs gs]
      by
        intro fs gs
        simp [CategoryStruct.comp]
        rw [map_comp_aux]
  }
  map := @λ F G φ => {
    app := DVect2.dfromList F.obj G.obj φ.app
    naturality := by
      intros as bs fs
      dsimp [CategoryStruct.comp]
      induction fs <;> dsimp [DVect2.map, List.comp]
      /- case nil has been completed -/
      case cons f fs h_ind =>
        rw [φ.naturality]
        apply congrArg
        exact h_ind
  }
  map_id := λ F => by
    ext as; dsimp
    induction as
    case nil => rfl
    case cons a as h_ind =>
      dsimp [DVect2.dfromList]
      rw [h_ind]
  map_comp := by
    intro F G H φ ψ
    ext as; dsimp
    induction as
    case nil => rfl
    case cons a as h_ind =>
      dsimp [DVect2.dfromList]
      rw [h_ind]

namespace mapF

@[simp]
theorem obj_obj_cons {α : Type u} [Category α] {β : Type v} [Category β] {F : Functor α β} : ∀ {a : α} {as : List α}, (mapF.obj F).obj (a::as) = F.obj a :: (mapF.obj F).obj as := rfl

@[simp]
theorem obj_map_cons {α : Type u} [Category α] {β : Type v} [Category β] {F : Functor α β} : ∀ {a b : α} {as bs : List α} {f : a ⟶ b} {fs : as ⟶ bs}, (mapF.obj F).map (DVect2.cons f fs) = DVect2.cons (F.map f) ((mapF.obj F).map fs) := rfl

@[simp]
theorem map_cons {α : Type u} [Category α] {β : Type v} [Category β] {F G : Functor α β} {φ : F ⟶ G} : ∀ {a : α} {as : List α}, (mapF.map φ).app (a::as) = DVect2.cons (φ.app a) ((mapF.map φ).app as) := rfl

--- `mapF : Functor α α ⟶ Functor (List α) (List α)` preserves the identity functor
@[simp]
protected
theorem obj_id {α : Type u} [Category α] : mapF.obj (𝟭 α) = 𝟭 (List α) := by
  apply eqF_List <;> dsimp [Functor.id]
  . intro as
    change List.map id as = as
    rw [List.map_id]
  . intro as₁ as₂ fs
    change DVect2.Eq (DVect2.map id id id fs) fs
    exact DVect2.map_id

--- `mapF : Functor α β ⟶ Functor (List α) (List β)` respects functor composition
@[simp]
protected
theorem obj_comp {α : Type u} [Category α] {β : Type v} [Category β] {γ : Type w} [Category γ] (F : Functor α β) (G : Functor β γ) : mapF.obj (F ⋙ G) = mapF.obj F ⋙ mapF.obj G := by
  dsimp [Functor.comp, mapF]
  apply eqF_List <;> dsimp
  . intro as
    rw [←List.map_comp G.obj F.obj]
    rfl
  . intro as₁ as₂ fs
    exact DVect2.map_comp

end mapF

/-!
### Functorial `append`
-/
namespace appendF

/--
  `DVect2.append` enables `Hom as₁ bs₁ → Hom as₂ bs₂ → Hom (as₁++as₂) (bs₁++bs₂)` for `as₁ as₂ bs₁ bs₂ : List α`.
-/
instance instHAppendHom (α : Type u) [Category α] {as₁ as₂ bs₁ bs₂ : List α} : HAppend (as₁ ⟶ bs₁) (as₂ ⟶ bs₂) ((as₁++as₂) ⟶ (bs₁++bs₂)) :=
  inferInstanceAs $ HAppend (DVect2 (Quiver.Hom (V:=α)) as₁ bs₁) (DVect2 (Quiver.Hom (V:=α)) as₂ bs₂) _

variable {α : Type u} [Category α]

@[simp]
protected
lemma map_cons {a b : α} {as₁ as₂ bs₁ bs₂ : List α} (f : a ⟶ b) (fs₁ : as₁ ⟶ bs₁) (fs₂ : as₂ ⟶ bs₂) : HAppend.hAppend (α:=(a::as₁) ⟶ (b::bs₁)) (DVect2.cons f fs₁) fs₂ = DVect2.cons f (fs₁ ++ fs₂) := rfl

@[simp]
protected
theorem map_id {as bs : List α} : 𝟙 as ++ 𝟙 bs = 𝟙 (as++bs) := by
  induction as
  case nil => rfl
  case cons a as h_ind =>
    dsimp
    rw [DVect2.cons_append, h_ind]

@[simp]
protected
theorem map_comp : ∀ {as₁ as₂ bs₁ bs₂ cs₁ cs₂ : List α} (fs₁ : Hom as₁ bs₁) (fs₂ : Hom as₂ bs₂) (gs₁ : Hom bs₁ cs₁) (gs₂ : Hom bs₂ cs₂), (fs₁ ++ fs₂) ≫ (gs₁ ++ gs₂) = HAppend.hAppend (self:=instHAppendHom α) (fs₁ ≫ gs₁) (fs₂ ≫ gs₂)
| [], _, [], _, [], _, DVect2.nil, _, DVect2.nil, _ => rfl
| (_::_), _, (_::_), _, (_::_), _, DVect2.cons f fs₁, fs₂, DVect2.cons g gs₁, gs₂ => by
  rw [DVect2.cons_append, DVect2.cons_append]
  dsimp
  rw [appendF.map_comp fs₁ _ gs₁ _, DVect2.cons_append]

end appendF

/-!
## Functorial join
-/

--- The functor `List (List α) ⥤ List α` consisting of `List.join` on objects and `DVect2.join` on morhisms.
def joinF {α : Type u} [Category α] : Functor (List (List α)) (List α) where
  obj := List.join
  map := DVect2.join
  map_id := by
    intro ass
    simp [CategoryStruct.id]
    induction ass
    case nil => rfl
    case cons as ass h_ind =>
      dsimp [List.id, List.join, DVect2.join] at *
      rw [DVect2.fromList_append, h_ind]
      rfl
  map_comp :=
    let rec map_comp_aux {α : Type u} [Category α] : ∀ {ass bss css : List (List α)} (fss : ass ⟶ bss) (gss : bss ⟶ css), Eq (α:=ass.join ⟶ css.join) (DVect2.join (fss ≫ gss)) (fss.join ≫ gss.join)
    | [], [], [], DVect2.nil, DVect2.nil => rfl
    | (_::_), (_::_), (_::_), DVect2.cons _ fss, DVect2.cons _ gss => by
      dsimp [DVect2.join]
      rw [map_comp_aux fss gss, appendF.map_comp]
    map_comp_aux

namespace joinF

@[simp]
protected
theorem obj_cons {α : Type u} [Category α] : ∀ {as : List α} {ass : List (List α)}, (joinF (α:=α)).obj (as::ass) = as ++ (joinF (α:=α)).obj ass := rfl

@[simp]
protected
theorem map_cons {α : Type u} [Category α] : ∀ {as bs : List α} {ass bss : List (List α)} {fs : as ⟶ bs} {fss : ass ⟶ bss}, (joinF (α:=α)).map (DVect2.cons fs fss) = HAppend.hAppend (α:=DVect2 (Quiver.Hom (V:=α)) as bs) (β:=DVect2 (Quiver.Hom (V:=α)) ass.join bss.join) fs ((joinF (α:=α)).map fss) := rfl

end joinF

end CategoryTheory.List


/-
Copyright (c) 2021 Yury Kudryashov. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Yury Kudryashov
-/
import topology.algebra.monoid
import group_theory.group_action.prod
import group_theory.group_action.basic
import topology.homeomorph

/-!
# Continuous monoid action

In this file we define class `has_continuous_smul`. We say `has_continuous_smul M α` if `M` acts on
`α` and the map `(c, x) ↦ c • x` is continuous on `M × α`. We reuse this class for topological
(semi)modules, vector spaces and algebras.

## Main definitions

* `has_continuous_smul M α` : typeclass saying that the map `(c, x) ↦ c • x` is continuous
  on `M × α`;
* `homeomorph.smul_of_ne_zero`: if a group with zero `G₀` (e.g., a field) acts on `α` and `c : G₀`
  is a nonzero element of `G₀`, then scalar multiplication by `c` is a homeomorphism of `α`;
* `homeomorph.smul`: scalar multiplication by an element of a group `G` acting on `α`
  is a homeomorphism of `α`.
* `units.has_continuous_smul`: scalar multiplication by `units M` is continuous when scalar
  multiplication by `M` is continuous. This allows `homeomorph.smul` to be used with on monoids
  with `G = units M`.

## Main results

Besides homeomorphisms mentioned above, in this file we provide lemmas like `continuous.smul`
or `filter.tendsto.smul` that provide dot-syntax access to `continuous_smul`.
-/

open_locale topological_space pointwise
open filter

/-- Class `has_continuous_smul M α` says that the scalar multiplication `(•) : M → α → α`
is continuous in both arguments. We use the same class for all kinds of multiplicative actions,
including (semi)modules and algebras. -/
class has_continuous_smul (M α : Type*) [has_scalar M α]
  [topological_space M] [topological_space α] : Prop :=
(continuous_smul : continuous (λp : M × α, p.1 • p.2))

export has_continuous_smul (continuous_smul)

/-- Class `has_continuous_vadd M α` says that the additive action `(+ᵥ) : M → α → α`
is continuous in both arguments. We use the same class for all kinds of additive actions,
including (semi)modules and algebras. -/
class has_continuous_vadd (M α : Type*) [has_vadd M α]
  [topological_space M] [topological_space α] : Prop :=
(continuous_vadd : continuous (λp : M × α, p.1 +ᵥ p.2))

export has_continuous_vadd (continuous_vadd)

attribute [to_additive] has_continuous_smul

variables {M α β : Type*} [topological_space M] [topological_space α]

section has_scalar

variables [has_scalar M α] [has_continuous_smul M α]

@[to_additive]
lemma filter.tendsto.smul {f : β → M} {g : β → α} {l : filter β} {c : M} {a : α}
  (hf : tendsto f l (𝓝 c)) (hg : tendsto g l (𝓝 a)) :
  tendsto (λ x, f x • g x) l (𝓝 $ c • a) :=
(continuous_smul.tendsto _).comp (hf.prod_mk_nhds hg)

@[to_additive]
lemma filter.tendsto.const_smul {f : β → α} {l : filter β} {a : α} (hf : tendsto f l (𝓝 a))
  (c : M) :
  tendsto (λ x, c • f x) l (𝓝 (c • a)) :=
tendsto_const_nhds.smul hf

@[to_additive]
lemma filter.tendsto.smul_const {f : β → M} {l : filter β} {c : M}
  (hf : tendsto f l (𝓝 c)) (a : α) :
  tendsto (λ x, (f x) • a) l (𝓝 (c • a)) :=
hf.smul tendsto_const_nhds

variables [topological_space β] {f : β → M} {g : β → α} {b : β} {s : set β}

@[to_additive]
lemma continuous_within_at.smul (hf : continuous_within_at f s b)
  (hg : continuous_within_at g s b) :
  continuous_within_at (λ x, f x • g x) s b :=
hf.smul hg

@[to_additive]
lemma continuous_within_at.const_smul (hg : continuous_within_at g s b) (c : M) :
  continuous_within_at (λ x, c • g x) s b :=
hg.const_smul c

@[to_additive]
lemma continuous_at.smul (hf : continuous_at f b) (hg : continuous_at g b) :
  continuous_at (λ x, f x • g x) b :=
hf.smul hg

@[to_additive]
lemma continuous_at.const_smul (hg : continuous_at g b) (c : M) :
  continuous_at (λ x, c • g x) b :=
hg.const_smul c

@[to_additive]
lemma continuous_on.smul (hf : continuous_on f s) (hg : continuous_on g s) :
  continuous_on (λ x, f x • g x) s :=
λ x hx, (hf x hx).smul (hg x hx)

@[to_additive]
lemma continuous_on.const_smul (hg : continuous_on g s) (c : M) :
  continuous_on (λ x, c • g x) s :=
λ x hx, (hg x hx).const_smul c

@[continuity, to_additive]
lemma continuous.smul (hf : continuous f) (hg : continuous g) :
  continuous (λ x, f x • g x) :=
continuous_smul.comp (hf.prod_mk hg)

@[to_additive]
lemma continuous.const_smul (hg : continuous g) (c : M) :
  continuous (λ x, c • g x) :=
continuous_smul.comp (continuous_const.prod_mk hg)

end has_scalar

section monoid

variables [monoid M] [mul_action M α] [has_continuous_smul M α]

instance units.has_continuous_smul : has_continuous_smul (units M) α :=
{ continuous_smul :=
    show continuous ((λ p : M × α, p.fst • p.snd) ∘ (λ p : units M × α, (p.1, p.2))),
    from continuous_smul.comp ((units.continuous_coe.comp continuous_fst).prod_mk continuous_snd) }

@[to_additive]
lemma smul_closure_subset (c : M) (s : set α) : c • closure s ⊆ closure (c • s) :=
((set.maps_to_image _ _).closure $ continuous_id.const_smul c).image_subset

@[to_additive]
lemma smul_closure_orbit_subset (c : M) (x : α) :
  c • closure (mul_action.orbit M x) ⊆ closure (mul_action.orbit M x) :=
(smul_closure_subset c _).trans $ closure_mono $ mul_action.smul_orbit_subset _ _

end monoid

section group

variables {G : Type*} [topological_space G] [group G] [mul_action G α]
  [has_continuous_smul G α]

@[to_additive]
lemma tendsto_const_smul_iff {f : β → α} {l : filter β} {a : α} (c : G) :
  tendsto (λ x, c • f x) l (𝓝 $ c • a) ↔ tendsto f l (𝓝 a) :=
⟨λ h, by simpa only [inv_smul_smul] using h.const_smul c⁻¹,
  λ h, h.const_smul _⟩

variables [topological_space β] {f : β → α} {b : β}  {s : set β}

@[to_additive]
lemma continuous_within_at_const_smul_iff (c : G) :
  continuous_within_at (λ x, c • f x) s b ↔ continuous_within_at f s b :=
tendsto_const_smul_iff c

@[to_additive]
lemma continuous_on_const_smul_iff (c : G) :
  continuous_on (λ x, c • f x) s ↔ continuous_on f s :=
forall_congr $ λ b, forall_congr $ λ hb, continuous_within_at_const_smul_iff c

@[to_additive]
lemma continuous_at_const_smul_iff (c : G) :
  continuous_at (λ x, c • f x) b ↔ continuous_at f b :=
tendsto_const_smul_iff c

@[to_additive]
lemma continuous_const_smul_iff (c : G) :
  continuous (λ x, c • f x) ↔ continuous f :=
by simp only [continuous_iff_continuous_at, continuous_at_const_smul_iff]

/-- Scalar multiplication by an element of a group `G` acting on `α` is a homeomorphism from `α`
to itself. -/
protected def homeomorph.smul (c : G) : α ≃ₜ α :=
{ to_equiv := mul_action.to_perm_hom G α c,
  continuous_to_fun  := continuous_id.const_smul _,
  continuous_inv_fun := continuous_id.const_smul _ }

/-- Affine-addition of an element of an additive group `G` acting on `α` is a homeomorphism
from `α` to itself. -/
protected def homeomorph.vadd {G : Type*} [topological_space G] [add_group G] [add_action G α]
  [has_continuous_vadd G α] (c : G) : α ≃ₜ α :=
{ to_equiv := add_action.to_perm_hom α G c,
  continuous_to_fun  := continuous_id.const_vadd _,
  continuous_inv_fun := continuous_id.const_vadd _ }

attribute [to_additive] homeomorph.smul

@[to_additive]
lemma is_open_map_smul (c : G) : is_open_map (λ x : α, c • x) :=
(homeomorph.smul c).is_open_map

@[to_additive] lemma is_open.smul {s : set α} (hs : is_open s) (c : G) : is_open (c • s) :=
is_open_map_smul c s hs

@[to_additive]
lemma is_closed_map_smul (c : G) : is_closed_map (λ x : α, c • x) :=
(homeomorph.smul c).is_closed_map

@[to_additive] lemma is_closed.smul {s : set α} (hs : is_closed s) (c : G) : is_closed (c • s) :=
is_closed_map_smul c s hs

end group

section group_with_zero

variables {G₀ : Type*} [topological_space G₀] [group_with_zero G₀] [mul_action G₀ α]
  [has_continuous_smul G₀ α]

lemma tendsto_const_smul_iff₀ {f : β → α} {l : filter β} {a : α} {c : G₀} (hc : c ≠ 0) :
  tendsto (λ x, c • f x) l (𝓝 $ c • a) ↔ tendsto f l (𝓝 a) :=
tendsto_const_smul_iff (units.mk0 c hc)

variables [topological_space β] {f : β → α} {b : β} {c : G₀} {s : set β}

lemma continuous_within_at_const_smul_iff₀ (hc : c ≠ 0) :
  continuous_within_at (λ x, c • f x) s b ↔ continuous_within_at f s b :=
tendsto_const_smul_iff (units.mk0 c hc)

lemma continuous_on_const_smul_iff₀ (hc : c ≠ 0) :
  continuous_on (λ x, c • f x) s ↔ continuous_on f s :=
continuous_on_const_smul_iff (units.mk0 c hc)

lemma continuous_at_const_smul_iff₀ (hc : c ≠ 0) :
  continuous_at (λ x, c • f x) b ↔ continuous_at f b :=
continuous_at_const_smul_iff (units.mk0 c hc)

lemma continuous_const_smul_iff₀ (hc : c ≠ 0) :
  continuous (λ x, c • f x) ↔ continuous f :=
continuous_const_smul_iff (units.mk0 c hc)

/-- Scalar multiplication by a non-zero element of a group with zero acting on `α` is a
homeomorphism from `α` onto itself. -/
protected def homeomorph.smul_of_ne_zero (c : G₀) (hc : c ≠ 0) : α ≃ₜ α :=
homeomorph.smul (units.mk0 c hc)

lemma is_open_map_smul₀ {c : G₀} (hc : c ≠ 0) : is_open_map (λ x : α, c • x) :=
(homeomorph.smul_of_ne_zero c hc).is_open_map

/-- `smul` is a closed map in the second argument.

The lemma that `smul` is a closed map in the first argument (for a normed space over a complete
normed field) is `is_closed_map_smul_left` in `analysis.normed_space.finite_dimension`. -/
lemma is_closed_map_smul_of_ne_zero {c : G₀} (hc : c ≠ 0) : is_closed_map (λ x : α, c • x) :=
(homeomorph.smul_of_ne_zero c hc).is_closed_map

/-- `smul` is a closed map in the second argument.

The lemma that `smul` is a closed map in the first argument (for a normed space over a complete
normed field) is `is_closed_map_smul_left` in `analysis.normed_space.finite_dimension`. -/
lemma is_closed_map_smul₀ {𝕜 M : Type*} [division_ring 𝕜] [add_comm_monoid M] [topological_space M]
  [t1_space M] [module 𝕜 M] [topological_space 𝕜] [has_continuous_smul 𝕜 M] (c : 𝕜) :
  is_closed_map (λ x : M, c • x) :=
begin
  rcases eq_or_ne c 0 with (rfl|hne),
  { simp only [zero_smul], exact is_closed_map_const },
  { exact (homeomorph.smul_of_ne_zero c hne).is_closed_map },
end

end group_with_zero

namespace is_unit

variables [monoid M] [mul_action M α] [has_continuous_smul M α]

lemma tendsto_const_smul_iff {f : β → α} {l : filter β} {a : α} {c : M} (hc : is_unit c) :
  tendsto (λ x, c • f x) l (𝓝 $ c • a) ↔ tendsto f l (𝓝 a) :=
let ⟨u, hu⟩ := hc in hu ▸ tendsto_const_smul_iff u

variables [topological_space β] {f : β → α} {b : β} {c : M} {s : set β}

lemma continuous_within_at_const_smul_iff (hc : is_unit c) :
  continuous_within_at (λ x, c • f x) s b ↔ continuous_within_at f s b :=
let ⟨u, hu⟩ := hc in hu ▸ continuous_within_at_const_smul_iff u

lemma continuous_on_const_smul_iff (hc : is_unit c) :
  continuous_on (λ x, c • f x) s ↔ continuous_on f s :=
let ⟨u, hu⟩ := hc in hu ▸ continuous_on_const_smul_iff u

lemma continuous_at_const_smul_iff (hc : is_unit c) :
  continuous_at (λ x, c • f x) b ↔ continuous_at f b :=
let ⟨u, hu⟩ := hc in hu ▸ continuous_at_const_smul_iff u

lemma continuous_const_smul_iff (hc : is_unit c) :
  continuous (λ x, c • f x) ↔ continuous f :=
let ⟨u, hu⟩ := hc in hu ▸ continuous_const_smul_iff u

lemma is_open_map_smul (hc : is_unit c) : is_open_map (λ x : α, c • x) :=
let ⟨u, hu⟩ := hc in hu ▸ is_open_map_smul u

lemma is_closed_map_smul (hc : is_unit c) : is_closed_map (λ x : α, c • x) :=
let ⟨u, hu⟩ := hc in hu ▸ is_closed_map_smul u

end is_unit

@[to_additive]
instance has_continuous_mul.has_continuous_smul {M : Type*} [monoid M]
  [topological_space M] [has_continuous_mul M] :
  has_continuous_smul M M :=
⟨continuous_mul⟩

@[to_additive]
instance [topological_space β] [has_scalar M α] [has_scalar M β] [has_continuous_smul M α]
  [has_continuous_smul M β] :
  has_continuous_smul M (α × β) :=
⟨(continuous_fst.smul (continuous_fst.comp continuous_snd)).prod_mk
  (continuous_fst.smul (continuous_snd.comp continuous_snd))⟩

@[to_additive]
instance {ι : Type*} {γ : ι → Type}
  [∀ i, topological_space (γ i)] [Π i, has_scalar M (γ i)] [∀ i, has_continuous_smul M (γ i)] :
  has_continuous_smul M (Π i, γ i) :=
⟨continuous_pi $ λ i,
  (continuous_fst.smul continuous_snd).comp $
    continuous_fst.prod_mk ((continuous_apply i).comp continuous_snd)⟩


/-
Copyright (c) 2020 Bhavik Mehta. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Bhavik Mehta
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.topology.opens
import Mathlib.category_theory.sites.grothendieck
import Mathlib.category_theory.sites.pretopology
import Mathlib.category_theory.limits.lattice
import Mathlib.PostPort

universes u

namespace Mathlib

/-!
# Grothendieck topology on a topological space

Define the Grothendieck topology and the pretopology associated to a topological space, and show
that the pretopology induces the topology.

The covering (pre)sieves on `X` are those for which the union of domains contains `X`.

## Tags

site, Grothendieck topology, space

## References

* [https://ncatlab.org/nlab/show/Grothendieck+topology][nlab]
* [S. MacLane, I. Moerdijk, *Sheaves in Geometry and Logic*][MM92]

## Implementation notes

We define the two separately, rather than defining the Grothendieck topology as that generated
by the pretopology for the purpose of having nice definitional properties for the sieves.
-/

namespace opens

/-- The Grothendieck topology associated to a topological space. -/
def grothendieck_topology (T : Type u) [topological_space T] :
    category_theory.grothendieck_topology (topological_space.opens T) :=
  category_theory.grothendieck_topology.mk
    (fun (X : topological_space.opens T) (S : category_theory.sieve X) =>
      ∀ (x : T), x ∈ X → ∃ (U : topological_space.opens T), ∃ (f : U ⟶ X), coe_fn S U f ∧ x ∈ U)
    sorry sorry sorry

/-- The Grothendieck pretopology associated to a topological space. -/
def pretopology (T : Type u) [topological_space T] :
    category_theory.pretopology (topological_space.opens T) :=
  category_theory.pretopology.mk
    (fun (X : topological_space.opens T) (R : category_theory.presieve X) =>
      ∀ (x : T), x ∈ X → ∃ (U : topological_space.opens T), ∃ (f : U ⟶ X), R f ∧ x ∈ U)
    sorry sorry sorry

/--
The pretopology associated to a space induces the Grothendieck topology associated to the space.
-/
@[simp] theorem pretopology_to_grothendieck (T : Type u) [topological_space T] :
    category_theory.pretopology.to_grothendieck (topological_space.opens T) (pretopology T) =
        grothendieck_topology T :=
  sorry

end Mathlib


import Lean4Axiomatic.Rational.Impl.Fraction.Negation
import Lean4Axiomatic.Rational.Sign

namespace Lean4Axiomatic.Rational.Impl.Fraction

open Logic (AP)
open Signed (Negative Positive sgn)

variable {ℕ : Type} [Natural ℕ]
variable {ℤ : Type} [Integer (ℕ := ℕ) ℤ]

/-! ## Fraction signedness -/

/--
Implementation of signum for integer fractions.

The `Fraction` data structure was designed specifically to make this definition
simple. The denominator is positive, so the numerator is what determines the
sign of the fraction. This emphasizes that fractions are an integer (the
numerator) that has been scaled down in size by a factor (the denominator).
-/
def _sgn (p : Fraction ℤ) : ℤ := sgn p.numerator

/--
Implementation of a predicate for positive integer fractions.

The easiest definition is to delegate to the signum function.
-/
def _Positive (p : Fraction ℤ) : Prop := _sgn p ≃ 1

/--
Implementation of a predicate for negative integer fractions.

The easiest definition is to delegate to the signum function.
-/
def _Negative (p : Fraction ℤ) : Prop := _sgn p ≃ -1

instance sign_ops : Sign.Ops (ℤ := ℤ) (Fraction ℤ) := {
  _sgn := _sgn
  _Positive := _Positive
  _Negative := _Negative
}

/--
The signum function respects integer fraction equivalence.

**Property intuition**: This is necessary for `sgn` to be a function on integer
fractions.

**Proof intuition**: Expand the fraction definitions and `sgn` on fractions to
obtain integer expressions. Then use integer `sgn` properties and algebra.
-/
theorem sgn_subst {p₁ p₂ : Fraction ℤ} : p₁ ≃ p₂ → sgn p₁ ≃ sgn p₂ := by
  revert p₁; intro (a//b); revert p₂; intro (c//d)
  intro (_ : a//b ≃ c//d)
  show sgn (a//b) ≃ sgn (c//d)
  have : a * d ≃ c * b := ‹a//b ≃ c//d›
  have : Positive b := ‹AP (Positive b)›.ev
  have : sgn b ≃ 1 := Integer.sgn_positive.mp this
  have : Positive d := ‹AP (Positive d)›.ev
  have : 1 ≃ sgn d := Rel.symm (Integer.sgn_positive.mp this)
  calc
    sgn (a//b)    ≃ _ := Rel.refl
    sgn a         ≃ _ := Rel.symm AA.identR
    sgn a * 1     ≃ _ := AA.substR ‹1 ≃ sgn d›
    sgn a * sgn d ≃ _ := Rel.symm Integer.sgn_compat_mul
    sgn (a * d)   ≃ _ := Integer.sgn_subst ‹a * d ≃ c * b›
    sgn (c * b)   ≃ _ := Integer.sgn_compat_mul
    sgn c * sgn b ≃ _ := AA.substR ‹sgn b ≃ 1›
    sgn c * 1     ≃ _ := AA.identR
    sgn c         ≃ _ := Rel.refl
    sgn (c//d)    ≃ _ := Rel.refl

/--
Fractions that are equivalent to zero are the only ones with sign zero.

**Property and proof intuition**: The sign of a fraction is the sign of its
numerator; this property also holds for integers; fractions with zero-valued
numerators are equivalent to zero.
-/
theorem sgn_zero_only_for_zero {p : Fraction ℤ} : sgn p ≃ 0 → p ≃ 0 := by
  intro (_ : sgn p ≃ 0)
  show p ≃ 0
  have : sgn p.numerator ≃ 0 := ‹sgn p ≃ 0›
  have : p.numerator ≃ 0 := Integer.sgn_zero.mpr this
  have : p ≃ 0 := eqv_zero_iff_numerator_eqv_zero.mpr this
  exact this

/--
The fraction equivalent of an integer has the same sign.

**Property intuition**: This must be true for the fraction to be a faithful
representation of the integer.

**Proof intuition**: True by definition of `sgn` for integer fractions.
-/
theorem sgn_from_integer {a : ℤ} : sgn (a : Fraction ℤ) ≃ sgn a := calc
  sgn (a : Fraction ℤ) ≃ _ := Rel.refl
  sgn (a//1)           ≃ _ := Rel.refl
  sgn a                ≃ _ := Rel.refl

/--
The `sgn` function is compatible with multiplication.

**Property intuition**: This holds for integers, so it should also hold for
fractions (which are just rescaled integers).

**Proof intuition**: Expand definitions to obtain the integer version of this
property.
-/
theorem sgn_compat_mul {p q : Fraction ℤ} : sgn (p * q) ≃ sgn p * sgn q := by
  revert p; intro (a//b); revert q; intro (c//d)
  show sgn (a//b * c//d) ≃ sgn (a//b) * sgn (c//d)
  calc
    sgn (a//b * c//d)       ≃ _ := sgn_subst eqv_refl
    sgn ((a * c)//(b * d))  ≃ _ := Rel.refl
    sgn (a * c)             ≃ _ := Integer.sgn_compat_mul
    sgn a * sgn c           ≃ _ := Rel.refl
    sgn (a//b) * sgn (c//d) ≃ _ := Rel.refl

/--
The sign of a fraction is `0`, `1`, or `-1`.

**Property intuition**: This is a fundamental fact about signs.

**Proof intuition**: Find the numerator's sign using the integer equivalent of
this property. The sign of the numerator is the sign of the entire fraction.
-/
theorem sgn_trichotomy
    (p : Fraction ℤ) : AA.OneOfThree (sgn p ≃ 0) (sgn p ≃ 1) (sgn p ≃ -1)
    := by
  have
    : AA.OneOfThree
      (p.numerator ≃ 0)
      (Positive p.numerator)
      (Negative p.numerator)
    := (Integer.sign_trichotomy p.numerator).atLeastOne
  match this with
  | AA.OneOfThree.first (_ : p.numerator ≃ 0) =>
    have : sgn p ≃ 0 := calc
      sgn p           ≃ _ := Rel.refl
      sgn p.numerator ≃ _ := Integer.sgn_zero.mp ‹p.numerator ≃ 0›
      0               ≃ _ := Rel.refl
    exact AA.OneOfThree.first this
  | AA.OneOfThree.second (_ : Positive p.numerator) =>
    have : sgn p ≃ 1 := calc
      sgn p           ≃ _ := Rel.refl
      sgn p.numerator ≃ _ := Integer.sgn_positive.mp ‹Positive p.numerator›
      1               ≃ _ := Rel.refl
    exact AA.OneOfThree.second this
  | AA.OneOfThree.third (_ : Negative p.numerator) =>
    have : sgn p ≃ -1 := calc
      sgn p           ≃ _ := Rel.refl
      sgn p.numerator ≃ _ := Integer.sgn_negative.mp ‹Negative p.numerator›
      (-1)            ≃ _ := Rel.refl
    exact AA.OneOfThree.third this

/--
Integer fractions are positive iff their sign is `1`.

**Property and proof intuition**: True by definition.
-/
theorem sgn_positive {p : Fraction ℤ} : Positive p ↔ sgn p ≃ 1 :=
  Iff.intro id id

/--
Integer fractions are negative iff their sign is `-1`.

**Property and proof intuition**: True by definition.
-/
theorem sgn_negative {p : Fraction ℤ} : Negative p ↔ sgn p ≃ -1 :=
  Iff.intro id id

instance sign_props : Sign.Props (Fraction ℤ) := {
  sgn_subst := sgn_subst
  sgn_zero_only_for_zero := sgn_zero_only_for_zero
  sgn_from_integer := sgn_from_integer
  sgn_compat_mul := sgn_compat_mul
  sgn_trichotomy := sgn_trichotomy
  sgn_positive := sgn_positive
  sgn_negative := sgn_negative
}

instance sign : Sign (Fraction ℤ) := {
  toOps := sign_ops
  toProps := sign_props
}

end Lean4Axiomatic.Rational.Impl.Fraction


import game.basic
import list.modify.basic
import tactic.fin_cases

open list

namespace game

/--Two games that are equal except one entry in one sublist of components differs by at most d-/
structure modify {n : ℕ} (G1 G2 : game n) (d : ℤ) :=
(j : fin n)  -- kind of the component they differ in (there are n kinds of componenents)
(hj : ∀ i : fin n, i ≠ j → G1.f i = G2.f i) /- if we are NOT looking at the kind of component they differ in,
                                               the lists of such components in both games is the same-/
(hl : list.modify (G1.f j) (G2.f j) d) /- if we are looking at the kind of component they differ in,
                                               the lists of such components in both games differ
                                               in one component by at most d-/

/--For two games that are equal except one pair of components of the same type differs
by at most d, both games have the same number of components of each type-/
lemma eq_list_lengths_of_modify {n : ℕ} {G1 G2 : game n} {d : ℤ} (h : modify G1 G2 d):
∀ (i : fin n), length (G1.f i) = length (G2.f i) :=
begin
intro i,
/- either the games differ in a component of kind i or they do differ somewhere else-/
by_cases p1 : i ≠ h.j,
  /- if they do not differ in a component of kind i, then by h.hj the
     lists are the same, hence their lengths as well-/
  {rw h.hj i p1},
  /- if they do differ in a component of kind i, then by h.hl the
     lists are modified lists, hence their lengths are the same
     by a lemma in list.modify.basic-/
  {push_neg at p1,
  rw p1,
  exact eq_size_of_modify_list h.hl},
end

end game

open game

/--if G1 is a version of G2 modified in one component by at most d,
then G2 is a version of G1 modified in one component by at most d-/
def modify.symm {G1 G2 : game 2} {d : ℤ}
(m : modify G1 G2 d) : modify G2 G1 d :=
{ j := m.j,-- they still differ in the same components
  hj := begin intros i h, rw eq_comm, exact m.hj i h, end, --follows from symmetry of equality in m.hj
  hl := begin apply list.modify.symm, exact m.hl, end, -- follows from symmetry of list.modify
}

/--games modified in one comonent have the same size-/
theorem eq_size_of_modify {G1 G2 : game 2} {d : ℤ} (h : game.modify G1 G2 d) : G1.size2 = G2.size2 :=
begin
  cases h with j hj hl, --split h into its fields
  unfold size2, -- size Gn = length (Gn.f 0) + length (Gn.f 1) for n = 1, 2
  fin_cases j, -- split into cases corresponding to possible values of j in fin 2

  /- in both cases we prove the number of chains are the same (h0)
     and the number of looops are the same (h1)
     (or the lists are the same, which implies the above)
     then clearly the sizes of the games are the same-/

  -- j = ⟨0,_⟩
  { have h0 := eq_size_of_modify_list hl, -- length (G1.f ⟨0, _⟩) = length (G2.f ⟨0, _⟩)
    change length (G1.f 0) = length (G2.f 0) at h0,
    have h1 : G1.f 1 = G2.f 1,
      exact hj ⟨1, dec_trivial⟩ dec_trivial, -- as we do not modify a loop, by hj
    rw [h0, h1],
  },
  -- j = ⟨1,_⟩
  { have h0 : G1.f 0 = G2.f 0,
      exact hj ⟨0, dec_trivial⟩ dec_trivial, -- as we do not modify a chain, by hj
    have h1 := eq_size_of_modify_list hl, -- length (G1.f ⟨1, _⟩) = length (G2.f ⟨1, _⟩)
    change length (G1.f 1) = length (G2.f 1) at h1,
    rw [h0, h1],
  }
end

/--If you remove some component that is not the modified one from
both modified games, you get a modified game-/
def game.remove_of_modify {G1 G2 : game 2} {d : ℤ }
(p : modify G1 G2 d) (j : fin 2) (i1 : fin (G1.f j).length)
(i2 : fin (G2.f j).length) (hi : i1.val = i2.val)(h : j ≠ p.j ∨ (j = p.j ∧ i1.val ≠ p.hl.n)):
modify (G1.remove j i1) (G2.remove j i2) d :=
begin
  split, -- split goal into its fields

    -- FIELD j
    swap 3, {exact p.j}, -- they still differ in the same kind of component

    -- FIELD hj
    {intros x x_neq, -- say we are looking at a kind x of component, that is not p.j
    unfold game.remove,
    show dite (x = j) (λ (h : x = j), remove_nth (G1.f j) (i1.val)) (λ (h : ¬x = j), G1.f x) =
        dite (x = j) (λ (h : x = j), remove_nth (G2.f j) (i2.val)) (λ (h : ¬x = j), G2.f x),
    split_ifs with ite, -- either x = j or ¬ (x = j)

      /- in both cases by h.hj, G1.f x and G2.f x are the same because of x_neq-/

      -- if-case (named ite) : x = j
      {rw hi, -- i1.val and i2.val are the same
      rw ite at x_neq,
      rw p.hj j x_neq},
      -- else-case (named ite) : ¬ (x = j)
      { exact p.hj x x_neq,},
        },

    -- FIELD hl
    {
      unfold game.remove,
      -- in the following, list.modify is meant
      show modify (dite (p.j = j) (λ (h : p.j = j), remove_nth (G1.f j) (i1.val)) (λ (h : ¬p.j = j), G1.f (p.j)))
          (dite (p.j = j) (λ (h : p.j = j), remove_nth (G2.f j) (i2.val)) (λ (h : ¬p.j = j), G2.f (p.j))) d,
      split_ifs with ite, -- either p.j = j or ¬ (p.j = j)
        -- if-case (named ite) : p.j = j
        {rw ← hi,
        rw eq_comm at ite,
        simp only [ite],
        have pj2 : j = p.j ∧ i1.val ≠ p.hl.n, --this is true because of h and ite
          {finish},
        /- hence i1.val ≠ p.hl.n, which together with p.hl is all we need
           to be able to use list.modify_remove_nth (see list.modify.basic)-/
        exact list.modify_remove_nth p.hl i1.val pj2.right,},
        -- else-case (named ite) : ¬ (p.j = j)
        {exact p.hl}, -- this is exactly what p.hl says
    },

end

/--game.remove_of_modify with roles of G1 and G2 switched-/
def game.remove_of_modify_symm{G1 G2 : game 2} {d : ℤ }
(p : modify G1 G2 d) (j : fin 2) (i1 : fin (G1.f j).length)
(i2 : fin (G2.f j).length) (hi : i1.val = i2.val)(h : j ≠ p.j ∨ (j = p.j ∧ i1.val ≠ p.hl.n)):
modify (G2.remove j i2) (G1.remove j i1) d :=
by exact modify.symm (game.remove_of_modify p j i1 i2 hi h)


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

/-!
# Basis on a quaternion-like algebra

## Main definitions

* `quaternion_algebra.basis A c₁ c₂`: a basis for a subspace of an `R`-algebra `A` that has the
  same algebra structure as `ℍ[R,c₁,c₂]`.
* `quaternion_algebra.basis.self R`: the canonical basis for `ℍ[R,c₁,c₂]`.
* `quaternion_algebra.basis.comp_hom b f`: transform a basis `b` by an alg_hom `f`.
* `quaternion_algebra.lift`: Define an `alg_hom` out of `ℍ[R,c₁,c₂]` by its action on the basis
  elements `i`, `j`, and `k`. In essence, this is a universal property. Analogous to `complex.lift`,
  but takes a bundled `quaternion_algebra.basis` instead of just a `subtype` as the amount of
  data / proves is non-negligeable.
-/

open_locale quaternion
namespace quaternion_algebra

/-- A quaternion basis contains the information both sufficient and necessary to construct an
`R`-algebra homomorphism from `ℍ[R,c₁,c₂]` to `A`; or equivalently, a surjective
`R`-algebra homomorphism from `ℍ[R,c₁,c₂]` to an `R`-subalgebra of `A`.

Note that for definitional convenience, `k` is provided as a field even though `i_mul_j` fully
determines it. -/
structure basis {R : Type*} (A : Type*) [comm_ring R] [ring A] [algebra R A] (c₁ c₂ : R) :=
(i j k : A)
(i_mul_i : i * i = c₁ • 1)
(j_mul_j : j * j = c₂ • 1)
(i_mul_j : i * j = k)
(j_mul_i : j * i = -k)

variables {R : Type*} {A B : Type*} [comm_ring R] [ring A] [ring B] [algebra R A] [algebra R B]
variables {c₁ c₂ : R}

namespace basis

/-- Since `k` is redundant, it is not necessary to show `q₁.k = q₂.k` when showing `q₁ = q₂`. -/
@[ext]
protected lemma ext ⦃q₁ q₂ : basis A c₁ c₂⦄ (hi : q₁.i = q₂.i) (hj : q₁.j = q₂.j) :
  q₁ = q₂ :=
begin
  cases q₁,
  cases q₂,
  congr',
  rw [←q₁_i_mul_j, ←q₂_i_mul_j],
  congr'
end

variables (R)

/-- There is a natural quaternionic basis for the `quaternion_algebra`. -/
@[simps i j k]
protected def self : basis ℍ[R,c₁,c₂] c₁ c₂ :=
{ i := ⟨0, 1, 0, 0⟩,
  i_mul_i := by { ext; simp },
  j := ⟨0, 0, 1, 0⟩,
  j_mul_j := by { ext; simp },
  k := ⟨0, 0, 0, 1⟩,
  i_mul_j := by { ext; simp },
  j_mul_i := by { ext; simp } }

variables {R}

instance : inhabited (basis ℍ[R,c₁,c₂] c₁ c₂) := ⟨basis.self R⟩

variables (q : basis A c₁ c₂)
include q

attribute [simp] i_mul_i j_mul_j i_mul_j j_mul_i

@[simp] lemma i_mul_k : q.i * q.k = c₁ • q.j :=
by rw [←i_mul_j, ←mul_assoc, i_mul_i, smul_mul_assoc, one_mul]

@[simp] lemma k_mul_i : q.k * q.i = -c₁ • q.j :=
by rw [←i_mul_j, mul_assoc, j_mul_i, mul_neg, i_mul_k, neg_smul]

@[simp] lemma k_mul_j : q.k * q.j = c₂ • q.i :=
by rw [←i_mul_j, mul_assoc, j_mul_j, mul_smul_comm, mul_one]

@[simp] lemma j_mul_k : q.j * q.k = -c₂ • q.i :=
by rw [←i_mul_j, ←mul_assoc, j_mul_i, neg_mul, k_mul_j, neg_smul]

@[simp] lemma k_mul_k : q.k * q.k = -((c₁ * c₂) • 1) :=
by rw [←i_mul_j, mul_assoc, ←mul_assoc q.j _ _, j_mul_i, ←i_mul_j,
  ←mul_assoc, mul_neg, ←mul_assoc, i_mul_i, smul_mul_assoc, one_mul,
  neg_mul, smul_mul_assoc, j_mul_j, smul_smul]

/-- Intermediate result used to define `quaternion_algebra.basis.lift_hom`. -/
def lift (x : ℍ[R,c₁,c₂]) : A :=
algebra_map R _ x.re + x.im_i • q.i + x.im_j • q.j + x.im_k • q.k

lemma lift_zero : q.lift (0 : ℍ[R,c₁,c₂]) = 0 := by simp [lift]
lemma lift_one : q.lift (1 : ℍ[R,c₁,c₂]) = 1 := by simp [lift]
lemma lift_add (x y : ℍ[R,c₁,c₂]) : q.lift (x + y) = q.lift x + q.lift y :=
by { simp [lift, add_smul], abel }
lemma lift_mul (x y : ℍ[R,c₁,c₂]) : q.lift (x * y) = q.lift x * q.lift y :=
begin
  simp only [lift, algebra.algebra_map_eq_smul_one],
  simp only [add_mul],
  simp only [add_mul, mul_add, smul_mul_assoc, mul_smul_comm, one_mul, mul_one,
    ←algebra.smul_def, smul_add, smul_smul],
  simp only [i_mul_i, j_mul_j, i_mul_j, j_mul_i, i_mul_k, k_mul_i, k_mul_j, j_mul_k, k_mul_k],
  simp only [smul_smul, smul_neg, sub_eq_add_neg, add_smul, ←add_assoc, mul_neg,
    neg_smul],
  simp only [mul_right_comm _ _ (c₁ * c₂), mul_comm _ (c₁ * c₂)],
  simp only [mul_comm _ c₁, mul_right_comm _ _ c₁],
  simp only [mul_comm _ c₂, mul_right_comm _ _ c₂],
  simp only [←mul_comm c₁ c₂, ←mul_assoc],
  simp [sub_eq_add_neg, add_smul, ←add_assoc],
  abel
end

lemma lift_smul (r : R) (x : ℍ[R,c₁,c₂]) : q.lift (r • x) = r • q.lift x :=
by simp [lift, mul_smul, ←algebra.smul_def]

/-- A `quaternion_algebra.basis` implies an `alg_hom` from the quaternions. -/
@[simps]
def lift_hom : ℍ[R,c₁,c₂] →ₐ[R] A :=
alg_hom.mk'
  { to_fun := q.lift,
    map_zero' := q.lift_zero,
    map_one' := q.lift_one,
    map_add' := q.lift_add,
    map_mul' := q.lift_mul }
  q.lift_smul

/-- Transform a `quaternion_algebra.basis` through an `alg_hom`. -/
@[simps i j k]
def comp_hom (F : A →ₐ[R] B) : basis B c₁ c₂ :=
{ i := F q.i,
  i_mul_i := by rw [←F.map_mul, q.i_mul_i, F.map_smul, F.map_one],
  j := F q.j,
  j_mul_j := by rw [←F.map_mul, q.j_mul_j, F.map_smul, F.map_one],
  k := F q.k,
  i_mul_j := by rw [←F.map_mul, q.i_mul_j],
  j_mul_i := by rw [←F.map_mul, q.j_mul_i, F.map_neg], }

end basis

/-- A quaternionic basis on `A` is equivalent to a map from the quaternion algebra to `A`. -/
@[simps]
def lift : basis A c₁ c₂ ≃ (ℍ[R,c₁,c₂] →ₐ[R] A) :=
{ to_fun := basis.lift_hom,
  inv_fun := (basis.self R).comp_hom,
  left_inv := λ q, begin
    ext;
    simp [basis.lift],
  end,
  right_inv := λ F, begin
    ext,
    dsimp [basis.lift],
    rw ←F.commutes,
    simp only [←F.commutes, ←F.map_smul, ←F.map_add, mk_add_mk, smul_mk, smul_zero, algebra_map_eq],
    congr,
    simp,
  end }

end quaternion_algebra


import Mathlib.Algebra.BigOperators.Basic
import Mathlib.Algebra.BigOperators.Order
import Mathlib.Data.Real.Basic
import Mathlib.Tactic.LibrarySearch
import Mathlib.Tactic.Linarith
import Mathlib.Tactic.Ring
import Mathlib.Tactic.FieldSimp
import Mathlib.Tactic.Positivity

/-
Canadian Mathematical Olympiad 1998, Problem 3

Let n be a natural number such that n ≥ 2. Show that

  (1/(n + 1))(1 + 1/3 + ... + 1/(2n - 1)) > (1/n)(1/2 + 1/4 + ... + 1/2n).
-/

namespace Canada1998Q3

open BigOperators

theorem canada1998_q3 (n : ℕ) (hn : 2 ≤ n) :
    (1/((n:ℝ) + 1)) * ∑ i in Finset.range n, (1/(2 * (i:ℝ) + 1)) >
    (1/(n:ℝ)) * ∑ i in Finset.range n, (1/(2 * (i:ℝ) + 2)) := by
  cases' n with n; norm_num at hn
  cases' n with n; norm_num at hn

  revert hn
  intro h2; clear h2

  -- We prove
  -- n(1 + 1/3 + ... + 1/(2n - 1)) > (n + 1)(1/2 + 1/4 + ... + 1/2n)
  -- by induction.
  suffices
   (n.succ.succ:ℝ) * ∑ i in Finset.range n.succ.succ, (1/(2 * (i:ℝ) + 1)) >
    ((n.succ.succ:ℝ) + 1) * ∑ i in Finset.range n.succ.succ, (1/(2 * (i:ℝ) + 2))
      by rw[div_mul_eq_mul_div₀, one_mul, div_mul_eq_mul_div₀, one_mul]
         apply (div_lt_div_iff (by positivity) (by positivity)).mpr
         linarith

  induction n with
  | zero =>
     -- Base case: when n = 2, we have 8/3 > 9/4.
     field_simp[Finset.sum_range_succ]
     norm_num
  | succ m ih =>
    let k := m.succ.succ

    -- Inductive case: suppose claim is true for k ≥ 2. Then we have
    -- k (1 + 1/3 + ... 1/(2k - 1)) > (k + 1)(1/2 + 1/4 + ... + 1/2k).
    -- Note that
    --  (1 + 1/3 + ... + 1/(2k-1)) + (k+1)/(2k+1)
    --    = (1/2 + 1/3 + ... + 1/(2k-1)) + 1/2 + (k+1)/(2k+1)
    --    > (1/2 + 1/4 + ... + 1/2k) + 1/2 + (k+1)/(2k+1)
    --    > (1/2 + 1/4 + ... + 1/2k) + (k + 1)/(2k + 2) + 1/(2k+1)
    --    > (1/2 + 1/4 + ... + 1/2k) + (k + 2)/(2k + 2).

    have h1 : (1:ℝ) / (2 * ↑(0:ℕ) + 1) = 1 := by norm_num

    have h2 : ∀ k' ∈ Finset.range (m + 1), (1:ℝ) / (2 * ↑(k' + 1) + 1) >
                          (1:ℝ) / (2 * ↑(k' + 1) + 1 + 1) := by
      intros k' _
      apply div_lt_div_of_lt_left zero_lt_one
      · positivity
      · exact lt_add_one _

    have h3 : (∑i in Finset.range k, 1 / (2 * (i:ℝ) + 1)) + (k+1)/(2 * k + 1)
            = _ := rfl

    nth_rewrite 1 [Finset.sum_range_succ'] at h3
    rw[h1, add_assoc] at h3

    have h4 : Finset.Nonempty (Finset.range (m + 1)) :=
      Finset.nonempty_range_succ
    have h5 := Finset.sum_lt_sum_of_nonempty h4 h2
    norm_cast at h5

    have h6 : (∑i in Finset.range k, 1 / (2 * (i:ℝ) + 1 + 1)) = _ := rfl
    nth_rewrite 1 [Finset.sum_range_succ'] at h6

    have h7' : (2:ℝ) * (k:ℝ) ≥ 4 := by
      have hh2' : k ≥ 2 := Nat.succ_le_succ (Nat.succ_le_succ (Nat.zero_le m))
      have hh2 : (k:ℝ) ≥ 2 := by exact_mod_cast hh2'
      calc
        (2:ℝ) * (k:ℝ) ≥ (2:ℝ) * 2 := mul_le_mul_of_nonneg_left hh2 (by linarith)
        _ = 4 := by norm_num

    have h7 : 1 / 2 > 1 / (2 * (k:ℝ) + 2) := by apply div_lt_div' <;> linarith
    have h8 : ((k:ℝ)+1)/(2 * (k:ℝ) + 1) > ((k:ℝ)+1)/(2 * (k:ℝ) + 2) :=
      by apply div_lt_div' <;> linarith

    have h9 :=
           --  (1 + 1/3 + ... + 1/(2k-1)) + (k+1)/(2k+1)
      calc (∑i in Finset.range k, 1 / (2 * (i:ℝ) + 1)) + (k+1)/(2 * k + 1)

      --    = (1/3 + ... + 1/(2k-1)) + (1 + (k+1)/(2k+1))
         = (∑i in Finset.range (m+1), 1 / (2 * ((i + 1):ℝ) + 1))
               + (1 + (k+1)/(2 * k + 1)) := by rw[←h3]; norm_cast
                                        -- TODO shouldn't need casting?

       --    > (1/4 + ... + 1/2k) + (1 + (k+1)/(2k+1))
       _ > (∑i in Finset.range (m+1), 1 / (2 * ((i + 1):ℝ) + 1 + 1))
              + (1 + (k+1)/(2 * k + 1)) := by norm_cast; linarith

       _ = (∑i in Finset.range (m+1), 1 / (2 * ((i + 1):ℝ) + 1 + 1))
              + (1/2 + 1/2 + (k+1)/(2 * k + 1)) := by field_simp
       _ = (∑i in Finset.range (m+1), 1 / (2 * ((i + 1):ℝ) + 1 + 1))
              + 1/2 + (1/2 + (k+1)/(2 * k + 1)) := by ring
       _ = (∑i in Finset.range (m+1), 1 / (2 * ((i + 1):ℝ) + 1 + 1))
              + 1/(2 *(((0:ℕ)):ℝ) + 1 + 1) + (1/2 + (k+1)/(2 * k + 1)) :=
                      by norm_num
       _ = (∑i in Finset.range k, 1 / (2 * (i:ℝ) + 1 + 1)) +
              (1/2 + (k+1)/(2 * k + 1)) := by rw[←h6]; norm_cast

       --    > (1/2 + 1/4 + ... + 1/2k) + (k + 1)/(2k + 2) + 1/(2k+1)
       _ > (∑i in Finset.range k, 1 / (2 * (i:ℝ) + 1 + 1)) +
              ((k+1)/(2 * k + 2) + 1/(2 * k + 2)) := by linarith

       --    = (1/2 + 1/4 + ... + 1/2k) + (k + 2)/(2k + 2).
       _ = (∑i in Finset.range k, 1 / (2 * (i:ℝ) + 1 + 1)) +
              (k+2)/(2 * k + 2) := by field_simp; ring

   --
   -- Then we are done because
   -- (k + 1)(1 + 1/3 + ... + 1/(2k - 1) + 1/(2k + 1))
   --  = k (1 + 1/3 + ... + 1/(2k - 1))
   --     + (1 + 1/3 + ... + 1/(2k - 1)) + (k + 1)/(2k + 1)
   --  > k (1 + 1/3 + ... + 1/(2k - 1))
   --     + (1/2 + 1/4 + ... + 1/2k)) + (k + 2)/(2k + 2)
   --    (by h9, proved above)

   --  > (k + 2)(1/2 + 1/4 + ... + 1/(2k + 2)).

    have :=
      calc (k + 1) * (∑i in Finset.range k.succ, 1 / (2 * (i:ℝ) + 1))
         = k * (∑i in Finset.range k, 1 / (2 * (i:ℝ) + 1)) +
             ((∑i in Finset.range k, 1 / (2 * (i:ℝ) + 1)) +
                (k + 1) / (2 * k + 1)) := by
                   rw[Finset.sum_range_succ]; ring
       _ > k * (∑i in Finset.range k, 1 / (2 * (i:ℝ) + 1)) +
             ((∑i in Finset.range k, 1 / (2 * (i:ℝ) + 1 + 1)) +
                (k + 2) / (2 * k + 2)) := add_lt_add_left h9 _
       _ > (k + 1) * (∑i in Finset.range k, 1 / (2 * (i:ℝ) + 2)) +
             ((∑i in Finset.range k, 1 / (2 * (i:ℝ) + 1 + 1)) +
                (k + 2) / (2 * k + 2)) := add_lt_add_right ih _
       _ = (k + 1) * (∑i in Finset.range k, 1 / (2 * (i:ℝ) + 2)) +
             ((∑i in Finset.range k, 1 / (2 * (i:ℝ) + 2)) +
                (k + 2) / (2 * k + 2)) := by
             congr; funext x; rw [add_assoc, show (1:ℝ) + 1 = 2 by norm_num]
       _ = (k + 2) * ((∑i in Finset.range k, 1 / (2 * (i:ℝ) + 2)) +
                1 / (2 * k + 2)) := by ring
       _ = (k + 2) * (∑i in Finset.range k.succ, 1 / (2 * (i:ℝ) + 2))
                 := by rw[←Finset.sum_range_succ]
    norm_cast at this
    norm_cast