/-
Copyright (c) 2021 Frédéric Dupuis. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Frédéric Dupuis
-/

import algebra.star.basic
import group_theory.subgroup.basic

/-!
# Self-adjoint, skew-adjoint and normal elements of a star additive group

This file defines `self_adjoint R` (resp. `skew_adjoint R`), where `R` is a star additive group,
as the additive subgroup containing the elements that satisfy `star x = x` (resp. `star x = -x`).
This includes, for instance, (skew-)Hermitian operators on Hilbert spaces.

We also define `is_star_normal R`, a `Prop` that states that an element `x` satisfies
`star x * x = x * star x`.

## Implementation notes

* When `R` is a `star_module R₂ R`, then `self_adjoint R` has a natural
  `module (self_adjoint R₂) (self_adjoint R)` structure. However, doing this literally would be
  undesirable since in the main case of interest (`R₂ = ℂ`) we want `module ℝ (self_adjoint R)`
  and not `module (self_adjoint ℂ) (self_adjoint R)`. We solve this issue by adding the typeclass
  `[has_trivial_star R₃]`, of which `ℝ` is an instance (registered in `data/real/basic`), and then
  add a `[module R₃ (self_adjoint R)]` instance whenever we have
  `[module R₃ R] [has_trivial_star R₃]`. (Another approach would have been to define
  `[star_invariant_scalars R₃ R]` to express the fact that `star (x • v) = x • star v`, but
  this typeclass would have the disadvantage of taking two type arguments.)

## TODO

* Define `λ z x, z * x * star z` (i.e. conjugation by `z`) as a monoid action of `R` on `R`
  (similar to the existing `conj_act` for groups), and then state the fact that `self_adjoint R` is
  invariant under it.

-/

variables (R : Type*) {A : Type*}

/-- The self-adjoint elements of a star additive group, as an additive subgroup. -/
def self_adjoint [add_group R] [star_add_monoid R] : add_subgroup R :=
{ carrier := {x | star x = x},
  zero_mem' := star_zero R,
  add_mem' := λ x y (hx : star x = x) (hy : star y = y),
                show star (x + y) = x + y, by simp only [star_add x y, hx, hy],
  neg_mem' := λ x (hx : star x = x), show star (-x) = -x, by simp only [hx, star_neg] }

/-- The skew-adjoint elements of a star additive group, as an additive subgroup. -/
def skew_adjoint [add_comm_group R] [star_add_monoid R] : add_subgroup R :=
{ carrier := {x | star x = -x},
  zero_mem' := show star (0 : R) = -0, by simp only [star_zero, neg_zero],
  add_mem' := λ x y (hx : star x = -x) (hy : star y = -y),
                show star (x + y) = -(x + y), by rw [star_add x y, hx, hy, neg_add],
  neg_mem' := λ x (hx : star x = -x), show star (-x) = (- -x), by simp only [hx, star_neg] }

variables {R}

/-- An element of a star monoid is normal if it commutes with its adjoint. -/
class is_star_normal [has_mul R] [has_star R] (x : R) : Prop :=
(star_comm_self : commute (star x) x)

export is_star_normal (star_comm_self)

lemma star_comm_self' [has_mul R] [has_star R] (x : R) [is_star_normal x] :
  (star x) * x = x * star x :=
is_star_normal.star_comm_self

namespace self_adjoint

section add_group
variables [add_group R] [star_add_monoid R]

lemma mem_iff {x : R} : x ∈ self_adjoint R ↔ star x = x :=
by { rw [←add_subgroup.mem_carrier], exact iff.rfl }

@[simp, norm_cast] lemma star_coe_eq {x : self_adjoint R} : star (x : R) = x := x.prop

instance : inhabited (self_adjoint R) := ⟨0⟩

lemma bit0_mem {x : R} (hx : x ∈ self_adjoint R) : bit0 x ∈ self_adjoint R :=
by simp only [mem_iff, star_bit0, mem_iff.mp hx]

end add_group

section ring
variables [ring R] [star_ring R]

instance : has_one (self_adjoint R) := ⟨⟨1, by rw [mem_iff, star_one]⟩⟩

@[simp, norm_cast] lemma coe_one : ↑(1 : self_adjoint R) = (1 : R) := rfl

instance [nontrivial R] : nontrivial (self_adjoint R) := ⟨⟨0, 1, subtype.ne_of_val_ne zero_ne_one⟩⟩

lemma one_mem : (1 : R) ∈ self_adjoint R := by simp only [mem_iff, star_one]

lemma bit1_mem {x : R} (hx : x ∈ self_adjoint R) : bit1 x ∈ self_adjoint R :=
by simp only [mem_iff, star_bit1, mem_iff.mp hx]

lemma conjugate {x : R} (hx : x ∈ self_adjoint R) (z : R) : z * x * star z ∈ self_adjoint R :=
by simp only [mem_iff, star_mul, star_star, mem_iff.mp hx, mul_assoc]

lemma conjugate' {x : R} (hx : x ∈ self_adjoint R) (z : R) : star z * x * z ∈ self_adjoint R :=
by simp only [mem_iff, star_mul, star_star, mem_iff.mp hx, mul_assoc]

lemma is_star_normal_of_mem {x : R} (hx : x ∈ self_adjoint R) : is_star_normal x :=
⟨by { simp only [mem_iff] at hx, simp only [hx] }⟩

instance (x : self_adjoint R) : is_star_normal (x : R) :=
is_star_normal_of_mem (set_like.coe_mem _)

instance : has_pow (self_adjoint R) ℕ :=
⟨λ x n, ⟨(x : R) ^ n, by simp only [mem_iff, star_pow, star_coe_eq]⟩⟩

@[simp, norm_cast] lemma coe_pow (x : self_adjoint R) (n : ℕ) : ↑(x ^ n) = (x : R) ^ n := rfl

end ring

section comm_ring
variables [comm_ring R] [star_ring R]

instance : has_mul (self_adjoint R) :=
⟨λ x y, ⟨(x : R) * y, by simp only [mem_iff, star_mul', star_coe_eq]⟩⟩

@[simp, norm_cast] lemma coe_mul (x y : self_adjoint R) : ↑(x * y) = (x : R) * y := rfl

instance : comm_ring (self_adjoint R) :=
function.injective.comm_ring _ subtype.coe_injective
  (self_adjoint R).coe_zero coe_one (self_adjoint R).coe_add coe_mul (self_adjoint R).coe_neg
  (self_adjoint R).coe_sub (self_adjoint R).coe_nsmul (self_adjoint R).coe_zsmul coe_pow

end comm_ring

section field

variables [field R] [star_ring R]

instance : has_inv (self_adjoint R) :=
{ inv := λ x, ⟨(x.val)⁻¹, by simp only [mem_iff, star_inv', star_coe_eq, subtype.val_eq_coe]⟩ }

@[simp, norm_cast] lemma coe_inv (x : self_adjoint R) : ↑(x⁻¹) = (x : R)⁻¹ := rfl

instance : has_div (self_adjoint R) :=
{ div := λ x y, ⟨x / y, by simp only [mem_iff, star_div', star_coe_eq, subtype.val_eq_coe]⟩ }

@[simp, norm_cast] lemma coe_div (x y : self_adjoint R) : ↑(x / y) = (x / y : R) := rfl

instance : has_pow (self_adjoint R) ℤ :=
{ pow := λ x z, ⟨x ^ z, by simp only [mem_iff, star_zpow₀, star_coe_eq, subtype.val_eq_coe]⟩ }

@[simp, norm_cast] lemma coe_zpow (x : self_adjoint R) (z : ℤ) : ↑(x ^ z) = (x : R) ^ z := rfl

instance : field (self_adjoint R) :=
function.injective.field _ subtype.coe_injective
  (self_adjoint R).coe_zero coe_one (self_adjoint R).coe_add coe_mul (self_adjoint R).coe_neg
  (self_adjoint R).coe_sub coe_inv coe_div (self_adjoint R).coe_nsmul (self_adjoint R).coe_zsmul
  coe_pow coe_zpow

end field

section has_scalar
variables [has_star R] [has_trivial_star R] [add_group A] [star_add_monoid A]

lemma smul_mem [has_scalar R A] [star_module R A] (r : R) {x : A}
  (h : x ∈ self_adjoint A) : r • x ∈ self_adjoint A :=
by rw [mem_iff, star_smul, star_trivial, mem_iff.mp h]

instance [has_scalar R A] [star_module R A] : has_scalar R (self_adjoint A) :=
⟨λ r x, ⟨r • x, smul_mem r x.prop⟩⟩

@[simp, norm_cast] lemma coe_smul [has_scalar R A] [star_module R A] (r : R) (x : self_adjoint A) :
  ↑(r • x) = r • (x : A) := rfl

instance [monoid R] [mul_action R A] [star_module R A] : mul_action R (self_adjoint A) :=
function.injective.mul_action coe subtype.coe_injective coe_smul

instance [monoid R] [distrib_mul_action R A] [star_module R A] :
  distrib_mul_action R (self_adjoint A) :=
function.injective.distrib_mul_action (self_adjoint A).subtype subtype.coe_injective coe_smul

end has_scalar

section module
variables [has_star R] [has_trivial_star R] [add_comm_group A] [star_add_monoid A]

instance [semiring R] [module R A] [star_module R A] : module R (self_adjoint A) :=
function.injective.module R (self_adjoint A).subtype subtype.coe_injective coe_smul

end module

end self_adjoint

namespace skew_adjoint

section add_group
variables [add_comm_group R] [star_add_monoid R]

lemma mem_iff {x : R} : x ∈ skew_adjoint R ↔ star x = -x :=
by { rw [←add_subgroup.mem_carrier], exact iff.rfl }

@[simp, norm_cast] lemma star_coe_eq {x : skew_adjoint R} : star (x : R) = -x := x.prop

instance : inhabited (skew_adjoint R) := ⟨0⟩

lemma bit0_mem {x : R} (hx : x ∈ skew_adjoint R) : bit0 x ∈ skew_adjoint R :=
by rw [mem_iff, star_bit0, mem_iff.mp hx, bit0, bit0, neg_add]

end add_group

section ring
variables [ring R] [star_ring R]

lemma conjugate {x : R} (hx : x ∈ skew_adjoint R) (z : R) : z * x * star z ∈ skew_adjoint R :=
by simp only [mem_iff, star_mul, star_star, mem_iff.mp hx, neg_mul, mul_neg, mul_assoc]

lemma conjugate' {x : R} (hx : x ∈ skew_adjoint R) (z : R) : star z * x * z ∈ skew_adjoint R :=
by simp only [mem_iff, star_mul, star_star, mem_iff.mp hx, neg_mul, mul_neg, mul_assoc]

lemma is_star_normal_of_mem {x : R} (hx : x ∈ skew_adjoint R) : is_star_normal x :=
⟨by { simp only [mem_iff] at hx, simp only [hx, commute.neg_left] }⟩

instance (x : skew_adjoint R) : is_star_normal (x : R) :=
is_star_normal_of_mem (set_like.coe_mem _)

end ring

section has_scalar
variables [has_star R] [has_trivial_star R] [add_comm_group A] [star_add_monoid A]

lemma smul_mem [monoid R] [distrib_mul_action R A] [star_module R A] (r : R) {x : A}
  (h : x ∈ skew_adjoint A) : r • x ∈ skew_adjoint A :=
by rw [mem_iff, star_smul, star_trivial, mem_iff.mp h, smul_neg r]

instance [monoid R] [distrib_mul_action R A] [star_module R A] : has_scalar R (skew_adjoint A) :=
⟨λ r x, ⟨r • x, smul_mem r x.prop⟩⟩

@[simp, norm_cast] lemma coe_smul [monoid R] [distrib_mul_action R A] [star_module R A]
  (r : R) (x : skew_adjoint A) : ↑(r • x) = r • (x : A) := rfl

instance [monoid R] [distrib_mul_action R A] [star_module R A] :
  distrib_mul_action R (skew_adjoint A) :=
function.injective.distrib_mul_action (skew_adjoint A).subtype subtype.coe_injective coe_smul

instance [semiring R] [module R A] [star_module R A] : module R (skew_adjoint A) :=
function.injective.module R (skew_adjoint A).subtype subtype.coe_injective coe_smul

end has_scalar

end skew_adjoint

instance is_star_normal_zero [semiring R] [star_ring R] : is_star_normal (0 : R) :=
⟨by simp only [star_comm_self, star_zero]⟩

instance is_star_normal_one [monoid R] [star_semigroup R] : is_star_normal (1 : R) :=
⟨by simp only [star_comm_self, star_one]⟩

instance is_star_normal_star_self [monoid R] [star_semigroup R] {x : R} [is_star_normal x] :
  is_star_normal (star x) :=
⟨show star (star x) * (star x) = (star x) * star (star x), by rw [star_star, star_comm_self']⟩

@[priority 100] -- see Note [lower instance priority]
instance has_trivial_star.is_star_normal [monoid R] [star_semigroup R]
  [has_trivial_star R] {x : R} : is_star_normal x :=
⟨by rw [star_trivial]⟩

@[priority 100] -- see Note [lower instance priority]
instance comm_monoid.is_star_normal [comm_monoid R] [star_semigroup R] {x : R} :
  is_star_normal x :=
⟨mul_comm _ _⟩


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

/-!
# Spectral maps

This file defines spectral maps. A map is spectral when it's continuous and the preimage of a
compact open set is compact open.

## Main declarations

* `is_spectral_map`: Predicate for a map to be spectral.
* `spectral_map`: Bundled spectral maps.
* `spectral_map_class`: Typeclass for a type to be a type of spectral maps.

## TODO

Once we have `spectral_space`, `is_spectral_map` should move to `topology.spectral.basic`.
-/

open function order_dual

variables {F α β γ δ : Type*}

section unbundled
variables [topological_space α] [topological_space β] [topological_space γ] {f : α → β} {s : set β}

/-- A function between topological spaces is spectral if it is continuous and the preimage of every
compact open set is compact open. -/
structure is_spectral_map (f : α → β) extends continuous f : Prop :=
(compact_preimage_of_open ⦃s : set β⦄ : is_open s → is_compact s → is_compact (f ⁻¹' s))

lemma is_compact.preimage_of_open (hf : is_spectral_map f) (h₀ : is_compact s) (h₁ : is_open s) :
  is_compact (f ⁻¹' s) :=
hf.compact_preimage_of_open h₁ h₀

lemma is_spectral_map.continuous {f : α → β} (hf : is_spectral_map f) : continuous f :=
hf.to_continuous

lemma is_spectral_map_id : is_spectral_map (@id α) := ⟨continuous_id, λ s _, id⟩

lemma is_spectral_map.comp {f : β → γ} {g : α → β} (hf : is_spectral_map f)
  (hg : is_spectral_map g) :
  is_spectral_map (f ∘ g) :=
⟨hf.continuous.comp hg.continuous,
  λ s hs₀ hs₁, (hs₁.preimage_of_open hf hs₀).preimage_of_open hg (hs₀.preimage hf.continuous)⟩

end unbundled

/-- The type of spectral maps from `α` to `β`. -/
structure spectral_map (α β : Type*) [topological_space α] [topological_space β] :=
(to_fun : α → β)
(spectral' : is_spectral_map to_fun)

/-- `spectral_map_class F α β` states that `F` is a type of spectral maps.

You should extend this class when you extend `spectral_map`. -/
class spectral_map_class (F : Type*) (α β : out_param $ Type*) [topological_space α]
  [topological_space β]
  extends fun_like F α (λ _, β) :=
(map_spectral (f : F) : is_spectral_map f)

export spectral_map_class (map_spectral)

attribute [simp] map_spectral

@[priority 100] -- See note [lower instance priority]
instance spectral_map_class.to_continuous_map_class [topological_space α] [topological_space β]
  [spectral_map_class F α β] :
  continuous_map_class F α β :=
⟨λ f, (map_spectral f).continuous⟩

instance [topological_space α] [topological_space β] [spectral_map_class F α β] :
  has_coe_t F (spectral_map α β) :=
⟨λ f, ⟨_, map_spectral f⟩⟩

/-! ### Spectral maps -/

namespace spectral_map
variables [topological_space α] [topological_space β] [topological_space γ] [topological_space δ]

/-- Reinterpret a `spectral_map` as a `continuous_map`. -/
def to_continuous_map (f : spectral_map α β) : continuous_map α β := ⟨_, f.spectral'.continuous⟩

instance : spectral_map_class (spectral_map α β) α β :=
{ coe := spectral_map.to_fun,
  coe_injective' := λ f g h, by { cases f, cases g, congr' },
  map_spectral := λ f, f.spectral' }

/-- Helper instance for when there's too many metavariables to apply `fun_like.has_coe_to_fun`
directly. -/
instance : has_coe_to_fun (spectral_map α β) (λ _, α → β) := fun_like.has_coe_to_fun

@[simp] lemma to_fun_eq_coe {f : spectral_map α β} : f.to_fun = (f : α → β) := rfl

@[ext] lemma ext {f g : spectral_map α β} (h : ∀ a, f a = g a) : f = g := fun_like.ext f g h

/-- Copy of a `spectral_map` with a new `to_fun` equal to the old one. Useful to fix definitional
equalities. -/
protected def copy (f : spectral_map α β) (f' : α → β) (h : f' = f) : spectral_map α β :=
⟨f', h.symm.subst f.spectral'⟩

variables (α)

/-- `id` as a `spectral_map`. -/
protected def id : spectral_map α α := ⟨id, is_spectral_map_id⟩

instance : inhabited (spectral_map α α) := ⟨spectral_map.id α⟩

@[simp] lemma coe_id : ⇑(spectral_map.id α) = id := rfl

variables {α}

@[simp] lemma id_apply (a : α) : spectral_map.id α a = a := rfl

/-- Composition of `spectral_map`s as a `spectral_map`. -/
def comp (f : spectral_map β γ) (g : spectral_map α β) : spectral_map α γ :=
⟨f.to_continuous_map.comp g.to_continuous_map, f.spectral'.comp g.spectral'⟩

@[simp] lemma coe_comp (f : spectral_map β γ) (g : spectral_map α β) : (f.comp g : α → γ) = f ∘ g :=
rfl
@[simp] lemma comp_apply (f : spectral_map β γ) (g : spectral_map α β) (a : α) :
  (f.comp g) a = f (g a) := rfl
@[simp] lemma coe_comp_continuous_map (f : spectral_map β γ) (g : spectral_map α β) :
  (f.comp g : continuous_map α γ) = (f : continuous_map β γ).comp g := rfl
@[simp] lemma comp_assoc (f : spectral_map γ δ) (g : spectral_map β γ) (h : spectral_map α β) :
  (f.comp g).comp h = f.comp (g.comp h) := rfl
@[simp] lemma comp_id (f : spectral_map α β) : f.comp (spectral_map.id α) = f :=
ext $ λ a, rfl
@[simp] lemma id_comp (f : spectral_map α β) : (spectral_map.id β).comp f = f :=
ext $ λ a, rfl

lemma cancel_left {g : spectral_map β γ} {f₁ f₂ : spectral_map α β} (hg : injective g) :
  g.comp f₁ = g.comp f₂ ↔ f₁ = f₂ :=
⟨λ h, ext $ λ a, hg $ by rw [←comp_apply, h, comp_apply], congr_arg _⟩

end spectral_map


/- Copied from the Liquid Tensor Experiment's `for_mathlib` files at commit `df38d96` -/
import data.fintype.card
import algebra.module.hom
import algebra.big_operators.fin
import algebraic_topology.simplicial_object
import category_theory.preadditive.opposite

import algebra.homology.homological_complex

namespace category_theory

variables {C : Type*} [category C] [preadditive C] (M : cosimplicial_object C)

namespace cosimplicial_object

open simplex_category finset add_monoid_hom category_theory.preadditive
open_locale simplicial big_operators

/-- The coboundary map in the alternating face map cochain complex. -/
def coboundary (n : ℕ) : M.obj [n] ⟶ M.obj [n+1] :=
∑ i : fin (n+2), (-1:ℤ)^(i:ℕ) • (M.δ i)

lemma coboundary_zero : coboundary M 0 = (M.δ 0) - (M.δ 1) :=
begin
  simp only [coboundary, fin.sum_univ_succ, fin.default_eq_zero, fin.coe_zero, one_zsmul,
    fin.coe_succ, univ_unique, neg_zsmul, pow_one, fin.succ_zero_eq_one, sum_singleton,
    pow_zero, sub_eq_add_neg]
end

@[reassoc]
lemma coboundary_coboundary (n : ℕ) : coboundary M n ≫ coboundary M (n+1) = 0 :=
begin
  let s : finset (fin (n+2) × fin (n+3)) := univ.filter (λ ij, (ij.2:ℕ) ≤ ij.1),
  calc coboundary M n ≫ coboundary M (n+1)
      = comp_hom (∑ (i:fin (n+2)), (-1:ℤ)^(i:ℕ) • (M.δ i))
                 (∑ (i:fin (n+3)), (-1:ℤ)^(i:ℕ) • (M.δ i)) : rfl
  ... = ∑ (i : fin (n+2)) (j : fin (n+3)), (-1:ℤ)^(i+j:ℕ) • ((M.δ i) ≫ (M.δ j)) : _
  ... = ∑ ij : fin (n+2) × fin (n+3), (-1:ℤ)^(ij.1+ij.2:ℕ) • ((M.δ ij.1) ≫ (M.δ ij.2)) :
        by rw [← univ_product_univ, sum_product]
  ... =   (∑ ij in s,  (-1:ℤ)^(ij.1+ij.2:ℕ) • ((M.δ ij.1) ≫ (M.δ ij.2)))
        + (∑ ij in sᶜ, (-1:ℤ)^(ij.1+ij.2:ℕ) • ((M.δ ij.1) ≫ (M.δ ij.2))) :
        by rw sum_add_sum_compl
  ... = 0 : _,
  { simp only [map_sum, map_zsmul, finset_sum_apply, smul_apply, smul_sum, pow_add, mul_smul],
    refl, },
  erw [← eq_neg_iff_add_eq_zero, ← finset.sum_neg_distrib],
  -- The sums are equal because we can give a bijection
  -- between the indexing sets, such that corresponding terms are equal.
  -- We get 4 goals. All the substance is in the second goal.
  refine (finset.sum_bij (λ (ij : fin (n+2) × fin (n+3)) hij,
    (ij.2.cast_lt (lt_of_le_of_lt (mem_filter.mp hij).right ij.1.is_lt), ij.1.succ))
    _ _ _ _),
  { -- Show that our function is well-defined
    rintro ⟨i,j⟩ hij, simp only [mem_filter, true_and, mem_univ, not_le, mem_compl, fin.coe_succ],
    dsimp [s] at hij ⊢, simp only [true_and, mem_filter, mem_univ] at hij,
    apply nat.lt_of_succ_le, apply nat.succ_le_succ, exact hij, },
  { -- The core of the proof.
    -- After all, we have to use the simplicial identity somewhere.
    rintros ⟨i,j⟩ hij_aux,
    have hij := (mem_filter.mp hij_aux).2,
    dsimp at hij ⊢,
    rw [δ_comp_δ], swap,
    { rwa ← fin.coe_fin_le },
    rw [← neg_zsmul],
    congr' 1,
    calc (-1) ^ (i + j : ℕ)
        = - (-1) ^ (i + j + 1 : ℕ) : _
    ... = - (-1) ^ (j + (i + 1) : ℕ) : _
    ... = _ : _,
    { rw [pow_succ, neg_one_mul, neg_neg] },
    { rw [add_assoc, add_left_comm] },
    { simp only [fin.coe_succ] } },
  { -- Show that our function is injective
    rintro ⟨i₁, j₁⟩ ⟨i₂, j₂⟩ hij₁ hij₂ h,
    rw [prod.mk.inj_iff, fin.eq_iff_veq, fin.eq_iff_veq] at h ⊢,
    simp at h,
    rwa [and_comm] at h, },
  { -- Show that our function is surjective
    rintro ⟨i,j⟩ hij,
    refine ⟨⟨j.pred _, i.cast_succ⟩, _, _⟩,
    { intro H,
      rw [H, mem_compl, mem_filter, not_and] at hij,
      exact hij (mem_univ _) (nat.zero_le _) },
    { cases i,
      simp only [true_and, mem_compl, mem_filter, mem_univ, not_le, fin.coe_pred] at hij ⊢,
      exact nat.le_pred_of_lt hij, },
    { ext; simp only [fin.succ_pred, fin.pred_succ, fin.cast_lt_cast_succ], }, },
end

/-- Make a cochain complex from a cosimplicial object. -/
def to_cocomplex : cochain_complex C ℕ := cochain_complex.of
(λ n, M.obj [n]) (λ n, M.coboundary n) M.coboundary_coboundary

/-- A functorial version of `to_cocomplex`. -/
def cocomplex : cosimplicial_object C ⥤ cochain_complex C ℕ :=
{ obj := to_cocomplex,
  map := λ M N f,
  { f := λ i, f.app _,
    comm' := begin
      rintro i j (rfl : i + 1 = j),
      dsimp [to_cocomplex, cochain_complex.of],
      simp only [if_pos rfl, category.comp_id, eq_to_hom_refl, coboundary, δ,
        preadditive.sum_comp, preadditive.comp_sum, comp_zsmul, zsmul_comp, nat_trans.naturality],
    end } }

namespace augmented

/-- The objects defining the cochain complex associated to an augmented cosimplicial object. -/
@[nolint unused_arguments]
def to_cocomplex_obj (M : augmented C) : ℕ → C
| 0 := augmented.point.obj M
| (n+1) := (augmented.drop.obj M).obj [n]

/-- The boundary maps defining the cochain complex associated to an augmented cosimplicial object.-/
def to_cocomplex_d {M : augmented C} : Π (n : ℕ), to_cocomplex_obj M n ⟶ to_cocomplex_obj M (n+1)
| 0 := M.hom.app _
| (n+1) := (augmented.drop.obj M).coboundary _

/-- The cochain complex associated to an augmented cosimplicial object. -/
@[simps]
def to_cocomplex (M : augmented C) : cochain_complex C ℕ := cochain_complex.of
(to_cocomplex_obj M) to_cocomplex_d
begin
  rintros (_|_),
  { dsimp [to_cocomplex_d],
    erw [coboundary_zero, preadditive.comp_sub, sub_eq_zero,
      ← M.hom.naturality, ← M.hom.naturality],
    refl },
  { apply coboundary_coboundary }
end

/-- A functorial version of to_cocomplex. -/
def cocomplex : augmented C ⥤ cochain_complex C ℕ :=
{ obj := to_cocomplex,
  map := λ M N f,
  { f := λ i,
    match i with
    | 0 := point.map f
    | (n+1) := (drop.map f).app _
    end,
    comm' := begin
      rintro i j (rfl : i + 1 = j),
      dsimp [to_cocomplex, cochain_complex.of],
      simp only [if_pos rfl, eq_to_hom_refl, category.comp_id],
      cases i,
      { dsimp [to_cocomplex_d],
        erw [← nat_trans.comp_app, ← f.w],
        refl },
      { dsimp [to_cocomplex_d, coboundary],
        simp only [preadditive.sum_comp, preadditive.comp_sum, comp_zsmul, zsmul_comp],
        apply fintype.sum_congr,
        intro i,
        erw (drop.map f).naturality,
        refl }
    end },
  map_id' := λ M, by { ext (_|_), tidy },
  map_comp' := λ M N K f g, by { ext (_|_), tidy } }

end augmented

end cosimplicial_object

end category_theory

namespace category_theory

variables {C : Type*} [category C] [preadditive C] (M : simplicial_object C)

namespace simplicial_object

open simplex_category finset category_theory.preadditive opposite
open_locale simplicial big_operators

/-- The boundary map in the alternating face map chain complex. -/
def boundary (n : ℕ) : M.obj (opposite.op [n+1]) ⟶ M.obj (opposite.op [n]) :=
∑ i : fin (n+2), (-1:ℤ)^(i:ℕ) • (M.δ i)

lemma boundary_zero : boundary M 0 = (M.δ 0) - (M.δ 1) :=
begin
  simp only [boundary, fin.sum_univ_succ, fin.default_eq_zero, fin.coe_zero, one_zsmul,
    fin.coe_succ, univ_unique, neg_zsmul, pow_one, fin.succ_zero_eq_one, sum_singleton,
    pow_zero, sub_eq_add_neg]
end

lemma coboundary_right_op (n : ℕ) :
  (cosimplicial_object.coboundary (M.right_op) n).unop = boundary M n :=
begin
  dsimp only [cosimplicial_object.coboundary, boundary],
  simp only [unop_sum, unop_zsmul],
  refl
end

@[reassoc]
lemma boundary_boundary (n : ℕ) : boundary M (n+1) ≫ boundary M n = 0 :=
begin
  rw [← coboundary_right_op, ← coboundary_right_op, ← unop_comp,
    cosimplicial_object.coboundary_coboundary, unop_zero],
end

/-- Make a chain complex from a simplicial object. -/
def to_complex : chain_complex C ℕ := chain_complex.of
(λ n, M.obj (opposite.op [n])) (λ n, M.boundary n) M.boundary_boundary

/-- A functorial version of `to_complex`. -/
def complex : simplicial_object C ⥤ chain_complex C ℕ :=
{ obj := to_complex,
  map := λ M N f,
  { f := λ i, f.app _,
    comm' := begin
      rintro i j (rfl : j + 1 = i),
      dsimp [to_complex, chain_complex.of],
      simp only [if_pos rfl, category.id_comp, eq_to_hom_refl, boundary, δ,
        preadditive.sum_comp, preadditive.comp_sum, comp_zsmul, zsmul_comp, nat_trans.naturality],
    end } }

namespace augmented

/-- The objects defining the chain complex associated to an augmented simplicial object. -/
@[nolint unused_arguments]
def to_complex_obj (M : augmented C) : ℕ → C
| 0 := augmented.point.obj M
| (n+1) := (augmented.drop.obj M).obj (opposite.op [n])

/-- The boundary maps defining the chain complex associated to an augmented simplicial object.-/
def to_complex_d {M : augmented C} : Π (n : ℕ), to_complex_obj M (n+1) ⟶ to_complex_obj M n
| 0 := M.hom.app _
| (n+1) := (augmented.drop.obj M).boundary _

/-- The chain complex associated to an augmented simplicial object. -/
@[simps]
def to_complex (M : augmented C) : chain_complex C ℕ := chain_complex.of
(to_complex_obj M) to_complex_d
begin
  rintros (_|_),
  { dsimp [to_complex_d],
    erw [boundary_zero, preadditive.sub_comp, sub_eq_zero,
      M.hom.naturality, M.hom.naturality],
    refl },
  { apply boundary_boundary }
end

/-- A functorial version of to_complex. -/
def complex : augmented C ⥤ chain_complex C ℕ :=
{ obj := to_complex,
  map := λ M N f,
  { f := λ i,
    match i with
    | 0 := point.map f
    | (n+1) := (drop.map f).app _
    end,
    comm' := begin
      rintro i j (rfl : j + 1 = i),
      dsimp [to_complex, chain_complex.of],
      simp only [if_pos rfl, eq_to_hom_refl, category.id_comp],
      cases j,
      { dsimp [to_complex_d],
        erw [← nat_trans.comp_app, f.w],
        refl },
      { dsimp [to_complex_d, boundary],
        simp only [preadditive.sum_comp, preadditive.comp_sum, comp_zsmul, zsmul_comp],
        apply fintype.sum_congr,
        intro i,
        erw (drop.map f).naturality,
        refl }
    end },
  map_id' := λ M, by { ext (_|_), tidy },
  map_comp' := λ M N K f g, by { ext (_|_), tidy } }

end augmented

end simplicial_object

end category_theory


/-
Copyright (c) 2022 Yaël Dillies. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Yaël Dillies, Christopher Hoskin
-/
import algebra.group_power.lemmas
import algebra.hom.group_instances

/-!
# Centroid homomorphisms

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

Let `A` be a (non unital, non associative) algebra. The centroid of `A` is the set of linear maps
`T` on `A` such that `T` commutes with left and right multiplication, that is to say, for all `a`
and `b` in `A`,
$$
T(ab) = (Ta)b, T(ab) = a(Tb).
$$
In mathlib we call elements of the centroid "centroid homomorphisms" (`centroid_hom`) in keeping
with `add_monoid_hom` etc.

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

## Types of morphisms

* `centroid_hom`: Maps which preserve left and right multiplication.

## Typeclasses

* `centroid_hom_class`

## References

* [Jacobson, Structure of Rings][Jacobson1956]
* [McCrimmon, A taste of Jordan algebras][mccrimmon2004]

## Tags

centroid
-/

open function

variables {F α : Type*}

-- Making `centroid_hom` an old structure will allow the lemma `to_add_monoid_hom_eq_coe`
-- to be true by `rfl`. After upgrading to Lean 4, this should no longer be needed
-- because eta for structures should provide the same result.
set_option old_structure_cmd true

/-- The type of centroid homomorphisms from `α` to `α`. -/
structure centroid_hom (α : Type*) [non_unital_non_assoc_semiring α] extends α →+ α :=
(map_mul_left' (a b : α) : to_fun (a * b) = a * to_fun b)
(map_mul_right' (a b : α) : to_fun (a * b) = to_fun a * b)

attribute [nolint doc_blame] centroid_hom.to_add_monoid_hom

/-- `centroid_hom_class F α` states that `F` is a type of centroid homomorphisms.

You should extend this class when you extend `centroid_hom`. -/
class centroid_hom_class (F : Type*) (α : out_param $ Type*) [non_unital_non_assoc_semiring α]
  extends add_monoid_hom_class F α α :=
(map_mul_left (f : F) (a b : α) : f (a * b) = a * f b)
(map_mul_right (f : F) (a b : α) : f (a * b) = f a * b)

export centroid_hom_class (map_mul_left map_mul_right)

instance [non_unital_non_assoc_semiring α] [centroid_hom_class F α] :
  has_coe_t F (centroid_hom α) :=
⟨λ f, { to_fun := f, map_mul_left' := map_mul_left f, map_mul_right' := map_mul_right f,
  ..(f : α →+ α) }⟩

/-! ### Centroid homomorphisms -/

namespace centroid_hom

section non_unital_non_assoc_semiring

variables [non_unital_non_assoc_semiring α]

instance : centroid_hom_class (centroid_hom α) α :=
{ coe := λ f, f.to_fun,
  coe_injective' := λ f g h, by { cases f, cases g, congr' },
  map_zero := λ f, f.map_zero',
  map_add := λ f, f.map_add',
  map_mul_left := λ f, f.map_mul_left',
  map_mul_right := λ f, f.map_mul_right' }

/-- Helper instance for when there's too many metavariables to apply `fun_like.has_coe_to_fun`
directly. -/
instance : has_coe_to_fun (centroid_hom α) (λ _, α → α) := fun_like.has_coe_to_fun

@[simp] lemma to_fun_eq_coe {f : centroid_hom α} : f.to_fun = (f : α → α) := rfl

@[ext] lemma ext {f g : centroid_hom α} (h : ∀ a, f a = g a) : f = g := fun_like.ext f g h

@[simp, norm_cast] lemma coe_to_add_monoid_hom (f : centroid_hom α) : ⇑(f : α →+ α) = f := rfl
@[simp] lemma to_add_monoid_hom_eq_coe (f : centroid_hom α) : f.to_add_monoid_hom = f := rfl

lemma coe_to_add_monoid_hom_injective : injective (coe : centroid_hom α → α →+ α) :=
λ f g h, ext $ λ a, by { have := fun_like.congr_fun h a, exact this }

/-- Turn a centroid homomorphism into an additive monoid endomorphism. -/
def to_End (f : centroid_hom α) : add_monoid.End α := (f : α →+ α)

lemma to_End_injective : injective (centroid_hom.to_End : centroid_hom α → add_monoid.End α) :=
coe_to_add_monoid_hom_injective

/-- Copy of a `centroid_hom` with a new `to_fun` equal to the old one. Useful to fix
definitional equalities. -/
protected def copy (f : centroid_hom α) (f' : α → α) (h : f' = f) :
  centroid_hom α :=
{ to_fun := f',
  map_mul_left' := λ a b, by simp_rw [h, map_mul_left],
  map_mul_right' := λ a b, by simp_rw [h, map_mul_right],
  ..f.to_add_monoid_hom.copy f' $ by exact h }

@[simp] lemma coe_copy (f : centroid_hom α) (f' : α → α) (h : f' = f) : ⇑(f.copy f' h) = f' := rfl

variables (α)

/-- `id` as a `centroid_hom`. -/
protected def id : centroid_hom α :=
{ map_mul_left' := λ _ _, rfl,
  map_mul_right' := λ _ _, rfl,
  .. add_monoid_hom.id α }

instance : inhabited (centroid_hom α) := ⟨centroid_hom.id α⟩

@[simp, norm_cast] lemma coe_id : ⇑(centroid_hom.id α) = id := rfl

@[simp, norm_cast] lemma coe_to_add_monoid_hom_id :
  (centroid_hom.id α : α →+ α) = add_monoid_hom.id α := rfl

variables {α}

@[simp] lemma id_apply (a : α) : centroid_hom.id α a = a := rfl

/-- Composition of `centroid_hom`s as a `centroid_hom`. -/
def comp (g f : centroid_hom α) : centroid_hom α :=
{ map_mul_left' := λ a b, (congr_arg g $ f.map_mul_left' _ _).trans $ g.map_mul_left' _ _,
  map_mul_right' := λ a b, (congr_arg g $ f.map_mul_right' _ _).trans $ g.map_mul_right' _ _,
  .. g.to_add_monoid_hom.comp f.to_add_monoid_hom }

@[simp, norm_cast] lemma coe_comp (g f : centroid_hom α) : ⇑(g.comp f) = g ∘ f := rfl
@[simp] lemma comp_apply (g f : centroid_hom α) (a : α) : g.comp f a = g (f a) := rfl
@[simp, norm_cast] lemma coe_comp_add_monoid_hom (g f : centroid_hom α) :
  (g.comp f : α →+ α) = (g : α →+ α).comp f := rfl
@[simp] lemma comp_assoc (h g f : centroid_hom α) : (h.comp g).comp f = h.comp (g.comp f) := rfl
@[simp] lemma comp_id (f : centroid_hom α) : f.comp (centroid_hom.id α) = f := ext $ λ a, rfl
@[simp] lemma id_comp (f : centroid_hom α) : (centroid_hom.id α).comp f = f := ext $ λ a, rfl

lemma cancel_right {g₁ g₂ f : centroid_hom α} (hf : surjective f) :
  g₁.comp f = g₂.comp f ↔ g₁ = g₂ :=
⟨λ h, ext $ hf.forall.2 $ fun_like.ext_iff.1 h, congr_arg _⟩

lemma cancel_left {g f₁ f₂ : centroid_hom α} (hg : injective g) : g.comp f₁ = g.comp f₂ ↔ f₁ = f₂ :=
⟨λ h, ext $ λ a, hg $ by rw [←comp_apply, h, comp_apply], congr_arg _⟩

instance : has_zero (centroid_hom α) :=
⟨{ map_mul_left' := λ a b, (mul_zero _).symm,
  map_mul_right' := λ a b, (zero_mul _).symm,
  ..(0 : α →+ α) }⟩

instance : has_one (centroid_hom α) := ⟨centroid_hom.id α⟩

instance : has_add (centroid_hom α) :=
⟨λ f g,
  { map_mul_left' := λ a b, by simp [map_mul_left, mul_add],
    map_mul_right' := λ a b, by simp [map_mul_right, add_mul],
    ..(f + g : α →+ α) } ⟩

instance : has_mul (centroid_hom α) := ⟨comp⟩

instance has_nsmul : has_smul ℕ (centroid_hom α) :=
⟨λ n f,
  { map_mul_left' := λ a b,
      by { change n • f (a * b) = a * n • f b, rw [map_mul_left f, ←mul_smul_comm] },
    map_mul_right' := λ a b,
      by { change n • f (a * b) = n • f a * b, rw [map_mul_right f, ←smul_mul_assoc] },
    .. (n • f : α →+ α) }⟩

instance has_npow_nat : has_pow (centroid_hom α) ℕ :=
⟨λ f n,
{  map_mul_left' := λ a b, begin
    induction n with n ih,
    { simp },
    { rw pow_succ,
      exact (congr_arg f.to_End ih).trans (f.map_mul_left' _ _) }
  end,
  map_mul_right' := λ a b, begin
    induction n with n ih,
    { simp },
    { rw pow_succ,
      exact (congr_arg f.to_End ih).trans (f.map_mul_right' _ _) }
  end,
  ..(f.to_End ^ n : add_monoid.End α) }⟩

@[simp, norm_cast] lemma coe_zero : ⇑(0 : centroid_hom α) = 0 := rfl
@[simp, norm_cast] lemma coe_one : ⇑(1 : centroid_hom α) = id := rfl
@[simp, norm_cast] lemma coe_add (f g : centroid_hom α) : ⇑(f + g) = f + g := rfl
@[simp, norm_cast] lemma coe_mul (f g : centroid_hom α) : ⇑(f * g) = f ∘ g := rfl
-- Eligible for `dsimp`
@[simp, norm_cast, nolint simp_nf] lemma coe_nsmul (f : centroid_hom α) (n : ℕ) :
  ⇑(n • f) = n • f := rfl

@[simp] lemma zero_apply (a : α) : (0 : centroid_hom α) a = 0 := rfl
@[simp] lemma one_apply (a : α) : (1 : centroid_hom α) a = a := rfl
@[simp] lemma add_apply (f g : centroid_hom α) (a : α) : (f + g) a = f a + g a := rfl
@[simp] lemma mul_apply (f g : centroid_hom α) (a : α) : (f * g) a = f (g a) := rfl
-- Eligible for `dsimp`
@[simp, nolint simp_nf]
lemma nsmul_apply (f : centroid_hom α) (n : ℕ) (a : α) : (n • f) a = n • f a := rfl

@[simp] lemma to_End_zero : (0 : centroid_hom α).to_End = 0 := rfl
@[simp] lemma to_End_add (x y : centroid_hom α) : (x + y).to_End = x.to_End + y.to_End := rfl
lemma to_End_nsmul (x : centroid_hom α) (n : ℕ) : (n • x).to_End = n • x.to_End := rfl

-- cf.`add_monoid_hom.add_comm_monoid`
instance : add_comm_monoid (centroid_hom α) :=
coe_to_add_monoid_hom_injective.add_comm_monoid _ to_End_zero to_End_add to_End_nsmul

instance : has_nat_cast (centroid_hom α) :=
{ nat_cast := λ n, n • 1 }

@[simp, norm_cast] lemma coe_nat_cast (n : ℕ) : ⇑(n : centroid_hom α) = n • id := rfl

lemma nat_cast_apply (n : ℕ) (m : α):
  (n : centroid_hom α) m = n • m := rfl

@[simp] lemma to_End_one : (1 : centroid_hom α).to_End = 1 := rfl
@[simp] lemma to_End_mul (x y : centroid_hom α) : (x * y).to_End = x.to_End * y.to_End := rfl
@[simp] lemma to_End_pow (x : centroid_hom α) (n : ℕ) : (x ^ n).to_End = x.to_End ^ n :=
by { ext, refl }
@[simp, norm_cast] lemma to_End_nat_cast (n : ℕ) : (n : centroid_hom α).to_End = ↑n := rfl

-- cf `add_monoid.End.semiring`
instance : semiring (centroid_hom α) :=
to_End_injective.semiring _ to_End_zero to_End_one to_End_add to_End_mul
  to_End_nsmul to_End_pow to_End_nat_cast

lemma comp_mul_comm (T S : centroid_hom α) (a b : α) : (T ∘ S) (a * b) = (S ∘ T) (a * b) :=
by rw [comp_app, map_mul_right, map_mul_left, ←map_mul_right, ←map_mul_left]

end non_unital_non_assoc_semiring

section non_unital_non_assoc_ring
variables [non_unital_non_assoc_ring α]

/-- Negation of `centroid_hom`s as a `centroid_hom`. -/
instance : has_neg (centroid_hom α) :=
⟨λ f,
  { map_mul_left' := by simp [map_mul_left],
    map_mul_right' := by simp [map_mul_right],
    .. (-f : α →+ α) }⟩
instance : has_sub (centroid_hom α) :=
⟨λ f g,
{ map_mul_left' := λ a b, by simp [map_mul_left, mul_sub],
  map_mul_right' := λ a b, by simp [map_mul_right, sub_mul],
  .. (f - g : α →+ α) }⟩

instance has_zsmul : has_smul ℤ (centroid_hom α) :=
⟨λ n f,
  { map_mul_left' := λ a b,
      by { change n • f (a * b) = a * n • f b, rw [map_mul_left f, ←mul_smul_comm] },
    map_mul_right' := λ a b,
      by { change n • f (a * b) = n • f a * b, rw [map_mul_right f, ←smul_mul_assoc] },
    .. (n • f : α →+ α) }⟩

instance : has_int_cast (centroid_hom α) :=
{ int_cast := λ z, z • 1 }

@[simp, norm_cast] lemma coe_int_cast (z : ℤ) : ⇑(z : centroid_hom α) = z • id := rfl

lemma int_cast_apply (z : ℤ) (m : α) :
  (z : centroid_hom α) m = z • m := rfl

@[simp] lemma to_End_neg (x : centroid_hom α) : (-x).to_End = -x.to_End := rfl
@[simp] lemma to_End_sub (x y : centroid_hom α) : (x - y).to_End = x.to_End - y.to_End := rfl
lemma to_End_zsmul (x : centroid_hom α) (n : ℤ) : (n • x).to_End = n • x.to_End := rfl

instance : add_comm_group (centroid_hom α) :=
to_End_injective.add_comm_group _ to_End_zero to_End_add to_End_neg to_End_sub
  to_End_nsmul to_End_zsmul

@[simp, norm_cast] lemma coe_neg (f : centroid_hom α) : ⇑(-f) = -f := rfl
@[simp, norm_cast] lemma coe_sub (f g : centroid_hom α) : ⇑(f - g) = f - g := rfl

@[simp] lemma neg_apply (f : centroid_hom α) (a : α) : (-f) a = - f a := rfl
@[simp] lemma sub_apply (f g : centroid_hom α) (a : α) : (f - g) a = f a - g a := rfl

@[simp, norm_cast] lemma to_End_int_cast (z : ℤ) : (z : centroid_hom α).to_End = ↑z := rfl

instance : ring (centroid_hom α) := to_End_injective.ring _ to_End_zero to_End_one
  to_End_add to_End_mul to_End_neg to_End_sub to_End_nsmul to_End_zsmul
  to_End_pow to_End_nat_cast to_End_int_cast

end non_unital_non_assoc_ring

section non_unital_ring
variables [non_unital_ring α]

/-- A prime associative ring has commutative centroid. -/
@[reducible] -- See note [reducible non instances]
def comm_ring (h : ∀ a b : α, (∀ r : α, a * r * b = 0) → a = 0 ∨ b = 0) :
  comm_ring (centroid_hom α) :=
{ mul_comm := λ f g, begin
    ext,
    refine sub_eq_zero.1 ((or_self _).1 $ h _ _ $ λ r, _),
    rw [mul_assoc, sub_mul, sub_eq_zero, ← map_mul_right, ← map_mul_right, coe_mul, coe_mul,
      comp_mul_comm],
  end,
  ..centroid_hom.ring }

end non_unital_ring
end centroid_hom


/-
Copyright (c) 2020 Riccardo Brasca. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Author: Riccardo Brasca
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.data.polynomial.algebra_map
import Mathlib.algebra.algebra.subalgebra
import Mathlib.algebra.polynomial.big_operators
import Mathlib.data.polynomial.erase_lead
import Mathlib.PostPort

universes u v

namespace Mathlib

/-!
# Polynomials that lift

Given semirings `R` and `S` with a morphism `f : R →+* S`, we define a subsemiring `lifts` of
`polynomial S` by the image of `ring_hom.of (map f)`.
Then, we prove that a polynomial that lifts can always be lifted to a polynomial of the same degree
and that a monic polynomial that lifts can be lifted to a monic polynomial (of the same degree).

## Main definition

* `lifts (f : R →+* S)` : the subsemiring of polynomials that lift.

## Main results

* `lifts_and_degree_eq` : A polynomial lifts if and only if it can be lifted to a polynomial
of the same degree.
* `lifts_and_degree_eq_and_monic` : A monic polynomial lifts if and only if it can be lifted to a
monic polynomial of the same degree.
* `lifts_iff_alg` : if `R` is commutative, a polynomial lifts if and only if it is in the image of
`map_alg`, where `map_alg : polynomial R →ₐ[R] polynomial S` is the only `R`-algebra map
that sends `X` to `X`.

## Implementation details

In general `R` and `S` are semiring, so `lifts` is a semiring. In the case of rings, see
`lifts_iff_lifts_ring`.

Since we do not assume `R` to be commutative, we cannot say in general that the set of polynomials
that lift is a subalgebra. (By `lift_iff` this is true if `R` is commutative.)

-/

namespace polynomial

/-- We define the subsemiring of polynomials that lifts as the image of `ring_hom.of (map f)`. -/
def lifts {R : Type u} [semiring R] {S : Type v} [semiring S] (f : R →+* S) : subsemiring (polynomial S) :=
  ring_hom.srange (ring_hom.of (map f))

theorem mem_lifts {R : Type u} [semiring R] {S : Type v} [semiring S] {f : R →+* S} (p : polynomial S) : p ∈ lifts f ↔ ∃ (q : polynomial R), map f q = p := sorry

theorem lifts_iff_set_range {R : Type u} [semiring R] {S : Type v} [semiring S] {f : R →+* S} (p : polynomial S) : p ∈ lifts f ↔ p ∈ set.range (map f) := sorry

theorem lifts_iff_coeff_lifts {R : Type u} [semiring R] {S : Type v} [semiring S] {f : R →+* S} (p : polynomial S) : p ∈ lifts f ↔ ∀ (n : ℕ), coeff p n ∈ set.range ⇑f := sorry

/--If `(r : R)`, then `C (f r)` lifts. -/
theorem C_mem_lifts {R : Type u} [semiring R] {S : Type v} [semiring S] (f : R →+* S) (r : R) : coe_fn C (coe_fn f r) ∈ lifts f := sorry

/-- If `(s : S)` is in the image of `f`, then `C s` lifts. -/
theorem C'_mem_lifts {R : Type u} [semiring R] {S : Type v} [semiring S] {f : R →+* S} {s : S} (h : s ∈ set.range ⇑f) : coe_fn C s ∈ lifts f := sorry

/-- The polynomial `X` lifts. -/
theorem X_mem_lifts {R : Type u} [semiring R] {S : Type v} [semiring S] (f : R →+* S) : X ∈ lifts f := sorry

/-- The polynomial `X ^ n` lifts. -/
theorem X_pow_mem_lifts {R : Type u} [semiring R] {S : Type v} [semiring S] (f : R →+* S) (n : ℕ) : X ^ n ∈ lifts f := sorry

/-- If `p` lifts and `(r : R)` then `r * p` lifts. -/
theorem base_mul_mem_lifts {R : Type u} [semiring R] {S : Type v} [semiring S] {f : R →+* S} {p : polynomial S} (r : R) (hp : p ∈ lifts f) : coe_fn C (coe_fn f r) * p ∈ lifts f := sorry

/-- If `(s : S)` is in the image of `f`, then `monomial n s` lifts. -/
theorem monomial_mem_lifts {R : Type u} [semiring R] {S : Type v} [semiring S] {f : R →+* S} {s : S} (n : ℕ) (h : s ∈ set.range ⇑f) : coe_fn (monomial n) s ∈ lifts f := sorry

/-- If `p` lifts then `p.erase n` lifts. -/
theorem erase_mem_lifts {R : Type u} [semiring R] {S : Type v} [semiring S] {f : R →+* S} {p : polynomial S} (n : ℕ) (h : p ∈ lifts f) : finsupp.erase n p ∈ lifts f := sorry

theorem monomial_mem_lifts_and_degree_eq {R : Type u} [semiring R] {S : Type v} [semiring S] {f : R →+* S} {s : S} {n : ℕ} (hl : coe_fn (monomial n) s ∈ lifts f) : ∃ (q : polynomial R), map f q = coe_fn (monomial n) s ∧ degree q = degree (coe_fn (monomial n) s) := sorry

/-- A polynomial lifts if and only if it can be lifted to a polynomial of the same degree. -/
theorem mem_lifts_and_degree_eq {R : Type u} [semiring R] {S : Type v} [semiring S] {f : R →+* S} {p : polynomial S} (hlifts : p ∈ lifts f) : ∃ (q : polynomial R), map f q = p ∧ degree q = degree p := sorry

/-- A monic polynomial lifts if and only if it can be lifted to a monic polynomial
of the same degree. -/
theorem lifts_and_degree_eq_and_monic {R : Type u} [semiring R] {S : Type v} [semiring S] {f : R →+* S} [nontrivial S] {p : polynomial S} (hlifts : p ∈ lifts f) (hmonic : monic p) : ∃ (q : polynomial R), map f q = p ∧ degree q = degree p ∧ monic q := sorry

/-- The subring of polynomials that lift. -/
def lifts_ring {R : Type u} [ring R] {S : Type v} [ring S] (f : R →+* S) : subring (polynomial S) :=
  ring_hom.range (ring_hom.of (map f))

/-- If `R` and `S` are rings, `p` is in the subring of polynomials that lift if and only if it is in
the subsemiring of polynomials that lift. -/
theorem lifts_iff_lifts_ring {R : Type u} [ring R] {S : Type v} [ring S] (f : R →+* S) (p : polynomial S) : p ∈ lifts f ↔ p ∈ lifts_ring f := sorry

/-- The map `polynomial R → polynomial S` as an algebra homomorphism. -/
def map_alg (R : Type u) [comm_semiring R] (S : Type v) [semiring S] [algebra R S] : alg_hom R (polynomial R) (polynomial S) :=
  aeval X

/-- `map_alg` is the morphism induced by `R → S`. -/
theorem map_alg_eq_map {R : Type u} [comm_semiring R] {S : Type v} [semiring S] [algebra R S] (p : polynomial R) : coe_fn (map_alg R S) p = map (algebra_map R S) p := sorry

/-- A polynomial `p` lifts if and only if it is in the image of `map_alg`. -/
theorem mem_lifts_iff_mem_alg (R : Type u) [comm_semiring R] {S : Type v} [semiring S] [algebra R S] (p : polynomial S) : p ∈ lifts (algebra_map R S) ↔ p ∈ alg_hom.range (map_alg R S) := sorry

/-- If `p` lifts and `(r : R)` then `r • p` lifts. -/
theorem smul_mem_lifts {R : Type u} [comm_semiring R] {S : Type v} [semiring S] [algebra R S] {p : polynomial S} (r : R) (hp : p ∈ lifts (algebra_map R S)) : r • p ∈ lifts (algebra_map R S) :=
  eq.mpr (id (Eq._oldrec (Eq.refl (r • p ∈ lifts (algebra_map R S))) (propext (mem_lifts_iff_mem_alg R (r • p)))))
    (subalgebra.smul_mem (alg_hom.range (map_alg R S))
      (eq.mp (Eq._oldrec (Eq.refl (p ∈ lifts (algebra_map R S))) (propext (mem_lifts_iff_mem_alg R p))) hp) r)


/-
Copyright (c) 2022 Joseph Hua. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Scott Morrison, Bhavik Mehta, Johan Commelin, Reid Barton, Rob Lewis, Joseph Hua
-/
import category_theory.functor.reflects_isomorphisms
import category_theory.limits.shapes.terminal

/-!

# Algebras of endofunctors

This file defines (co)algebras of an endofunctor, and provides the category instance for them.
It also defines the forgetful functor from the category of (co)algebras. It is shown that the
structure map of the initial algebra of an endofunctor is an isomorphism. Furthermore, it is shown
that for an adjunction `F ⊣ G` the category of algebras over `F` is equivalent to the category of
coalgebras over `G`.

## TODO

* Prove the dual result about the structure map of the terminal coalgebra of an endofunctor.
* Prove that if the countable infinite product over the powers of the endofunctor exists, then
  algebras over the endofunctor coincide with algebras over the free monad on the endofunctor.
-/

universes v u

namespace category_theory
namespace endofunctor

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

/-- An algebra of an endofunctor; `str` stands for "structure morphism" -/
structure algebra (F : C ⥤ C) :=
(A : C)
(str : F.obj A ⟶ A)

instance [inhabited C] : inhabited (algebra (𝟭 C)) := ⟨⟨ default , 𝟙 _ ⟩⟩

namespace algebra

variables {F : C ⥤ C} (A : algebra F) {A₀ A₁ A₂ : algebra F}

/-
```
        str
   F A₀ -----> A₀
    |          |
F f |          | f
    V          V
   F A₁ -----> A₁
        str
```
-/
/-- A morphism between algebras of endofunctor `F` -/
@[ext] structure hom (A₀ A₁ : algebra F) :=
(f : A₀.1 ⟶ A₁.1)
(h' : F.map f ≫ A₁.str = A₀.str ≫ f . obviously)

restate_axiom hom.h'
attribute [simp, reassoc] hom.h
namespace hom

/-- The identity morphism of an algebra of endofunctor `F` -/
def id : hom A A := { f := 𝟙 _ }

instance : inhabited (hom A A) := ⟨{ f := 𝟙 _ }⟩

/-- The composition of morphisms between algebras of endofunctor `F` -/
def comp (f : hom A₀ A₁) (g : hom A₁ A₂) : hom A₀ A₂ := { f := f.1 ≫ g.1 }

end hom

instance (F : C ⥤ C) : category_struct (algebra F) :=
{ hom := hom,
  id := hom.id,
  comp := @hom.comp _ _ _ }

@[simp] lemma id_eq_id : algebra.hom.id A = 𝟙 A := rfl

@[simp] lemma id_f : (𝟙 _ : A ⟶ A).1 = 𝟙 A.1 := rfl

variables {A₀ A₁ A₂} (f : A₀ ⟶ A₁) (g : A₁ ⟶ A₂)

@[simp] lemma comp_eq_comp : algebra.hom.comp f g = f ≫ g := rfl

@[simp] lemma comp_f : (f ≫ g).1 = f.1 ≫ g.1 := rfl

/-- Algebras of an endofunctor `F` form a category -/
instance (F : C ⥤ C) : category (algebra F) := {}

/--
To construct an isomorphism of algebras, it suffices to give an isomorphism of the As which
commutes with the structure morphisms.
-/
@[simps]
def iso_mk (h : A₀.1 ≅ A₁.1) (w : F.map h.hom ≫ A₁.str = A₀.str ≫ h.hom) : A₀ ≅ A₁ :=
{ hom := { f := h.hom },
  inv :=
  { f := h.inv,
    h' := by { rw [h.eq_comp_inv, category.assoc, ←w, ←functor.map_comp_assoc], simp } } }

/-- The forgetful functor from the category of algebras, forgetting the algebraic structure. -/
@[simps] def forget (F : C ⥤ C) : algebra F ⥤ C :=
{ obj := λ A, A.1,
  map := λ A B f, f.1 }

/-- An algebra morphism with an underlying isomorphism hom in `C` is an algebra isomorphism. -/
lemma iso_of_iso (f : A₀ ⟶ A₁) [is_iso f.1] : is_iso f :=
⟨⟨{ f := inv f.1,
    h' := by { rw [is_iso.eq_comp_inv f.1, category.assoc, ← f.h], simp } }, by tidy⟩⟩

instance forget_reflects_iso : reflects_isomorphisms (forget F) :=
{ reflects := λ A B, iso_of_iso }

instance forget_faithful : faithful (forget F) := {}

/-- An algebra morphism with an underlying epimorphism hom in `C` is an algebra epimorphism. -/
lemma epi_of_epi {X Y : algebra F} (f : X ⟶ Y) [h : epi f.1] : epi f :=
(forget F).epi_of_epi_map h

/-- An algebra morphism with an underlying monomorphism hom in `C` is an algebra monomorphism. -/
lemma mono_of_mono {X Y : algebra F} (f : X ⟶ Y) [h : mono f.1] : mono f :=
(forget F).mono_of_mono_map h

/--
From a natural transformation `α : G → F` we get a functor from
algebras of `F` to algebras of `G`.
-/
@[simps]
def functor_of_nat_trans {F G : C ⥤ C} (α : G ⟶ F) : algebra F ⥤ algebra G :=
{ obj := λ A,
  { A := A.1,
    str := α.app A.1 ≫ A.str },
  map := λ A₀ A₁ f,
  { f := f.1 } }

/-- The identity transformation induces the identity endofunctor on the category of algebras. -/
@[simps {rhs_md := semireducible}]
def functor_of_nat_trans_id :
  functor_of_nat_trans (𝟙 F) ≅ 𝟭 _ :=
nat_iso.of_components
  (λ X, iso_mk (iso.refl _) (by { dsimp, simp, }))
  (λ X Y f, by { ext, dsimp, simp })

/-- A composition of natural transformations gives the composition of corresponding functors. -/
@[simps {rhs_md := semireducible}]
def functor_of_nat_trans_comp {F₀ F₁ F₂ : C ⥤ C} (α : F₀ ⟶ F₁) (β : F₁ ⟶ F₂) :
  functor_of_nat_trans (α ≫ β) ≅
    functor_of_nat_trans β ⋙ functor_of_nat_trans α :=
nat_iso.of_components
  (λ X, iso_mk (iso.refl _) (by { dsimp, simp }))
  (λ X Y f, by { ext, dsimp, simp })

/--
If `α` and `β` are two equal natural transformations, 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 {rhs_md := semireducible}]
def functor_of_nat_trans_eq {F G : C ⥤ C} {α β : F ⟶ G} (h : α = β) :
  functor_of_nat_trans α ≅ functor_of_nat_trans β :=
nat_iso.of_components
  (λ X, iso_mk (iso.refl _) (by { dsimp, simp [h] }))
  (λ X Y f, by { ext, dsimp, simp })

/--
Naturally isomorphic endofunctors give equivalent categories of algebras.
Furthermore, they are equivalent as categories over `C`, that is,
we have `equiv_of_nat_iso h ⋙ forget = forget`.
-/
@[simps]
def equiv_of_nat_iso {F G : C ⥤ C} (α : F ≅ G) :
  algebra F ≌ algebra G :=
{ functor := functor_of_nat_trans α.inv,
  inverse := functor_of_nat_trans α.hom,
  unit_iso :=
    functor_of_nat_trans_id.symm ≪≫
    functor_of_nat_trans_eq (by simp) ≪≫
    functor_of_nat_trans_comp _ _,
  counit_iso :=
    (functor_of_nat_trans_comp _ _).symm ≪≫
    functor_of_nat_trans_eq (by simp) ≪≫
    functor_of_nat_trans_id }.

namespace initial

variables {A} (h : limits.is_initial A)

/-- The inverse of the structure map of an initial algebra -/
@[simp] def str_inv : A.1 ⟶ F.obj A.1 := (h.to ⟨ F.obj A.1 , F.map A.str ⟩).1

lemma left_inv' : (⟨str_inv h ≫ A.str⟩ : A ⟶ A) = 𝟙 A :=
limits.is_initial.hom_ext h _ (𝟙 A)

lemma left_inv : str_inv h ≫ A.str = 𝟙 _ := congr_arg hom.f (left_inv' h)

lemma right_inv : A.str ≫ str_inv h = 𝟙 _ :=
by { rw [str_inv, ← (h.to ⟨ F.obj A.1 , F.map A.str ⟩).h,
  ← F.map_id, ← F.map_comp], congr, exact (left_inv h) }

/--
The structure map of the inital algebra is an isomorphism,
hence endofunctors preserve their initial algebras
-/

end initial
end algebra

/-- A coalgebra of an endofunctor; `str` stands for "structure morphism" -/
structure coalgebra (F : C ⥤ C) :=
(V : C)
(str : V ⟶ F.obj V)

instance [inhabited C] : inhabited (coalgebra (𝟭 C)) := ⟨⟨ default , 𝟙 _ ⟩⟩

namespace coalgebra

variables {F : C ⥤ C} (V : coalgebra F) {V₀ V₁ V₂ : coalgebra F}

/-
```
        str
    V₀ -----> F V₀
    |          |
  f |          | F f
    V          V
    V₁ -----> F V₁
        str
```
-/
/-- A morphism between coalgebras of an endofunctor `F` -/
@[ext] structure hom (V₀ V₁ : coalgebra F) :=
(f : V₀.1 ⟶ V₁.1)
(h' : V₀.str ≫ F.map f = f ≫ V₁.str . obviously)

restate_axiom hom.h'
attribute [simp, reassoc] hom.h
namespace hom

/-- The identity morphism of an algebra of endofunctor `F` -/
def id : hom V V := { f := 𝟙 _ }

instance : inhabited (hom V V) := ⟨{ f := 𝟙 _ }⟩

/-- The composition of morphisms between algebras of endofunctor `F` -/
def comp (f : hom V₀ V₁) (g : hom V₁ V₂) : hom V₀ V₂ := { f := f.1 ≫ g.1 }

end hom

instance (F : C ⥤ C) : category_struct (coalgebra F) :=
{ hom := hom,
  id := hom.id,
  comp := @hom.comp _ _ _ }

@[simp] lemma id_eq_id : coalgebra.hom.id V = 𝟙 V := rfl

@[simp] lemma id_f : (𝟙 _ : V ⟶ V).1 = 𝟙 V.1 := rfl

variables {V₀ V₁ V₂} (f : V₀ ⟶ V₁) (g : V₁ ⟶ V₂)

@[simp] lemma comp_eq_comp : coalgebra.hom.comp f g = f ≫ g := rfl

@[simp] lemma comp_f : (f ≫ g).1 = f.1 ≫ g.1 := rfl

/-- Coalgebras of an endofunctor `F` form a category -/
instance (F : C ⥤ C) : category (coalgebra F) := {}

/--
To construct an isomorphism of coalgebras, it suffices to give an isomorphism of the Vs which
commutes with the structure morphisms.
-/
@[simps]
def iso_mk (h : V₀.1 ≅ V₁.1) (w : V₀.str ≫ F.map h.hom = h.hom ≫ V₁.str ) : V₀ ≅ V₁ :=
{ hom := { f := h.hom },
  inv :=
  { f := h.inv,
    h' := by { rw [h.eq_inv_comp, ← category.assoc, ←w, category.assoc, ← functor.map_comp],
               simp only [iso.hom_inv_id, functor.map_id, category.comp_id] } } }

/-- The forgetful functor from the category of coalgebras, forgetting the coalgebraic structure. -/
@[simps] def forget (F : C ⥤ C) : coalgebra F ⥤ C :=
{ obj := λ A, A.1,
  map := λ A B f, f.1 }

/-- A coalgebra morphism with an underlying isomorphism hom in `C` is a coalgebra isomorphism. -/
lemma iso_of_iso (f : V₀ ⟶ V₁) [is_iso f.1] : is_iso f :=
⟨⟨{ f := inv f.1,
    h' := by { rw [is_iso.eq_inv_comp f.1, ← category.assoc, ← f.h, category.assoc], simp } },
          by tidy⟩⟩

instance forget_reflects_iso : reflects_isomorphisms (forget F) :=
{ reflects := λ A B, iso_of_iso }

instance forget_faithful : faithful (forget F) := {}

/-- An algebra morphism with an underlying epimorphism hom in `C` is an algebra epimorphism. -/
lemma epi_of_epi {X Y : coalgebra F} (f : X ⟶ Y) [h : epi f.1] : epi f :=
(forget F).epi_of_epi_map h

/-- An algebra morphism with an underlying monomorphism hom in `C` is an algebra monomorphism. -/
lemma mono_of_mono {X Y : coalgebra F} (f : X ⟶ Y) [h : mono f.1] : mono f :=
(forget F).mono_of_mono_map h

/--
From a natural transformation `α : F → G` we get a functor from
coalgebras of `F` to coalgebras of `G`.
-/
@[simps]
def functor_of_nat_trans {F G : C ⥤ C} (α : F ⟶ G) : coalgebra F ⥤ coalgebra G :=
{ obj := λ V,
  { V := V.1,
    str := V.str ≫ α.app V.1 },
  map := λ V₀ V₁ f, { f := f.1,
      h' := by rw [category.assoc, ← α.naturality, ← category.assoc, f.h, category.assoc] } }

/-- The identity transformation induces the identity endofunctor on the category of coalgebras. -/
@[simps {rhs_md := semireducible}]
def functor_of_nat_trans_id :
  functor_of_nat_trans (𝟙 F) ≅ 𝟭 _ :=
nat_iso.of_components
  (λ X, iso_mk (iso.refl _) (by { dsimp, simp, }))
  (λ X Y f, by { ext, dsimp, simp })

/-- A composition of natural transformations gives the composition of corresponding functors. -/
@[simps {rhs_md := semireducible}]
def functor_of_nat_trans_comp {F₀ F₁ F₂ : C ⥤ C} (α : F₀ ⟶ F₁) (β : F₁ ⟶ F₂) :
  functor_of_nat_trans (α ≫ β) ≅
    functor_of_nat_trans α ⋙ functor_of_nat_trans β :=
nat_iso.of_components
  (λ X, iso_mk (iso.refl _) (by { dsimp, simp }))
  (λ X Y f, by { ext, dsimp, simp })

/--
If `α` and `β` are two equal natural transformations, then the functors of coalgebras 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 {rhs_md := semireducible}]
def functor_of_nat_trans_eq {F G : C ⥤ C} {α β : F ⟶ G} (h : α = β) :
  functor_of_nat_trans α ≅ functor_of_nat_trans β :=
nat_iso.of_components
  (λ X, iso_mk (iso.refl _) (by { dsimp, simp [h] }))
  (λ X Y f, by { ext, dsimp, simp })

/--
Naturally isomorphic endofunctors give equivalent categories of coalgebras.
Furthermore, they are equivalent as categories over `C`, that is,
we have `equiv_of_nat_iso h ⋙ forget = forget`.
-/
@[simps]
def equiv_of_nat_iso {F G : C ⥤ C} (α : F ≅ G) :
  coalgebra F ≌ coalgebra G :=
{ functor := functor_of_nat_trans α.hom,
  inverse := functor_of_nat_trans α.inv,
  unit_iso :=
    functor_of_nat_trans_id.symm ≪≫
    functor_of_nat_trans_eq (by simp) ≪≫
    functor_of_nat_trans_comp _ _,
  counit_iso :=
    (functor_of_nat_trans_comp _ _).symm ≪≫
    functor_of_nat_trans_eq (by simp) ≪≫
    functor_of_nat_trans_id }.

end coalgebra

namespace adjunction

variables {F : C ⥤ C} {G : C ⥤ C}

lemma algebra.hom_equiv_naturality_str (adj : F ⊣ G) (A₁ A₂ : algebra F)
  (f : A₁ ⟶ A₂) : (adj.hom_equiv A₁.A A₁.A) A₁.str ≫ G.map f.f =
  f.f ≫ (adj.hom_equiv A₂.A A₂.A) A₂.str :=
by { rw [← adjunction.hom_equiv_naturality_right, ← adjunction.hom_equiv_naturality_left, f.h] }

lemma coalgebra.hom_equiv_naturality_str_symm (adj : F ⊣ G) (V₁ V₂ : coalgebra G)
  (f : V₁ ⟶ V₂) :  F.map f.f ≫ ((adj.hom_equiv V₂.V V₂.V).symm) V₂.str =
  ((adj.hom_equiv V₁.V V₁.V).symm) V₁.str ≫ f.f :=
by { rw [← adjunction.hom_equiv_naturality_left_symm, ← adjunction.hom_equiv_naturality_right_symm,
     f.h] }

/-- Given an adjunction `F ⊣ G`, the functor that associates to an algebra over `F` a
coalgebra over `G` defined via adjunction applied to the structure map. -/
def algebra.to_coalgebra_of (adj : F ⊣ G) : algebra F ⥤ coalgebra G :=
{ obj := λ A, { V := A.1,
                    str := (adj.hom_equiv A.1 A.1).to_fun A.2 },
      map := λ A₁ A₂ f, { f := f.1,
                          h' := (algebra.hom_equiv_naturality_str adj A₁ A₂ f) } }

/-- Given an adjunction `F ⊣ G`, the functor that associates to a coalgebra over `G` an algebra over
`F` defined via adjunction applied to the structure map. -/
def coalgebra.to_algebra_of (adj : F ⊣ G) : coalgebra G ⥤ algebra F :=
{ obj := λ V, { A := V.1,
                    str := (adj.hom_equiv V.1 V.1).inv_fun V.2 },
      map := λ V₁ V₂ f, { f := f.1,
                          h' := (coalgebra.hom_equiv_naturality_str_symm adj V₁ V₂ f) } }

/-- Given an adjunction, assigning to an algebra over the left adjoint a coalgebra over its right
adjoint and going back is isomorphic to the identity functor. -/
def alg_coalg_equiv.unit_iso (adj : F ⊣ G) :
  𝟭 (algebra F) ≅ (algebra.to_coalgebra_of adj) ⋙ (coalgebra.to_algebra_of adj) :=
{ hom :=
  { app := λ A,
    { f := (𝟙 A.1),
      h' := by { erw [F.map_id, category.id_comp, category.comp_id],
                 apply (adj.hom_equiv _ _).left_inv A.str } },
    naturality' := λ A₁ A₂ f, by { ext1, dsimp, erw [category.id_comp, category.comp_id], refl } },
  inv :=
  { app := λ A,
    { f := (𝟙 A.1),
      h' := by { erw [F.map_id, category.id_comp, category.comp_id],
                 apply ((adj.hom_equiv _ _).left_inv A.str).symm } },
    naturality' := λ A₁ A₂ f,
      by { ext1, dsimp, erw [category.comp_id, category.id_comp], refl } },
  hom_inv_id' := by { ext, exact category.comp_id _ },
  inv_hom_id' := by { ext, exact category.comp_id _ } }

/-- Given an adjunction, assigning to a coalgebra over the right adjoint an algebra over the left
adjoint and going back is isomorphic to the identity functor. -/
def alg_coalg_equiv.counit_iso (adj : F ⊣ G) :
  (coalgebra.to_algebra_of adj) ⋙ (algebra.to_coalgebra_of adj) ≅ 𝟭 (coalgebra G) :=
{ hom :=
  { app := λ V,
    { f := (𝟙 V.1),
      h' := by { dsimp, erw [G.map_id, category.id_comp, category.comp_id],
                 apply (adj.hom_equiv _ _).right_inv V.str } },
    naturality' := λ V₁ V₂ f,
      by { ext1, dsimp, erw [category.comp_id, category.id_comp], refl, } },
  inv :=
  { app := λ V,
    { f := (𝟙 V.1),
      h' := by { dsimp, rw [G.map_id, category.comp_id, category.id_comp],
                 apply ((adj.hom_equiv _ _).right_inv V.str).symm } },
    naturality' := λ V₁ V₂ f,
      by { ext1, dsimp, erw [category.comp_id, category.id_comp], refl } },
  hom_inv_id' := by { ext, exact category.comp_id _ },
  inv_hom_id' := by { ext, exact category.comp_id _ } }

/-- If `F` is left adjoint to `G`, then the category of algebras over `F` is equivalent to the
category of coalgebras over `G`. -/
def algebra_coalgebra_equiv (adj : F ⊣ G) : algebra F ≌ coalgebra G :=
{ functor := algebra.to_coalgebra_of adj,
  inverse := coalgebra.to_algebra_of adj,
  unit_iso := alg_coalg_equiv.unit_iso adj,
  counit_iso := alg_coalg_equiv.counit_iso adj,
  functor_unit_iso_comp' := λ A, by { ext, exact category.comp_id _ } }

end adjunction

end endofunctor
end category_theory