import analysis.calculus.bump_function_inner
import topology.metric_space.hausdorff_distance

import to_mathlib.topology.misc
import to_mathlib.topology.nhds_set
import to_mathlib.topology.hausdorff_distance
import to_mathlib.linear_algebra.basic

import notations

/-! # Spaces of 1-jets and their sections

For real normed spaces `E` and `F`, this file defines the space `one_jet_sec E F` of 1-jets
of maps from `E` to `F` as `E × F × (E →L[ℝ] F)`.

A section `𝓕 : jet_sec E F` of this space is a map `(𝓕.f, 𝓕.φ) : E → F × (E →L[ℝ] F)`.

It is holonomic at `x`, spelled `𝓕.is_holonomic_at x` if the differential of `𝓕.f` at `x`
is `𝓕.φ x`.

We then introduced parametrized families of sections, and especially homotopies of sections,
with type `htpy_jet_sec E F` and their concatenation operation `htpy_jet_sec.comp`.

Implementation note: the time parameter `t` for homotopies is any real number, but all the
homotopies we will construct will be constant for `t ≤ 0` and `t ≥ 1`. It looks like this imposes
more smoothness constraints at `t = 0` and `t = 1` (requiring flat functions), but this is needed
for smooth concatenations anyway.
 -/

noncomputable theory

open set function real filter
open_locale unit_interval topology

variables (E : Type*) [normed_add_comm_group E] [normed_space ℝ E]
variables (F : Type*) [normed_add_comm_group F] [normed_space ℝ F]
variables (P : Type*) [normed_add_comm_group P] [normed_space ℝ P]

/-! ## Spaces of 1-jets -/

/-- The space of 1-jets of maps from `E` to `F`. -/
@[derive metric_space]
def one_jet := E × F × (E →L[ℝ] F)

/-- A smooth section of J¹(E, F) → E. -/
@[ext] structure jet_sec :=
(f : E → F)
(f_diff : 𝒞 ∞ f)
(φ : E → E →L[ℝ] F)
(φ_diff : 𝒞 ∞ φ)

namespace jet_sec

variables {E F}

instance : has_coe_to_fun (jet_sec E F) (λ S, E → F × (E →L[ℝ] F)) :=
⟨λ 𝓕, λ x, (𝓕.f x, 𝓕.φ x)⟩

lemma coe_apply (𝓕 : jet_sec E F) (x : E) : 𝓕 x = (𝓕.f x, 𝓕.φ x) := rfl

lemma eq_iff {𝓕 𝓕' : jet_sec E F} {x : E} :
  𝓕 x = 𝓕' x ↔ 𝓕.f x = 𝓕'.f x ∧ 𝓕.φ x = 𝓕'.φ x :=
begin
  split,
  { intro h,
    exact ⟨congr_arg prod.fst h, congr_arg prod.snd h⟩ },
  { rintros ⟨h, h'⟩,
    ext1,
    exacts [h, h'] }
end

lemma ext' {𝓕 𝓕' : jet_sec E F} (h : ∀ x, 𝓕 x = 𝓕' x) : 𝓕 = 𝓕' :=
begin
  ext : 2,
  { exact congr_arg prod.fst (h x) },
  { ext1 x, exact congr_arg prod.snd (h x) },
end

/-! ## Holonomic sections-/

/-- A jet section `𝓕` is holonomic if its linear map part at `x`
is the derivative of its function part at `x`. -/
def is_holonomic_at (𝓕 : jet_sec E F) (x : E) : Prop := D 𝓕.f x = 𝓕.φ x

lemma is_holonomic_at.congr {𝓕 𝓕' : jet_sec E F} {x} (h : is_holonomic_at 𝓕 x)
  (h' : 𝓕 =ᶠ[𝓝 x] 𝓕') : is_holonomic_at 𝓕' x :=
begin
  have h'' : 𝓕.f =ᶠ[𝓝 x] 𝓕'.f,
  { apply h'.mono,
    dsimp only,
    simp_rw eq_iff,
    tauto },
  unfold jet_sec.is_holonomic_at,
  rwa [h''.symm.fderiv_eq, ← (eq_iff.mp h'.self_of_nhds).2]
end

/-- A formal solution `𝓕` of `R` is partially holonomic in the direction of some subspace `E'`
if its linear map part at `x` is the derivative of its function part at `x` in restriction to
`E'`. -/
def is_part_holonomic_at (𝓕 : jet_sec E F) (E' : submodule ℝ E) (x : E) :=
∀ v ∈ E', D 𝓕.f x v = 𝓕.φ x v

lemma _root_.filter.eventually.is_part_holonomic_at_congr {𝓕 𝓕' : jet_sec E F} {s : set E}
  (h : ∀ᶠ x near s, 𝓕 x = 𝓕' x) (E' : submodule ℝ E) :
  ∀ᶠ x near s, 𝓕.is_part_holonomic_at E' x ↔ 𝓕'.is_part_holonomic_at E' x :=
begin
  apply h.eventually_nhds_set.mono,
  intros x hx,
  have hf : 𝓕.f =ᶠ[𝓝 x] 𝓕'.f,
  { apply hx.mono,
    dsimp only,
    simp_rw eq_iff,
    tauto },
  unfold jet_sec.is_part_holonomic_at,
  rw [hf.fderiv_eq, (eq_iff.mp hx.self_of_nhds).2]
end

lemma is_part_holonomic_at.sup (𝓕 : jet_sec E F) {E' E'' : submodule ℝ E} {x : E}
  (h' : 𝓕.is_part_holonomic_at E' x) (h'' : 𝓕.is_part_holonomic_at E'' x) :
  𝓕.is_part_holonomic_at (E' ⊔ E'') x :=
λ v : E, linear_map.eq_on_sup h' h''

lemma is_part_holonomic_top {𝓕 : jet_sec E F} {x : E} :
  is_part_holonomic_at 𝓕 ⊤ x ↔ is_holonomic_at 𝓕 x :=
begin
  simp only [is_part_holonomic_at, submodule.mem_top, forall_true_left, is_holonomic_at],
  rw [← funext_iff, continuous_linear_map.coe_fn_injective.eq_iff]
end

@[simp] lemma is_part_holonomic_bot (𝓕 : jet_sec E F) :
  is_part_holonomic_at 𝓕 ⊥ = λ x, true :=
begin
  ext x,
  simp only [is_part_holonomic_at, submodule.mem_bot, forall_eq, map_zero, eq_self_iff_true]
end

end jet_sec

/-! ## Homotopies of sections -/

section htpy_jet_sec

/-- A parametrized family of sections of J¹(E, F). -/
structure family_jet_sec :=
(f : P → E → F)
(f_diff : 𝒞 ∞ ↿f)
(φ : P → E → E →L[ℝ] F)
(φ_diff : 𝒞 ∞ ↿φ)

/-- A homotopy of sections of J¹(E, F). -/
@[reducible] def htpy_jet_sec := family_jet_sec E F ℝ

variables  {E F P}

instance : has_coe_to_fun (family_jet_sec E F P) (λ S, P → jet_sec E F) :=
⟨λ S t,
 { f := S.f t,
   f_diff := S.f_diff.comp (cont_diff_const.prod cont_diff_id),
   φ := S.φ t,
   φ_diff := S.φ_diff.comp (cont_diff_const.prod cont_diff_id) }⟩

namespace family_jet_sec

lemma cont_diff_f (𝓕 : family_jet_sec E F P) {n : ℕ∞} : 𝒞 n ↿𝓕.f :=
𝓕.f_diff.of_le le_top

lemma cont_diff_φ (𝓕 : family_jet_sec E F P) {n : ℕ∞} : 𝒞 n ↿𝓕.φ :=
𝓕.φ_diff.of_le le_top

end family_jet_sec

/-- The constant homotopy of formal solutions at a given formal solution. It will be used
as junk value for constructions of formal homotopies that need additional assumptions and also
for trivial induction initialization. -/
def jet_sec.const_htpy (𝓕 : jet_sec E F) : htpy_jet_sec E F :=
{ f := λ t, 𝓕.f,
  f_diff := 𝓕.f_diff.snd',
  φ := λ t, 𝓕.φ,
  φ_diff := 𝓕.φ_diff.snd' }

@[simp] lemma jet_sec.const_htpy_apply (𝓕 : jet_sec E F) :
  ∀ t, 𝓕.const_htpy t = 𝓕 :=
λ t, by ext x ; refl

/-! ## Concatenation of homotopies of sections

In this part of the file we build a concatenation operation for homotopies of 1-jet sections.
We first need to introduce a smooth step function on `ℝ`. There is already a version
of this in mathlib called `smooth_transition` but that version is not locally constant
near `0` and `1`, which is not convenient enough for gluing purposes.
-/

/-- A smooth step function on `ℝ`. -/
def smooth_step : ℝ → ℝ := λ t, smooth_transition (2 * t - 1/2)

lemma smooth_step.smooth : 𝒞 ∞ smooth_step :=
smooth_transition.cont_diff.comp $ (cont_diff_id.const_smul (2 : ℝ)).sub cont_diff_const

@[simp]
lemma smooth_step.zero : smooth_step 0 = 0 :=
begin
  apply smooth_transition.zero_of_nonpos,
  norm_num
end

@[simp]
lemma smooth_step.one : smooth_step 1 = 1 :=
begin
  apply smooth_transition.one_of_one_le,
  norm_num
end

lemma smooth_step.mem (t : ℝ) : smooth_step t ∈ I :=
⟨smooth_transition.nonneg _, smooth_transition.le_one _⟩

lemma smooth_step.abs_le (t : ℝ) : |smooth_step t| ≤ 1 :=
abs_le.mpr ⟨by linarith [(smooth_step.mem t).1], smooth_transition.le_one _⟩

lemma smooth_step.of_lt {t : ℝ} (h : t < 1/4) : smooth_step t = 0 :=
begin
  apply smooth_transition.zero_of_nonpos,
  linarith
end

-- unused
lemma smooth_step.pos_of_gt {t : ℝ} (h : 1/4 < t) : 0 < smooth_step t :=
begin
  apply smooth_transition.pos_of_pos,
  linarith
end

lemma smooth_step.of_gt {t : ℝ} (h : 3/4 < t) : smooth_step t = 1 :=
begin
  apply smooth_transition.one_of_one_le,
  linarith
end

lemma htpy_jet_sec_comp_aux {f g : ℝ → E → F} (hf : 𝒞 ∞ ↿f) (hg : 𝒞 ∞ ↿g)
  (hfg : f 1 = g 0) :
  𝒞 ∞ ↿(λ t x, if t ≤ 1/2 then f (smooth_step $ 2*t) x else g (smooth_step $ 2*t - 1) x : ℝ → E → F) :=
begin
  have s₁ : 𝒞 ∞ (λ p : ℝ × E, (smooth_step $ 2*p.1, p.2)),
  { change 𝒞 ∞ ((prod.map smooth_step id) ∘ (λ p : ℝ × E, (2*p.1, p.2))),
    apply (smooth_step.smooth.prod_map cont_diff_id).comp,
    apply cont_diff.prod,
    apply cont_diff_const.mul cont_diff_fst,
    apply cont_diff_snd },
  replace hf := hf.comp s₁,
  have s₂ : 𝒞 ∞ (λ p : ℝ × E, (smooth_step $ 2*p.1 - 1, p.2)),
  { change 𝒞 ∞ ((prod.map smooth_step id) ∘ (λ p : ℝ × E, (2*p.1 - 1, p.2))),
    apply (smooth_step.smooth.prod_map cont_diff_id).comp,
    apply cont_diff.prod,
    apply cont_diff.sub,
    apply cont_diff_const.mul cont_diff_fst,
    apply cont_diff_const,
    apply cont_diff_snd },
  replace hg := hg.comp s₂,
  rw cont_diff_iff_cont_diff_at at *,
  rintros ⟨t₀ , x₀⟩,
  rcases lt_trichotomy t₀ (1/2) with ht|rfl|ht,
  { apply (hf (t₀, x₀)).congr_of_eventually_eq,
    have : (Iio (1/2) : set ℝ) ×ˢ univ ∈ 𝓝 (t₀, x₀),
      from prod_mem_nhds_iff.mpr ⟨Iio_mem_nhds ht, univ_mem⟩,
    filter_upwards [this] with p hp,
    cases p with t x,
    replace hp : t < 1/2 := (prod_mk_mem_set_prod_eq.mp hp).1,
    change ite (t ≤ 1 / 2) (f (smooth_step (2 * t)) x) (g (smooth_step (2 * t - 1)) x) = _,
    rw if_pos hp.le,
    refl },
  { apply (hf (1/2, x₀)).congr_of_eventually_eq,
    have : (Ioo (3/8) (5/8) : set ℝ) ×ˢ univ ∈ 𝓝 (1/(2 : ℝ), x₀),
    { refine prod_mem_nhds_iff.mpr ⟨Ioo_mem_nhds _ _, univ_mem⟩ ; norm_num },
    filter_upwards [this] with p hp,
    cases p with t x,
    cases (prod_mk_mem_set_prod_eq.mp hp).1 with lt_t t_lt,
    change ite (t ≤ 1 / 2) (f (smooth_step (2 * t)) x) (g (smooth_step (2 * t - 1)) x) = _,
    split_ifs,
    { refl },
    { change g _ x = f (smooth_step $ 2*t) x,
      apply congr_fun,
      rw [show smooth_step (2 * t - 1) = 0, by { apply smooth_step.of_lt, linarith },
          show smooth_step (2 * t) = 1, by { apply smooth_step.of_gt, linarith }, hfg] }, },
  { apply (hg (t₀, x₀)).congr_of_eventually_eq,
    have : (Ioi (1/2) : set ℝ) ×ˢ univ ∈ 𝓝 (t₀, x₀),
      from prod_mem_nhds_iff.mpr ⟨Ioi_mem_nhds ht, univ_mem⟩,
    filter_upwards [this] with p hp,
    cases p with t x,
    replace hp : ¬ (t ≤ 1/2) := by push_neg ; exact (prod_mk_mem_set_prod_eq.mp hp).1,
    change ite (t ≤ 1 / 2) (f (smooth_step (2 * t)) x) (g (smooth_step (2 * t - 1)) x) = _,
    rw if_neg hp,
    refl }
end

/-- Concatenation of homotopies of formal solution. The result depend on our choice of
a smooth step function in order to keep smoothness with respect to the time parameter. -/
def htpy_jet_sec.comp (𝓕 𝓖 : htpy_jet_sec E F) (h : 𝓕 1 = 𝓖 0) : htpy_jet_sec E F :=
{ f := λ t x, if t ≤ 1/2 then 𝓕.f (smooth_step $ 2*t) x else 𝓖.f (smooth_step $ 2*t - 1) x,
  f_diff :=
  htpy_jet_sec_comp_aux 𝓕.f_diff 𝓖.f_diff (show (𝓕 1).f = (𝓖 0).f, by rw h),
  φ := λ t x, if t ≤ 1/2 then 𝓕.φ (smooth_step $ 2*t) x else  𝓖.φ (smooth_step $ 2*t - 1) x,
  φ_diff :=
  htpy_jet_sec_comp_aux 𝓕.φ_diff 𝓖.φ_diff (show (𝓕 1).φ = (𝓖 0).φ, by rw h) }

@[simp]
lemma htpy_jet_sec.comp_of_le (𝓕 𝓖 : htpy_jet_sec E F) (h) {t : ℝ} (ht : t ≤ 1/2) :
  𝓕.comp 𝓖 h t = 𝓕 (smooth_step $ 2*t) :=
begin
  dsimp [htpy_jet_sec.comp],
  ext x,
  change (if t ≤ 1/2 then _ else  _) = _,
  rw if_pos ht,
  refl,
  ext1 x,
  change (if t ≤ 1 / 2 then _ else _) = (𝓕 _).φ x,
  rw if_pos ht,
  refl
end

lemma htpy_jet_sec.comp_le_0 (𝓕 𝓖 : htpy_jet_sec E F) (h) : ∀ᶠ t near Iic 0, 𝓕.comp 𝓖 h t = 𝓕 0 :=
begin
  have : Iio (1/8 : ℝ) ∈ 𝓝ˢ (Iic (0 : ℝ)),
  { apply mem_nhds_set_iff_forall.mpr (λ (x : ℝ) (hx : x ≤ 0), Iio_mem_nhds _),
    linarith },
  apply mem_of_superset this,
  rintros t (ht : t <1/8),
  have ht' : t ≤ 1/2,
  { linarith },
  change 𝓕.comp 𝓖 h t = 𝓕 0,
  rw htpy_jet_sec.comp_of_le _ _ h ht',
  have ht'' : 2*t < 1/4,
  { linarith },
  rw smooth_step.of_lt ht''
end

-- unused
@[simp]
lemma htpy_jet_sec.comp_0 (𝓕 𝓖 : htpy_jet_sec E F) (h) : 𝓕.comp 𝓖 h 0 = 𝓕 0 :=
(𝓕.comp_le_0 𝓖 h).on_set 0 right_mem_Iic

@[simp]
lemma htpy_jet_sec.comp_of_not_le (𝓕 𝓖 : htpy_jet_sec E F) (h) {t : ℝ} (ht : ¬ t ≤ 1/2) :
  𝓕.comp 𝓖 h t = 𝓖 (smooth_step $ 2*t - 1) :=
begin
  dsimp [htpy_jet_sec.comp],
  ext x,
  change (if t ≤ 1/2 then _ else  _) = _,
  rw if_neg ht,
  refl,
  ext1 x,
  change (if t ≤ 1 / 2 then _ else _) = (𝓖 _).φ x,
  rw if_neg ht,
  refl
end

lemma htpy_jet_sec.comp_ge_1 (𝓕 𝓖 : htpy_jet_sec E F) (h) : ∀ᶠ t near Ici 1, 𝓕.comp 𝓖 h t = 𝓖 1 :=
begin
  have : Ioi (7/8 : ℝ) ∈ 𝓝ˢ (Ici (1 : ℝ)),
  { apply mem_nhds_set_iff_forall.mpr (λ (x : ℝ) (hx : 1 ≤ x), Ioi_mem_nhds _),
    linarith },
  apply mem_of_superset this,
  rintros t (ht : 7/8 < t),
  have ht' : ¬ t ≤ 1/2,
  { linarith },
  change 𝓕.comp 𝓖 h t = 𝓖 1,
  rw htpy_jet_sec.comp_of_not_le _ _ h ht',
  have ht'' : 3/4 < 2*t - 1,
  { linarith },
  rw smooth_step.of_gt ht''
end

@[simp]
lemma htpy_jet_sec.comp_1 (𝓕 𝓖 : htpy_jet_sec E F) (h) : 𝓕.comp 𝓖 h 1 = 𝓖 1 :=
(𝓕.comp_ge_1 𝓖 h).on_set 1 left_mem_Ici

end htpy_jet_sec


/-
Copyright (c) 2020 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Markus Himmel, Scott Morrison
-/
import category_theory.limits.shapes.zero
import category_theory.limits.shapes.kernels
import category_theory.abelian.basic

/-!
# Simple objects

We define simple objects in any category with zero morphisms.
A simple object is an object `Y` such that any monomorphism `f : X ⟶ Y`
is either an isomorphism or zero (but not both).

This is formalized as a `Prop` valued typeclass `simple X`.

If a morphism `f` out of a simple object is nonzero and has a kernel, then that kernel is zero.
(We state this as `kernel.ι f = 0`, but should add `kernel f ≅ 0`.)

When the category is abelian, being simple is the same as being cosimple (although we do not
state a separate typeclass for this).
As a consequence, any nonzero epimorphism out of a simple object is an isomorphism,
and any nonzero morphism into a simple object has trivial cokernel.
-/

noncomputable theory

open category_theory.limits

namespace category_theory

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

section
variables [has_zero_morphisms C]

/-- An object is simple if monomorphisms into it are (exclusively) either isomorphisms or zero. -/
class simple (X : C) : Prop :=
(mono_is_iso_iff_nonzero : ∀ {Y : C} (f : Y ⟶ X) [mono f], is_iso f ↔ (f ≠ 0))

/-- A nonzero monomorphism to a simple object is an isomorphism. -/
lemma is_iso_of_mono_of_nonzero {X Y : C} [simple Y] {f : X ⟶ Y} [mono f] (w : f ≠ 0) :
  is_iso f :=
(simple.mono_is_iso_iff_nonzero f).mpr w

lemma kernel_zero_of_nonzero_from_simple
  {X Y : C} [simple X] {f : X ⟶ Y} [has_kernel f] (w : f ≠ 0) :
  kernel.ι f = 0 :=
begin
  classical,
  by_contradiction h,
  haveI := is_iso_of_mono_of_nonzero h,
  exact w (eq_zero_of_epi_kernel f),
end

lemma mono_to_simple_zero_of_not_iso
  {X Y : C} [simple Y] {f : X ⟶ Y} [mono f] (w : is_iso f → false) : f = 0 :=
begin
  classical,
  by_contradiction h,
  apply w,
  exact is_iso_of_mono_of_nonzero h,
end

lemma id_nonzero (X : C) [simple.{v} X] : 𝟙 X ≠ 0 :=
(simple.mono_is_iso_iff_nonzero (𝟙 X)).mp (by apply_instance)

instance (X : C) [simple.{v} X] : nontrivial (End X) :=
nontrivial_of_ne 1 0 (id_nonzero X)

section
variable [has_zero_object C]
local attribute [instance] has_zero_object.has_zero

/-- We don't want the definition of 'simple' to include the zero object, so we check that here. -/
lemma zero_not_simple [simple (0 : C)] : false :=
(simple.mono_is_iso_iff_nonzero (0 : (0 : C) ⟶ (0 : C))).mp ⟨⟨0, by tidy⟩⟩ rfl

end
end

-- We next make the dual arguments, but for this we must be in an abelian category.
section abelian
variables [abelian C]

/-- In an abelian category, an object satisfying the dual of the definition of a simple object is
    simple. -/
lemma simple_of_cosimple (X : C) (h : ∀ {Z : C} (f : X ⟶ Z) [epi f], is_iso f ↔ (f ≠ 0)) :
  simple X :=
⟨λ Y f I,
 begin
  classical,
  fsplit,
  { introsI,
    have hx := cokernel.π_of_epi f,
    by_contradiction h,
    push_neg at h,
    substI h,
    exact (h _).mp (cokernel.π_of_zero _ _) hx },
  { intro hf,
    suffices : epi f,
    { resetI, apply abelian.is_iso_of_mono_of_epi },
    apply preadditive.epi_of_cokernel_zero,
    by_contradiction h',
    exact cokernel_not_iso_of_nonzero hf ((h _).mpr h') }
 end⟩

/-- A nonzero epimorphism from a simple object is an isomorphism. -/
lemma is_iso_of_epi_of_nonzero {X Y : C} [simple X] {f : X ⟶ Y} [epi f] (w : f ≠ 0) :
  is_iso f :=
begin
  -- `f ≠ 0` means that `kernel.ι f` is not an iso, and hence zero, and hence `f` is a mono.
  haveI : mono f :=
    preadditive.mono_of_kernel_zero (mono_to_simple_zero_of_not_iso (kernel_not_iso_of_nonzero w)),
  exact abelian.is_iso_of_mono_of_epi f,
end

lemma cokernel_zero_of_nonzero_to_simple
  {X Y : C} [simple Y] {f : X ⟶ Y} [has_cokernel f] (w : f ≠ 0) :
  cokernel.π f = 0 :=
begin
  classical,
  by_contradiction h,
  haveI := is_iso_of_epi_of_nonzero h,
  exact w (eq_zero_of_mono_cokernel f),
end

lemma epi_from_simple_zero_of_not_iso
  {X Y : C} [simple X] {f : X ⟶ Y} [epi f] (w : is_iso f → false) : f = 0 :=
begin
  classical,
  by_contradiction h,
  apply w,
  exact is_iso_of_epi_of_nonzero h,
end

end abelian

end category_theory


import Monads.Functor
import Monads.Applicative
import Monads.Monad

namespace Monads
  inductive List (α : Type u) where
  | nil : List α
  | cons : α → List α → List α
    deriving Repr

  namespace List
    section Functor
      def map {α β : Type u} : (α → β) → (List α) → (List β)
      | f, nil => nil
      | f, (cons x xs) => cons (f x) (map f xs)

      #eval map (Nat.add 2) (cons 1 (cons 2 nil))

      theorem map_nil (f : α → β) : map f nil = nil := by rfl
      theorem map_cons (f : α → β) (x : α) (xs : List α) : map f (cons x xs) = cons (f x) (map f xs) := by rfl
      theorem map_id_eq_id {xs : List α} : map id xs = xs := by
        induction xs with
        | nil =>
          rw [map_nil]
        | cons x xs ih =>
          rw [map_cons]
          rw [ih]
          rw [id_eq]

      instance : Functor List where
        fmap := map

      theorem fmap_def (f : α → β) (xs : List α) : f <$> xs = map f xs := by rfl

      instance : LawfulFunctor List where
        fmap_id := by
          intro α xs
          induction xs with
          | nil =>
            rw [fmap_def, map_nil]
          | cons y ys ih =>
            rw [fmap_def, map_cons]
            rw [id_eq]
            rw [←fmap_def]
            rw [ih]
        fmap_comp := by
          intro α β γ g h xs
          induction xs with
          | nil =>
            rw [fmap_def, map_nil]
            rw [fmap_def g nil, map_nil]
            rw [fmap_def, map_nil]
          | cons y ys ih =>
            rw [fmap_def, map_cons]
            rw [fmap_def g, map_cons]
            rw [fmap_def, map_cons]
            rw [←fmap_def, ←fmap_def, ←fmap_def]
            rw [ih]
         map_const_behaved := by
           -- Still the default definition so the proof is automated
           intro α β x y
           simp only [Functor.map_const, Functor.fmap]
    end Functor

    section Applicative
      def append : List α → List α → List α
      | nil, ys => ys
      | (cons x xs), ys => cons x (append xs ys)

      instance {α : Type u} : Append (List α) where
        append := append

      #eval (cons 1 (cons 2 nil)) ++ (cons 3 (cons 4 nil))

      theorem nil_append (ys : List α) : nil ++ ys = ys := by rfl
      theorem cons_append (x : α) (xs : List α) (ys : List α) : (cons x xs) ++ ys = (cons x (xs ++ ys)) := by rfl
      theorem append_nil (xs : List α) : xs ++ nil = xs := by
        induction xs with
        | nil => rfl
        | cons x xs ih =>
          rw [cons_append]
          rw [ih]

      theorem append_assoc {xs ys zs : List α} : xs ++ ys ++ zs = xs ++ (ys ++ zs) := by
        induction xs with
        | nil =>
          rw [nil_append]
          rw [nil_append]
        | cons x xs ih =>
          rw [cons_append]
          rw [cons_append]
          rw [cons_append]
          rw [ih]

      theorem append_eq_of_suffix (as bs cs : List α) : (as = bs)  → (as ++ cs = bs ++ cs) := by
        intro h
        rw [h]

      def apply { α β : Type u} : List (α → β) → List α → List β
      | (cons f fs), xs => (f <$> xs) ++ (apply fs xs)
      | _, _ => nil

      instance : Applicative List where
        pure := λ x => (cons x nil)
        apply := apply

      theorem pure_def (x : α) : pure x = (cons x nil) := by rfl
      theorem apply_def {α β : Type u} (fs : List (α → β)) (xs : List α) : fs <*> xs = apply fs xs := by rfl
      theorem cons_apply {α β : Type u} (f : α → β) (fs : List (α → β)) (xs : List α) : (cons f fs) <*> xs = (f <$> xs) ++ (fs <*> xs) := by rfl
      theorem apply_nil {α β : Type u} (fs : List (α → β)) : fs <*> nil = nil := by
        induction fs with
        | nil => rfl
        | cons f fs ih =>
          rw [cons_apply]
          rw [ih]
          rw [append_nil]
          rw [fmap_def, map_nil]

      theorem nil_apply {α β: Type u} (xs : List α) : @nil (α → β) <*> xs = nil := by rfl

      #eval Nat.add <$> (cons 1 (cons 2 nil)) <*> (cons 3 (cons 4 nil))

      instance : LawfulApplicative List where
        apply_id := by
          intro α x
          rw [pure_def]
          rw [cons_apply]
          rw [nil_apply]
          rw [append_nil]
          rw [fmap_def, map_id_eq_id]
        apply_homomorphism := by
          intro α β x g
          rw [pure_def, pure_def, pure_def]
          rw [cons_apply]
          rw [nil_apply]
          rw [append_nil]
          rw [fmap_def, map_cons]
          rw [map_nil]
        apply_interchange := by
          intro α β x g
          rw [pure_def, pure_def]
          rw [cons_apply]
          rw [nil_apply]
          rw [append_nil]
          induction g with
          | nil =>
            rw [nil_apply]
            rw [fmap_def, map_nil]
          | cons g gs ih =>
            rw [cons_apply]
            rw [fmap_def, map_cons]
            rw [map_nil]
            rw [fmap_def, map_cons]
            rw [cons_append]
            rw [nil_append]
            rw [←fmap_def]
            rw [ih]
        apply_comp := sorry
        lifta2_behaved := by
          -- Definition wasn't changed -> auto proof
          intro α β γ g x y
          simp only [Applicative.liftA2, Applicative.apply]
        seq_right_behaved := by
          -- Definition wasn't changed -> auto proof
          intro α β a1 a2
          simp only [Applicative.seq_right, Applicative.apply]
        seq_left_behaved := by
          -- Definition wasn't changed -> auto proof
          intro α β a1 a2
          simp only [Applicative.seq_left, Applicative.liftA2]
        fmap_eq_pure_apply := by
          intro α β g x
          rw [pure_def]
          rw [cons_apply]
          rw [nil_apply]
          rw [append_nil]
    end Applicative

    section Monad
      def flatten : List (List α) → List α
      | nil => nil
      | (cons xs xss) => xs ++ flatten xss

      theorem flatten_nil : flatten nil = @nil α := by rfl
      theorem flatten_cons (xs : List α) (xss : List (List α)) : flatten (cons xs xss) = xs ++ flatten xss := by rfl

      def flat_map : List α → (α → List β) → List β
      | xs, f => flatten $ map f xs

      theorem flat_map_def (xs : List α) (f : α → List β) : flat_map xs f = (flatten $ map f xs) := by rfl
      theorem flat_map_nil (f : α → List β) : flat_map nil f = nil := by rfl
      theorem flat_map_cons (x : α) (xs : List α) (f : α → List β) : flat_map (cons x xs) f = (f x) ++ flat_map xs f := by
        rw [flat_map_def]
        rw [map_cons]
        rw [flatten_cons]
        rw [←flat_map_def]

      theorem flat_map_distrib_append {xs ys : List α} {f : α → List β} : flat_map (xs ++ ys) f = flat_map xs f ++ flat_map ys f := by
        induction xs with
        | nil =>
          rw [nil_append]
          rw [flat_map_nil]
          rw [nil_append]
        | cons x xs ih =>
          rw [cons_append]
          rw [flat_map_cons]
          rw [flat_map_cons]
          rw [ih]
          rw [append_assoc]
      theorem map_eq_constant_flat_map {α β : Type u} (f : α → β) (as : List α) : (map f as) = (flat_map as fun a => cons (f a) nil) := by
        induction as with
        | nil =>
          rw [map_nil]
          rw [flat_map_nil]
        | cons a as ih =>
          rw [map_cons]
          rw [flat_map_cons]
          rw [cons_append]
          rw [nil_append]
          rw [ih]

      instance : Monad List where
        ret := λ x => (cons x nil)
        bind := flat_map

      theorem ret_def (x : α) : ret x = cons x nil := by rfl
      theorem bind_def (xs : List α) (f : α → List β) : xs >>= f = flat_map xs f := by rfl

      #eval (cons 1 (cons 2 nil)) >>= (λ x => (cons x (cons x nil)))

      instance : LawfulMonad List where
        ret_left_id := by
          intro α β a h
          rw [ret_def]
          rw [bind_def, flat_map_def]
          rw [map_cons]
          rw [map_nil]
          rw [flatten_cons]
          rw [flatten_nil, append_nil]
        ret_right_id := by
          intro α as
          rw [bind_def]
          induction as with
          | nil =>
            rw [flat_map_nil]
          | cons a as ih =>
            rw [flat_map_cons]
            rw [ih]
            rw [ret_def]
            rw [cons_append]
            rw [nil_append]
        bind_assoc := by
          intro α β γ as g h
          induction as with
          | nil =>
            rw [bind_def nil, flat_map_nil]
            rw [bind_def nil, flat_map_nil]
            rw [bind_def nil, flat_map_nil]
          | cons x xs ih =>
            rw [bind_def (cons x xs), flat_map_cons]
            rw [bind_def (cons x xs), flat_map_cons]
            rw [←bind_def]
            rw [←bind_def]
            rw [←ih]
            rw [bind_def _ h]
            rw [flat_map_distrib_append]
            rw [←bind_def]
            rw [←bind_def]
        pure_behaved := by
          intro α a
          rw [pure_def, ret_def]
        apply_behaved := by
          intro α β mf ma
          induction mf with
          | nil =>
            rw [nil_apply]
            rw [bind_def, flat_map_nil]
          | cons f fs fih =>
            rw [cons_apply]
            rw [bind_def, flat_map_cons]
            rw [←bind_def]
            induction ma with
            | nil =>
              rw [fmap_def, map_nil]
              rw [nil_append]
              rw [apply_nil]
              rw [bind_def, flat_map_nil]
              rw [nil_append]
              rw [←fih]
              rw [apply_nil]
            | cons a as aih =>
              rw [←fih]
              rw [bind_def, flat_map_cons]
              rw [ret_def]
              rw [cons_append]
              rw [nil_append]
              rw [fmap_def, map_cons]
              rw [map_eq_constant_flat_map]
              -- we have to rewrite inside a function which is easier with simp only
              simp only [ret_def]
        and_then_behaved := by
          intro α β a1 a2
          simp only [Monad.and_then, Applicative.seq_right]
          induction a1 with
          | nil =>
            simp only [Functor.map_const]
            simp only [Function.comp]
            rw [map_nil]
            rw [←apply_def, nil_apply]
            rw [flat_map_nil]
          | cons x xs xih =>
            rw [flat_map_cons]
            simp only [Function.const]
            simp only [Functor.map_const]
            simp only [Function.comp]
            rw [map_cons]
            simp only [Function.const]
            rw [←apply_def, cons_apply]
            rw [fmap_def, map_id_eq_id]
            rw [←xih]
            simp only [Functor.map_const]
            simp only [Function.comp]
            simp only [Function.const]
            rw [←apply_def]
    end Monad
  end List
end Monads


/-
Copyright (c) 2020 Johan Commelin. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Johan Commelin
-/
import algebra.group.inj_surj
import algebra.group_with_zero.defs

/-!
# Lifting groups with zero along injective/surjective maps

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

open function

variables {M₀ G₀ M₀' G₀' : Type*}

section mul_zero_class

variables [mul_zero_class M₀] {a b : M₀}

/-- Pullback a `mul_zero_class` instance along an injective function.
See note [reducible non-instances]. -/
@[reducible]
protected def function.injective.mul_zero_class [has_mul M₀'] [has_zero M₀'] (f : M₀' → M₀)
  (hf : injective f) (zero : f 0 = 0) (mul : ∀ a b, f (a * b) = f a * f b) :
  mul_zero_class M₀' :=
{ mul := (*),
  zero := 0,
  zero_mul := λ a, hf $ by simp only [mul, zero, zero_mul],
  mul_zero := λ a, hf $ by simp only [mul, zero, mul_zero] }

/-- Pushforward a `mul_zero_class` instance along an surjective function.
See note [reducible non-instances]. -/
@[reducible]
protected def function.surjective.mul_zero_class [has_mul M₀'] [has_zero M₀'] (f : M₀ → M₀')
  (hf : surjective f) (zero : f 0 = 0) (mul : ∀ a b, f (a * b) = f a * f b) :
  mul_zero_class M₀' :=
{ mul := (*),
  zero := 0,
  mul_zero := hf.forall.2 $ λ x, by simp only [← zero, ← mul, mul_zero],
  zero_mul := hf.forall.2 $ λ x, by simp only [← zero, ← mul, zero_mul] }

end mul_zero_class

section no_zero_divisors

/-- Pushforward a `no_zero_divisors` instance along an injective function. -/
protected lemma function.injective.no_zero_divisors [has_mul M₀] [has_zero M₀]
  [has_mul M₀'] [has_zero M₀'] [no_zero_divisors M₀']
  (f : M₀ → M₀') (hf : injective f) (zero : f 0 = 0) (mul : ∀ x y, f (x * y) = f x * f y) :
  no_zero_divisors M₀ :=
{ eq_zero_or_eq_zero_of_mul_eq_zero := λ x y H,
  have f x * f y = 0, by rw [← mul, H, zero],
  (eq_zero_or_eq_zero_of_mul_eq_zero this).imp (λ H, hf $ by rwa zero)  (λ H, hf $ by rwa zero) }

end no_zero_divisors

section mul_zero_one_class

variables [mul_zero_one_class M₀]

/-- Pullback a `mul_zero_one_class` instance along an injective function.
See note [reducible non-instances]. -/
@[reducible]
protected def function.injective.mul_zero_one_class [has_mul M₀'] [has_zero M₀'] [has_one M₀']
  (f : M₀' → M₀)
  (hf : injective f) (zero : f 0 = 0) (one : f 1 = 1) (mul : ∀ a b, f (a * b) = f a * f b) :
  mul_zero_one_class M₀' :=
{ ..hf.mul_zero_class f zero mul, ..hf.mul_one_class f one mul }

/-- Pushforward a `mul_zero_one_class` instance along an surjective function.
See note [reducible non-instances]. -/
@[reducible]
protected def function.surjective.mul_zero_one_class [has_mul M₀'] [has_zero M₀'] [has_one M₀']
  (f : M₀ → M₀')
  (hf : surjective f) (zero : f 0 = 0) (one : f 1 = 1) (mul : ∀ a b, f (a * b) = f a * f b) :
  mul_zero_one_class M₀' :=
{ ..hf.mul_zero_class f zero mul, ..hf.mul_one_class f one mul }

end mul_zero_one_class

section semigroup_with_zero

/-- Pullback a `semigroup_with_zero` class along an injective function.
See note [reducible non-instances]. -/
@[reducible]
protected def function.injective.semigroup_with_zero
  [has_zero M₀'] [has_mul M₀'] [semigroup_with_zero M₀] (f : M₀' → M₀) (hf : injective f)
  (zero : f 0 = 0) (mul : ∀ x y, f (x * y) = f x * f y) :
  semigroup_with_zero M₀' :=
{ .. hf.mul_zero_class f zero mul,
  .. ‹has_zero M₀'›,
  .. hf.semigroup f mul }

/-- Pushforward a `semigroup_with_zero` class along an surjective function.
See note [reducible non-instances]. -/
@[reducible]
protected def function.surjective.semigroup_with_zero
  [semigroup_with_zero M₀] [has_zero M₀'] [has_mul M₀'] (f : M₀ → M₀') (hf : surjective f)
  (zero : f 0 = 0) (mul : ∀ x y, f (x * y) = f x * f y) :
  semigroup_with_zero M₀' :=
{ .. hf.mul_zero_class f zero mul,
  .. ‹has_zero M₀'›,
  .. hf.semigroup f mul }

end semigroup_with_zero

section monoid_with_zero

/-- Pullback a `monoid_with_zero` class along an injective function.
See note [reducible non-instances]. -/
@[reducible]
protected def function.injective.monoid_with_zero [has_zero M₀'] [has_mul M₀'] [has_one M₀']
  [has_pow M₀' ℕ] [monoid_with_zero M₀]
  (f : M₀' → M₀) (hf : injective f) (zero : f 0 = 0) (one : f 1 = 1)
  (mul : ∀ x y, f (x * y) = f x * f y) (npow : ∀ x (n : ℕ), f (x ^ n) = f x ^ n) :
  monoid_with_zero M₀' :=
{ .. hf.monoid f one mul npow, .. hf.mul_zero_class f zero mul }

/-- Pushforward a `monoid_with_zero` class along a surjective function.
See note [reducible non-instances]. -/
@[reducible]
protected def function.surjective.monoid_with_zero [has_zero M₀'] [has_mul M₀'] [has_one M₀']
  [has_pow M₀' ℕ] [monoid_with_zero M₀]
  (f : M₀ → M₀') (hf : surjective f) (zero : f 0 = 0) (one : f 1 = 1)
  (mul : ∀ x y, f (x * y) = f x * f y) (npow : ∀ x (n : ℕ), f (x ^ n) = f x ^ n) :
  monoid_with_zero M₀' :=
{ .. hf.monoid f one mul npow, .. hf.mul_zero_class f zero mul }

/-- Pullback a `monoid_with_zero` class along an injective function.
See note [reducible non-instances]. -/
@[reducible]
protected def function.injective.comm_monoid_with_zero [has_zero M₀'] [has_mul M₀'] [has_one M₀']
  [has_pow M₀' ℕ] [comm_monoid_with_zero M₀]
  (f : M₀' → M₀) (hf : injective f) (zero : f 0 = 0) (one : f 1 = 1)
  (mul : ∀ x y, f (x * y) = f x * f y) (npow : ∀ x (n : ℕ), f (x ^ n) = f x ^ n) :
  comm_monoid_with_zero M₀' :=
{ .. hf.comm_monoid f one mul npow, .. hf.mul_zero_class f zero mul }

/-- Pushforward a `monoid_with_zero` class along a surjective function.
See note [reducible non-instances]. -/
@[reducible]
protected def function.surjective.comm_monoid_with_zero [has_zero M₀'] [has_mul M₀'] [has_one M₀']
  [has_pow M₀' ℕ] [comm_monoid_with_zero M₀]
  (f : M₀ → M₀') (hf : surjective f) (zero : f 0 = 0) (one : f 1 = 1)
  (mul : ∀ x y, f (x * y) = f x * f y) (npow : ∀ x (n : ℕ), f (x ^ n) = f x ^ n) :
  comm_monoid_with_zero M₀' :=
{ .. hf.comm_monoid f one mul npow, .. hf.mul_zero_class f zero mul }

end monoid_with_zero

section cancel_monoid_with_zero

variables [cancel_monoid_with_zero M₀] {a b c : M₀}

/-- Pullback a `monoid_with_zero` class along an injective function.
See note [reducible non-instances]. -/
@[reducible]
protected def function.injective.cancel_monoid_with_zero [has_zero M₀'] [has_mul M₀'] [has_one M₀']
  [has_pow M₀' ℕ] (f : M₀' → M₀) (hf : injective f) (zero : f 0 = 0) (one : f 1 = 1)
  (mul : ∀ x y, f (x * y) = f x * f y) (npow : ∀ x (n : ℕ), f (x ^ n) = f x ^ n) :
  cancel_monoid_with_zero M₀' :=
{ mul_left_cancel_of_ne_zero := λ x y z hx H, hf $ mul_left_cancel₀ ((hf.ne_iff' zero).2 hx) $
    by erw [← mul, ← mul, H]; refl,
  mul_right_cancel_of_ne_zero := λ x y z hx H, hf $ mul_right_cancel₀ ((hf.ne_iff' zero).2 hx) $
    by erw [← mul, ← mul, H]; refl,
  .. hf.monoid f one mul npow, .. hf.mul_zero_class f zero mul }

end cancel_monoid_with_zero

section cancel_comm_monoid_with_zero

variables [cancel_comm_monoid_with_zero M₀] {a b c : M₀}

/-- Pullback a `cancel_comm_monoid_with_zero` class along an injective function.
See note [reducible non-instances]. -/
@[reducible]
protected def function.injective.cancel_comm_monoid_with_zero
  [has_zero M₀'] [has_mul M₀'] [has_one M₀'] [has_pow M₀' ℕ]
  (f : M₀' → M₀) (hf : injective f) (zero : f 0 = 0) (one : f 1 = 1)
  (mul : ∀ x y, f (x * y) = f x * f y) (npow : ∀ x (n : ℕ), f (x ^ n) = f x ^ n) :
  cancel_comm_monoid_with_zero M₀' :=
{ .. hf.comm_monoid_with_zero f zero one mul npow,
  .. hf.cancel_monoid_with_zero f zero one mul npow }

end cancel_comm_monoid_with_zero

section group_with_zero
variables [group_with_zero G₀] {a b c g h x : G₀}

/-- Pullback a `group_with_zero` class along an injective function.
See note [reducible non-instances]. -/
@[reducible]
protected def function.injective.group_with_zero [has_zero G₀'] [has_mul G₀'] [has_one G₀']
  [has_inv G₀'] [has_div G₀'] [has_pow G₀' ℕ] [has_pow G₀' ℤ]
  (f : G₀' → G₀) (hf : injective f) (zero : f 0 = 0) (one : f 1 = 1)
  (mul : ∀ x y, f (x * y) = f x * f y) (inv : ∀ x, f x⁻¹ = (f x)⁻¹)
  (div : ∀ x y, f (x / y) = f x / f y) (npow : ∀ x (n : ℕ), f (x ^ n) = f x ^ n)
  (zpow : ∀ x (n : ℤ), f (x ^ n) = f x ^ n) :
  group_with_zero G₀' :=
{ inv_zero := hf $ by erw [inv, zero, inv_zero],
  mul_inv_cancel := λ x hx, hf $ by erw [one, mul, inv, mul_inv_cancel ((hf.ne_iff' zero).2 hx)],
  .. hf.monoid_with_zero f zero one mul npow,
  .. hf.div_inv_monoid f one mul inv div npow zpow,
  .. pullback_nonzero f zero one, }

/-- Pushforward a `group_with_zero` class along an surjective function.
See note [reducible non-instances]. -/
@[reducible]
protected def function.surjective.group_with_zero [has_zero G₀'] [has_mul G₀'] [has_one G₀']
  [has_inv G₀'] [has_div G₀'] [has_pow G₀' ℕ] [has_pow G₀' ℤ]
  (h01 : (0:G₀') ≠ 1) (f : G₀ → G₀') (hf : surjective f)
  (zero : f 0 = 0) (one : f 1 = 1) (mul : ∀ x y, f (x * y) = f x * f y)
  (inv : ∀ x, f x⁻¹ = (f x)⁻¹) (div : ∀ x y, f (x / y) = f x / f y)
  (npow : ∀ x (n : ℕ), f (x ^ n) = f x ^ n) (zpow : ∀ x (n : ℤ), f (x ^ n) = f x ^ n):
  group_with_zero G₀' :=
{ inv_zero := by erw [← zero, ← inv, inv_zero],
  mul_inv_cancel := hf.forall.2 $ λ x hx,
    by erw [← inv, ← mul, mul_inv_cancel (mt (congr_arg f) $ trans_rel_left ne hx zero.symm)];
      exact one,
  exists_pair_ne := ⟨0, 1, h01⟩,
  .. hf.monoid_with_zero f zero one mul npow,
  .. hf.div_inv_monoid f one mul inv div npow zpow }

end group_with_zero

section comm_group_with_zero
variables [comm_group_with_zero G₀] {a b c d : G₀}

/-- Pullback a `comm_group_with_zero` class along an injective function.
See note [reducible non-instances]. -/
@[reducible]
protected def function.injective.comm_group_with_zero [has_zero G₀'] [has_mul G₀'] [has_one G₀']
  [has_inv G₀'] [has_div G₀'] [has_pow G₀' ℕ] [has_pow G₀' ℤ]
  (f : G₀' → G₀) (hf : injective f) (zero : f 0 = 0) (one : f 1 = 1)
  (mul : ∀ x y, f (x * y) = f x * f y) (inv : ∀ x, f x⁻¹ = (f x)⁻¹)
  (div : ∀ x y, f (x / y) = f x / f y) (npow : ∀ x (n : ℕ), f (x ^ n) = f x ^ n)
  (zpow : ∀ x (n : ℤ), f (x ^ n) = f x ^ n) :
  comm_group_with_zero G₀' :=
{ .. hf.group_with_zero f zero one mul inv div npow zpow, .. hf.comm_semigroup f mul }

/-- Pushforward a `comm_group_with_zero` class along a surjective function. -/
protected def function.surjective.comm_group_with_zero [has_zero G₀'] [has_mul G₀']
  [has_one G₀'] [has_inv G₀'] [has_div G₀'] [has_pow G₀' ℕ] [has_pow G₀' ℤ]
  (h01 : (0:G₀') ≠ 1) (f : G₀ → G₀') (hf : surjective f)
  (zero : f 0 = 0) (one : f 1 = 1) (mul : ∀ x y, f (x * y) = f x * f y) (inv : ∀ x, f x⁻¹ = (f x)⁻¹)
  (div : ∀ x y, f (x / y) = f x / f y) (npow : ∀ x (n : ℕ), f (x ^ n) = f x ^ n)
  (zpow : ∀ x (n : ℤ), f (x ^ n) = f x ^ n) :
  comm_group_with_zero G₀' :=
{ .. hf.group_with_zero h01 f zero one mul inv div npow zpow, .. hf.comm_semigroup f mul }

end comm_group_with_zero


import order.filter.basic

namespace filter

lemma eventually.choice {α β : Type*} {r : α → β → Prop} {l : filter α}
  [l.ne_bot] (h : ∀ᶠ x in l, ∃ y, r x y) : ∃ f : α → β, ∀ᶠ x in l, r x (f x) :=
begin
  classical,
  use (λ x, if hx : ∃ y, r x y then classical.some hx
            else classical.some (classical.some_spec h.exists)),
  filter_upwards [h],
  intros x hx,
  rw dif_pos hx,
  exact classical.some_spec hx
end

end filter


/-
Copyright (c) 2018 Chris Hughes. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Chris Hughes, Johannes Hölzl, Scott Morrison, Jens Wagemaker
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.data.polynomial.ring_division
import Mathlib.data.polynomial.derivative
import Mathlib.algebra.gcd_monoid
import Mathlib.PostPort

universes u y v u_1

namespace Mathlib

/-!
# Theory of univariate polynomials

This file starts looking like the ring theory of $ R[X] $

-/

namespace polynomial

protected instance normalization_monoid {R : Type u} [integral_domain R] [normalization_monoid R] : normalization_monoid (polynomial R) :=
  normalization_monoid.mk
    (fun (p : polynomial R) =>
      units.mk (coe_fn C ↑(norm_unit (leading_coeff p))) (coe_fn C ↑(norm_unit (leading_coeff p)⁻¹)) sorry sorry)
    sorry sorry sorry

@[simp] theorem coe_norm_unit {R : Type u} [integral_domain R] [normalization_monoid R] {p : polynomial R} : ↑(norm_unit p) = coe_fn C ↑(norm_unit (leading_coeff p)) := sorry

theorem leading_coeff_normalize {R : Type u} [integral_domain R] [normalization_monoid R] (p : polynomial R) : leading_coeff (coe_fn normalize p) = coe_fn normalize (leading_coeff p) := sorry

theorem is_unit_iff_degree_eq_zero {R : Type u} [field R] {p : polynomial R} : is_unit p ↔ degree p = 0 := sorry

theorem degree_pos_of_ne_zero_of_nonunit {R : Type u} [field R] {p : polynomial R} (hp0 : p ≠ 0) (hp : ¬is_unit p) : 0 < degree p := sorry

theorem monic_mul_leading_coeff_inv {R : Type u} [field R] {p : polynomial R} (h : p ≠ 0) : monic (p * coe_fn C (leading_coeff p⁻¹)) := sorry

theorem degree_mul_leading_coeff_inv {R : Type u} [field R] {q : polynomial R} (p : polynomial R) (h : q ≠ 0) : degree (p * coe_fn C (leading_coeff q⁻¹)) = degree p := sorry

theorem irreducible_of_monic {R : Type u} [field R] {p : polynomial R} (hp1 : monic p) (hp2 : p ≠ 1) : irreducible p ↔ ∀ (f g : polynomial R), monic f → monic g → f * g = p → f = 1 ∨ g = 1 := sorry

/-- Division of polynomials. See polynomial.div_by_monic for more details.-/
def div {R : Type u} [field R] (p : polynomial R) (q : polynomial R) : polynomial R :=
  coe_fn C (leading_coeff q⁻¹) * (p /ₘ (q * coe_fn C (leading_coeff q⁻¹)))

/-- Remainder of polynomial division, see the lemma `quotient_mul_add_remainder_eq_aux`.
See polynomial.mod_by_monic for more details. -/
def mod {R : Type u} [field R] (p : polynomial R) (q : polynomial R) : polynomial R :=
  p %ₘ (q * coe_fn C (leading_coeff q⁻¹))

protected instance has_div {R : Type u} [field R] : Div (polynomial R) :=
  { div := div }

protected instance has_mod {R : Type u} [field R] : Mod (polynomial R) :=
  { mod := mod }

theorem div_def {R : Type u} [field R] {p : polynomial R} {q : polynomial R} : p / q = coe_fn C (leading_coeff q⁻¹) * (p /ₘ (q * coe_fn C (leading_coeff q⁻¹))) :=
  rfl

theorem mod_def {R : Type u} [field R] {p : polynomial R} {q : polynomial R} : p % q = p %ₘ (q * coe_fn C (leading_coeff q⁻¹)) :=
  rfl

theorem mod_by_monic_eq_mod {R : Type u} [field R] {q : polynomial R} (p : polynomial R) (hq : monic q) : p %ₘ q = p % q := sorry

theorem div_by_monic_eq_div {R : Type u} [field R] {q : polynomial R} (p : polynomial R) (hq : monic q) : p /ₘ q = p / q := sorry

theorem mod_X_sub_C_eq_C_eval {R : Type u} [field R] (p : polynomial R) (a : R) : p % (X - coe_fn C a) = coe_fn C (eval a p) :=
  mod_by_monic_eq_mod p (monic_X_sub_C a) ▸ mod_by_monic_X_sub_C_eq_C_eval p a

theorem mul_div_eq_iff_is_root {R : Type u} {a : R} [field R] {p : polynomial R} : (X - coe_fn C a) * (p / (X - coe_fn C a)) = p ↔ is_root p a :=
  div_by_monic_eq_div p (monic_X_sub_C a) ▸ mul_div_by_monic_eq_iff_is_root

protected instance euclidean_domain {R : Type u} [field R] : euclidean_domain (polynomial R) :=
  euclidean_domain.mk comm_ring.add sorry comm_ring.zero sorry sorry comm_ring.neg comm_ring.sub sorry sorry comm_ring.mul
    sorry comm_ring.one sorry sorry sorry sorry sorry sorry Div.div sorry Mod.mod quotient_mul_add_remainder_eq_aux
    (fun (p q : polynomial R) => degree p < degree q) sorry sorry sorry

theorem mod_eq_self_iff {R : Type u} [field R] {p : polynomial R} {q : polynomial R} (hq0 : q ≠ 0) : p % q = p ↔ degree p < degree q := sorry

theorem div_eq_zero_iff {R : Type u} [field R] {p : polynomial R} {q : polynomial R} (hq0 : q ≠ 0) : p / q = 0 ↔ degree p < degree q := sorry

theorem degree_add_div {R : Type u} [field R] {p : polynomial R} {q : polynomial R} (hq0 : q ≠ 0) (hpq : degree q ≤ degree p) : degree q + degree (p / q) = degree p := sorry

theorem degree_div_le {R : Type u} [field R] (p : polynomial R) (q : polynomial R) : degree (p / q) ≤ degree p := sorry

theorem degree_div_lt {R : Type u} [field R] {p : polynomial R} {q : polynomial R} (hp : p ≠ 0) (hq : 0 < degree q) : degree (p / q) < degree p := sorry

@[simp] theorem degree_map {R : Type u} {k : Type y} [field R] [field k] (p : polynomial R) (f : R →+* k) : degree (map f p) = degree p :=
  degree_map_eq_of_injective (ring_hom.injective f) p

@[simp] theorem nat_degree_map {R : Type u} {k : Type y} [field R] {p : polynomial R} [field k] (f : R →+* k) : nat_degree (map f p) = nat_degree p :=
  nat_degree_eq_of_degree_eq (degree_map p f)

@[simp] theorem leading_coeff_map {R : Type u} {k : Type y} [field R] {p : polynomial R} [field k] (f : R →+* k) : leading_coeff (map f p) = coe_fn f (leading_coeff p) := sorry

theorem monic_map_iff {R : Type u} {k : Type y} [field R] [field k] {f : R →+* k} {p : polynomial R} : monic (map f p) ↔ monic p := sorry

theorem is_unit_map {R : Type u} {k : Type y} [field R] {p : polynomial R} [field k] (f : R →+* k) : is_unit (map f p) ↔ is_unit p := sorry

theorem map_div {R : Type u} {k : Type y} [field R] {p : polynomial R} {q : polynomial R} [field k] (f : R →+* k) : map f (p / q) = map f p / map f q := sorry

theorem map_mod {R : Type u} {k : Type y} [field R] {p : polynomial R} {q : polynomial R} [field k] (f : R →+* k) : map f (p % q) = map f p % map f q := sorry

theorem gcd_map {R : Type u} {k : Type y} [field R] {p : polynomial R} {q : polynomial R} [field k] (f : R →+* k) : euclidean_domain.gcd (map f p) (map f q) = map f (euclidean_domain.gcd p q) := sorry

theorem eval₂_gcd_eq_zero {R : Type u} {k : Type y} [field R] [comm_semiring k] {ϕ : R →+* k} {f : polynomial R} {g : polynomial R} {α : k} (hf : eval₂ ϕ α f = 0) (hg : eval₂ ϕ α g = 0) : eval₂ ϕ α (euclidean_domain.gcd f g) = 0 := sorry

theorem eval_gcd_eq_zero {R : Type u} [field R] {f : polynomial R} {g : polynomial R} {α : R} (hf : eval α f = 0) (hg : eval α g = 0) : eval α (euclidean_domain.gcd f g) = 0 :=
  eval₂_gcd_eq_zero hf hg

theorem root_left_of_root_gcd {R : Type u} {k : Type y} [field R] [comm_semiring k] {ϕ : R →+* k} {f : polynomial R} {g : polynomial R} {α : k} (hα : eval₂ ϕ α (euclidean_domain.gcd f g) = 0) : eval₂ ϕ α f = 0 := sorry

theorem root_right_of_root_gcd {R : Type u} {k : Type y} [field R] [comm_semiring k] {ϕ : R →+* k} {f : polynomial R} {g : polynomial R} {α : k} (hα : eval₂ ϕ α (euclidean_domain.gcd f g) = 0) : eval₂ ϕ α g = 0 := sorry

theorem root_gcd_iff_root_left_right {R : Type u} {k : Type y} [field R] [comm_semiring k] {ϕ : R →+* k} {f : polynomial R} {g : polynomial R} {α : k} : eval₂ ϕ α (euclidean_domain.gcd f g) = 0 ↔ eval₂ ϕ α f = 0 ∧ eval₂ ϕ α g = 0 := sorry

theorem is_root_gcd_iff_is_root_left_right {R : Type u} [field R] {f : polynomial R} {g : polynomial R} {α : R} : is_root (euclidean_domain.gcd f g) α ↔ is_root f α ∧ is_root g α :=
  root_gcd_iff_root_left_right

theorem is_coprime_map {R : Type u} {k : Type y} [field R] {p : polynomial R} {q : polynomial R} [field k] (f : R →+* k) : is_coprime (map f p) (map f q) ↔ is_coprime p q := sorry

@[simp] theorem map_eq_zero {R : Type u} {S : Type v} [field R] {p : polynomial R} [semiring S] [nontrivial S] (f : R →+* S) : map f p = 0 ↔ p = 0 := sorry

theorem map_ne_zero {R : Type u} {S : Type v} [field R] {p : polynomial R} [semiring S] [nontrivial S] {f : R →+* S} (hp : p ≠ 0) : map f p ≠ 0 :=
  mt (iff.mp (map_eq_zero f)) hp

theorem mem_roots_map {R : Type u} {k : Type y} [field R] {p : polynomial R} [field k] {f : R →+* k} {x : k} (hp : p ≠ 0) : x ∈ roots (map f p) ↔ eval₂ f x p = 0 := sorry

theorem exists_root_of_degree_eq_one {R : Type u} [field R] {p : polynomial R} (h : degree p = 1) : ∃ (x : R), is_root p x := sorry

theorem coeff_inv_units {R : Type u} [field R] (u : units (polynomial R)) (n : ℕ) : coeff (↑u) n⁻¹ = coeff (↑(u⁻¹)) n := sorry

theorem monic_normalize {R : Type u} [field R] {p : polynomial R} (hp0 : p ≠ 0) : monic (coe_fn normalize p) := sorry

theorem coe_norm_unit_of_ne_zero {R : Type u} [field R] {p : polynomial R} (hp : p ≠ 0) : ↑(norm_unit p) = coe_fn C (leading_coeff p⁻¹) := sorry

theorem normalize_monic {R : Type u} [field R] {p : polynomial R} (h : monic p) : coe_fn normalize p = p := sorry

theorem map_dvd_map' {R : Type u} {k : Type y} [field R] [field k] (f : R →+* k) {x : polynomial R} {y : polynomial R} : map f x ∣ map f y ↔ x ∣ y := sorry

theorem degree_normalize {R : Type u} [field R] {p : polynomial R} : degree (coe_fn normalize p) = degree p := sorry

theorem prime_of_degree_eq_one {R : Type u} [field R] {p : polynomial R} (hp1 : degree p = 1) : prime p := sorry

theorem irreducible_of_degree_eq_one {R : Type u} [field R] {p : polynomial R} (hp1 : degree p = 1) : irreducible p :=
  irreducible_of_prime (prime_of_degree_eq_one hp1)

theorem not_irreducible_C {R : Type u} [field R] (x : R) : ¬irreducible (coe_fn C x) := sorry

theorem degree_pos_of_irreducible {R : Type u} [field R] {p : polynomial R} (hp : irreducible p) : 0 < degree p :=
  lt_of_not_ge
    fun (hp0 : 0 ≥ degree p) =>
      (fun (this : p = coe_fn C (coeff p 0)) => not_irreducible_C (coeff p 0) (this ▸ hp)) (eq_C_of_degree_le_zero hp0)

theorem pairwise_coprime_X_sub {α : Type u} [field α] {I : Type v} {s : I → α} (H : function.injective s) : pairwise (is_coprime on fun (i : I) => X - coe_fn C (s i)) := sorry

/-- If `f` is a polynomial over a field, and `a : K` satisfies `f' a ≠ 0`,
then `f / (X - a)` is coprime with `X - a`.
Note that we do not assume `f a = 0`, because `f / (X - a) = (f - f a) / (X - a)`. -/
theorem is_coprime_of_is_root_of_eval_derivative_ne_zero {K : Type u_1} [field K] (f : polynomial K) (a : K) (hf' : eval a (coe_fn derivative f) ≠ 0) : is_coprime (X - coe_fn C a) (f /ₘ (X - coe_fn C a)) := sorry

theorem prod_multiset_root_eq_finset_root {R : Type u} [field R] {p : polynomial R} (hzero : p ≠ 0) : multiset.prod (multiset.map (fun (a : R) => X - coe_fn C a) (roots p)) =
  finset.prod (multiset.to_finset (roots p)) fun (a : R) => (fun (a : R) => (X - coe_fn C a) ^ root_multiplicity a p) a := sorry

/-- The product `∏ (X - a)` for `a` inside the multiset `p.roots` divides `p`. -/
theorem prod_multiset_X_sub_C_dvd {R : Type u} [field R] (p : polynomial R) : multiset.prod (multiset.map (fun (a : R) => X - coe_fn C a) (roots p)) ∣ p := sorry

theorem roots_C_mul {R : Type u} [field R] (p : polynomial R) {a : R} (hzero : a ≠ 0) : roots (coe_fn C a * p) = roots p := sorry

theorem roots_normalize {R : Type u} [field R] {p : polynomial R} : roots (coe_fn normalize p) = roots p := sorry


/-
Copyright (c) 2018 Kenny Lau. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Kenny Lau, Yury Kudryashov
-/
import algebra.module.basic
import linear_algebra.basic
import tactic.abel
import data.equiv.ring_aut

/-!
# Algebras over commutative semirings

In this file we define `algebra`s over commutative (semi)rings, algebra homomorphisms `alg_hom`,
and algebra equivalences `alg_equiv`.
We also define the usual operations on `alg_hom`s (`id`, `comp`).

`subalgebra`s are defined in `algebra.algebra.subalgebra`.

If `S` is an `R`-algebra and `A` is an `S`-algebra then `algebra.comap.algebra R S A` can be used
to provide `A` with a structure of an `R`-algebra. Other than that, `algebra.comap` is now
deprecated and replaced with `is_scalar_tower`.

For the category of `R`-algebras, denoted `Algebra R`, see the file
`algebra/category/Algebra/basic.lean`.

## Notations

* `A →ₐ[R] B` : `R`-algebra homomorphism from `A` to `B`.
* `A ≃ₐ[R] B` : `R`-algebra equivalence from `A` to `B`.
-/

universes u v w u₁ v₁

open_locale big_operators

section prio
-- We set this priority to 0 later in this file
set_option extends_priority 200 /- control priority of
`instance [algebra R A] : has_scalar R A` -/

/--
Given a commutative (semi)ring `R`, an `R`-algebra is a (possibly noncommutative)
(semi)ring `A` endowed with a morphism of rings `R →+* A` which lands in the
center of `A`.

For convenience, this typeclass extends `has_scalar R A` where the scalar action must
agree with left multiplication by the image of the structure morphism.

Given an `algebra R A` instance, the structure morphism `R →+* A` is denoted `algebra_map R A`.
-/
@[nolint has_inhabited_instance]
class algebra (R : Type u) (A : Type v) [comm_semiring R] [semiring A]
  extends has_scalar R A, R →+* A :=
(commutes' : ∀ r x, to_fun r * x = x * to_fun r)
(smul_def' : ∀ r x, r • x = to_fun r * x)
end prio

/-- Embedding `R →+* A` given by `algebra` structure. -/
def algebra_map (R : Type u) (A : Type v) [comm_semiring R] [semiring A] [algebra R A] : R →+* A :=
algebra.to_ring_hom

/-- Creating an algebra from a morphism to the center of a semiring. -/
def ring_hom.to_algebra' {R S} [comm_semiring R] [semiring S] (i : R →+* S)
  (h : ∀ c x, i c * x = x * i c) :
  algebra R S :=
{ smul := λ c x, i c * x,
  commutes' := h,
  smul_def' := λ c x, rfl,
  to_ring_hom := i}

/-- Creating an algebra from a morphism to a commutative semiring. -/
def ring_hom.to_algebra {R S} [comm_semiring R] [comm_semiring S] (i : R →+* S) :
  algebra R S :=
i.to_algebra' $ λ _, mul_comm _

lemma ring_hom.algebra_map_to_algebra {R S} [comm_semiring R] [comm_semiring S]
  (i : R →+* S) :
  @algebra_map R S _ _ i.to_algebra = i :=
rfl

namespace algebra

variables {R : Type u} {S : Type v} {A : Type w} {B : Type*}

/-- Let `R` be a commutative semiring, let `A` be a semiring with a `module R` structure.
If `(r • 1) * x = x * (r • 1) = r • x` for all `r : R` and `x : A`, then `A` is an `algebra`
over `R`.

See note [reducible non-instances]. -/
@[reducible]
def of_module' [comm_semiring R] [semiring A] [module R A]
  (h₁ : ∀ (r : R) (x : A), (r • 1) * x = r • x)
  (h₂ : ∀ (r : R) (x : A), x * (r • 1) = r • x) : algebra R A :=
{ to_fun := λ r, r • 1,
  map_one' := one_smul _ _,
  map_mul' := λ r₁ r₂, by rw [h₁, mul_smul],
  map_zero' := zero_smul _ _,
  map_add' := λ r₁ r₂, add_smul r₁ r₂ 1,
  commutes' := λ r x, by simp only [h₁, h₂],
  smul_def' := λ r x, by simp only [h₁] }

/-- Let `R` be a commutative semiring, let `A` be a semiring with a `module R` structure.
If `(r • x) * y = x * (r • y) = r • (x * y)` for all `r : R` and `x y : A`, then `A`
is an `algebra` over `R`.

See note [reducible non-instances]. -/
@[reducible]
def of_module [comm_semiring R] [semiring A] [module R A]
  (h₁ : ∀ (r : R) (x y : A), (r • x) * y = r • (x * y))
  (h₂ : ∀ (r : R) (x y : A), x * (r • y) = r • (x * y)) : algebra R A :=
of_module' (λ r x, by rw [h₁, one_mul]) (λ r x, by rw [h₂, mul_one])

section semiring

variables [comm_semiring R] [comm_semiring S]
variables [semiring A] [algebra R A] [semiring B] [algebra R B]

/-- We keep this lemma private because it picks up the `algebra.to_has_scalar` instance
which we set to priority 0 shortly. See `smul_def` below for the public version. -/
private lemma smul_def'' (r : R) (x : A) : r • x = algebra_map R A r * x :=
algebra.smul_def' r x

/--
To prove two algebra structures on a fixed `[comm_semiring R] [semiring A]` agree,
it suffices to check the `algebra_map`s agree.
-/
-- We'll later use this to show `algebra ℤ M` is a subsingleton.
@[ext]
lemma algebra_ext {R : Type*} [comm_semiring R] {A : Type*} [semiring A] (P Q : algebra R A)
  (w : ∀ (r : R), by { haveI := P, exact algebra_map R A r } =
    by { haveI := Q, exact algebra_map R A r }) :
  P = Q :=
begin
  unfreezingI { rcases P with ⟨⟨P⟩⟩, rcases Q with ⟨⟨Q⟩⟩ },
  congr,
  { funext r a,
    replace w := congr_arg (λ s, s * a) (w r),
    simp only [←smul_def''] at w,
    apply w, },
  { ext r,
    exact w r, },
  { apply proof_irrel_heq, },
  { apply proof_irrel_heq, },
end

@[priority 200] -- see Note [lower instance priority]
instance to_module : module R A :=
{ one_smul := by simp [smul_def''],
  mul_smul := by simp [smul_def'', mul_assoc],
  smul_add := by simp [smul_def'', mul_add],
  smul_zero := by simp [smul_def''],
  add_smul := by simp [smul_def'', add_mul],
  zero_smul := by simp [smul_def''] }

-- From now on, we don't want to use the following instance anymore.
-- Unfortunately, leaving it in place causes deterministic timeouts later in mathlib.
attribute [instance, priority 0] algebra.to_has_scalar

lemma smul_def (r : R) (x : A) : r • x = algebra_map R A r * x :=
algebra.smul_def' r x

lemma algebra_map_eq_smul_one (r : R) : algebra_map R A r = r • 1 :=
calc algebra_map R A r = algebra_map R A r * 1 : (mul_one _).symm
                   ... = r • 1                 : (algebra.smul_def r 1).symm

lemma algebra_map_eq_smul_one' : ⇑(algebra_map R A) = λ r, r • (1 : A) :=
funext algebra_map_eq_smul_one

/-- `mul_comm` for `algebra`s when one element is from the base ring. -/
theorem commutes (r : R) (x : A) : algebra_map R A r * x = x * algebra_map R A r :=
algebra.commutes' r x

/-- `mul_left_comm` for `algebra`s when one element is from the base ring. -/
theorem left_comm (x : A) (r : R) (y : A) :
  x * (algebra_map R A r * y) = algebra_map R A r * (x * y) :=
by rw [← mul_assoc, ← commutes, mul_assoc]

/-- `mul_right_comm` for `algebra`s when one element is from the base ring. -/
theorem right_comm (x : A) (r : R) (y : A) :
  (x * algebra_map R A r) * y = (x * y) * algebra_map R A r :=
by rw [mul_assoc, commutes, ←mul_assoc]

instance _root_.is_scalar_tower.right : is_scalar_tower R A A :=
⟨λ x y z, by rw [smul_eq_mul, smul_eq_mul, smul_def, smul_def, mul_assoc]⟩

/-- This is just a special case of the global `mul_smul_comm` lemma that requires less typeclass
search (and was here first). -/
@[simp] protected lemma mul_smul_comm (s : R) (x y : A) :
  x * (s • y) = s • (x * y) :=
-- TODO: set up `is_scalar_tower.smul_comm_class` earlier so that we can actually prove this using
-- `mul_smul_comm s x y`.
by rw [smul_def, smul_def, left_comm]

/-- This is just a special case of the global `smul_mul_assoc` lemma that requires less typeclass
search (and was here first). -/
@[simp] protected lemma smul_mul_assoc (r : R) (x y : A) :
  (r • x) * y = r • (x * y) :=
smul_mul_assoc r x y

section
variables {r : R} {a : A}

@[simp] lemma bit0_smul_one : bit0 r • (1 : A) = bit0 (r • (1 : A)) :=
by simp [bit0, add_smul]
lemma bit0_smul_one' : bit0 r • (1 : A) = r • 2 :=
by simp [bit0, add_smul, smul_add]
@[simp] lemma bit0_smul_bit0 : bit0 r • bit0 a = r • (bit0 (bit0 a)) :=
by simp [bit0, add_smul, smul_add]
@[simp] lemma bit0_smul_bit1 : bit0 r • bit1 a = r • (bit0 (bit1 a)) :=
by simp [bit0, add_smul, smul_add]
@[simp] lemma bit1_smul_one : bit1 r • (1 : A) = bit1 (r • (1 : A)) :=
by simp [bit1, add_smul]

end

variables (R A)

/--
The canonical ring homomorphism `algebra_map R A : R →* A` for any `R`-algebra `A`,
packaged as an `R`-linear map.
-/
protected def linear_map : R →ₗ[R] A :=
{ map_smul' := λ x y, by simp [algebra.smul_def],
  ..algebra_map R A }

@[simp]
lemma linear_map_apply (r : R) : algebra.linear_map R A r = algebra_map R A r := rfl

lemma coe_linear_map : ⇑(algebra.linear_map R A) = algebra_map R A := rfl

instance id : algebra R R := (ring_hom.id R).to_algebra

variables {R A}

namespace id

@[simp] lemma map_eq_id : algebra_map R R = ring_hom.id _ := rfl

lemma map_eq_self (x : R) : algebra_map R R x = x := rfl

@[simp] lemma smul_eq_mul (x y : R) : x • y = x * y := rfl

end id

section prod
variables (R A B)

instance : algebra R (A × B) :=
{ commutes' := by { rintro r ⟨a, b⟩, dsimp, rw [commutes r a, commutes r b] },
  smul_def' := by { rintro r ⟨a, b⟩, dsimp, rw [smul_def r a, smul_def r b] },
  .. prod.module,
  .. ring_hom.prod (algebra_map R A) (algebra_map R B) }

variables {R A B}

@[simp] lemma algebra_map_prod_apply (r : R) :
  algebra_map R (A × B) r = (algebra_map R A r, algebra_map R B r) := rfl

end prod

/-- Algebra over a subsemiring. This builds upon `subsemiring.module`. -/
instance of_subsemiring (S : subsemiring R) : algebra S A :=
{ smul := (•),
  commutes' := λ r x, algebra.commutes r x,
  smul_def' := λ r x, algebra.smul_def r x,
  .. (algebra_map R A).comp S.subtype }

/-- Algebra over a subring. This builds upon `subring.module`. -/
instance of_subring {R A : Type*} [comm_ring R] [ring A] [algebra R A]
  (S : subring R) : algebra S A :=
{ smul := (•),
  .. algebra.of_subsemiring S.to_subsemiring,
  .. (algebra_map R A).comp S.subtype }

lemma algebra_map_of_subring {R : Type*} [comm_ring R] (S : subring R) :
  (algebra_map S R : S →+* R) = subring.subtype S := rfl

lemma coe_algebra_map_of_subring {R : Type*} [comm_ring R] (S : subring R) :
  (algebra_map S R : S → R) = subtype.val := rfl

lemma algebra_map_of_subring_apply {R : Type*} [comm_ring R] (S : subring R) (x : S) :
  algebra_map S R x = x := rfl

/-- Explicit characterization of the submonoid map in the case of an algebra.
`S` is made explicit to help with type inference -/
def algebra_map_submonoid (S : Type*) [semiring S] [algebra R S]
  (M : submonoid R) : (submonoid S) :=
submonoid.map (algebra_map R S : R →* S) M

lemma mem_algebra_map_submonoid_of_mem [algebra R S] {M : submonoid R} (x : M) :
  (algebra_map R S x) ∈ algebra_map_submonoid S M :=
set.mem_image_of_mem (algebra_map R S) x.2

end semiring

section ring
variables [comm_ring R]

variables (R)

/-- A `semiring` that is an `algebra` over a commutative ring carries a natural `ring` structure.
See note [reducible non-instances]. -/
@[reducible]
def semiring_to_ring [semiring A] [algebra R A] : ring A :=
{ ..module.add_comm_monoid_to_add_comm_group R,
  ..(infer_instance : semiring A) }

variables {R}

lemma mul_sub_algebra_map_commutes [ring A] [algebra R A] (x : A) (r : R) :
  x * (x - algebra_map R A r) = (x - algebra_map R A r) * x :=
by rw [mul_sub, ←commutes, sub_mul]

lemma mul_sub_algebra_map_pow_commutes [ring A] [algebra R A] (x : A) (r : R) (n : ℕ) :
  x * (x - algebra_map R A r) ^ n = (x - algebra_map R A r) ^ n * x :=
begin
  induction n with n ih,
  { simp },
  { rw [pow_succ, ←mul_assoc, mul_sub_algebra_map_commutes,
      mul_assoc, ih, ←mul_assoc], }
end

end ring

end algebra

namespace no_zero_smul_divisors

variables {R A : Type*}

open algebra

section ring

variables [comm_ring R]

/-- If `algebra_map R A` is injective and `A` has no zero divisors,
`R`-multiples in `A` are zero only if one of the factors is zero.

Cannot be an instance because there is no `injective (algebra_map R A)` typeclass.
-/
lemma of_algebra_map_injective
  [semiring A] [algebra R A] [no_zero_divisors A]
  (h : function.injective (algebra_map R A)) : no_zero_smul_divisors R A :=
⟨λ c x hcx, (mul_eq_zero.mp ((smul_def c x).symm.trans hcx)).imp_left
  ((algebra_map R A).injective_iff.mp h _)⟩

variables (R A)
lemma algebra_map_injective [ring A] [nontrivial A]
  [algebra R A] [no_zero_smul_divisors R A] :
  function.injective (algebra_map R A) :=
suffices function.injective (λ (c : R), c • (1 : A)),
by { convert this, ext, rw [algebra.smul_def, mul_one] },
smul_left_injective R one_ne_zero

variables {R A}
lemma iff_algebra_map_injective [ring A] [is_domain A] [algebra R A] :
  no_zero_smul_divisors R A ↔ function.injective (algebra_map R A) :=
⟨@@no_zero_smul_divisors.algebra_map_injective R A _ _ _ _,
 no_zero_smul_divisors.of_algebra_map_injective⟩

end ring

section field

variables [field R] [semiring A] [algebra R A]

@[priority 100] -- see note [lower instance priority]
instance algebra.no_zero_smul_divisors [nontrivial A] [no_zero_divisors A] :
  no_zero_smul_divisors R A :=
no_zero_smul_divisors.of_algebra_map_injective (algebra_map R A).injective

end field

end no_zero_smul_divisors

namespace mul_opposite

variables {R A : Type*} [comm_semiring R] [semiring A] [algebra R A]

instance : algebra R Aᵐᵒᵖ :=
{ to_ring_hom := (algebra_map R A).to_opposite $ λ x y, algebra.commutes _ _,
  smul_def' := λ c x, unop_injective $
    by { dsimp, simp only [op_mul, algebra.smul_def, algebra.commutes, op_unop] },
  commutes' := λ r, mul_opposite.rec $ λ x, by dsimp; simp only [← op_mul, algebra.commutes],
  .. mul_opposite.has_scalar A R }

@[simp] lemma algebra_map_apply (c : R) : algebra_map R Aᵐᵒᵖ c = op (algebra_map R A c) := rfl

end mul_opposite

namespace module
variables (R : Type u) (M : Type v) [comm_semiring R] [add_comm_monoid M] [module R M]

instance : algebra R (module.End R M) :=
algebra.of_module smul_mul_assoc (λ r f g, (smul_comm r f g).symm)

lemma algebra_map_End_eq_smul_id (a : R) :
  (algebra_map R (End R M)) a = a • linear_map.id := rfl

@[simp] lemma algebra_map_End_apply (a : R) (m : M) :
  (algebra_map R (End R M)) a m = a • m := rfl

@[simp] lemma ker_algebra_map_End (K : Type u) (V : Type v)
  [field K] [add_comm_group V] [module K V] (a : K) (ha : a ≠ 0) :
  ((algebra_map K (End K V)) a).ker = ⊥ :=
linear_map.ker_smul _ _ ha

end module

set_option old_structure_cmd true
/-- Defining the homomorphism in the category R-Alg. -/
@[nolint has_inhabited_instance]
structure alg_hom (R : Type u) (A : Type v) (B : Type w)
  [comm_semiring R] [semiring A] [semiring B] [algebra R A] [algebra R B] extends ring_hom A B :=
(commutes' : ∀ r : R, to_fun (algebra_map R A r) = algebra_map R B r)

run_cmd tactic.add_doc_string `alg_hom.to_ring_hom "Reinterpret an `alg_hom` as a `ring_hom`"

infixr ` →ₐ `:25 := alg_hom _
notation A ` →ₐ[`:25 R `] ` B := alg_hom R A B

namespace alg_hom

variables {R : Type u} {A : Type v} {B : Type w} {C : Type u₁} {D : Type v₁}

section semiring

variables [comm_semiring R] [semiring A] [semiring B] [semiring C] [semiring D]
variables [algebra R A] [algebra R B] [algebra R C] [algebra R D]

instance : has_coe_to_fun (A →ₐ[R] B) (λ _, A → B) := ⟨alg_hom.to_fun⟩

initialize_simps_projections alg_hom (to_fun → apply)

@[simp] lemma to_fun_eq_coe (f : A →ₐ[R] B) : f.to_fun = f := rfl

instance coe_ring_hom : has_coe (A →ₐ[R] B) (A →+* B) := ⟨alg_hom.to_ring_hom⟩

instance coe_monoid_hom : has_coe (A →ₐ[R] B) (A →* B) := ⟨λ f, ↑(f : A →+* B)⟩

instance coe_add_monoid_hom : has_coe (A →ₐ[R] B) (A →+ B) := ⟨λ f, ↑(f : A →+* B)⟩

@[simp, norm_cast] lemma coe_mk {f : A → B} (h₁ h₂ h₃ h₄ h₅) :
  ⇑(⟨f, h₁, h₂, h₃, h₄, h₅⟩ : A →ₐ[R] B) = f := rfl

-- make the coercion the simp-normal form
@[simp] lemma to_ring_hom_eq_coe (f : A →ₐ[R] B) : f.to_ring_hom = f := rfl

@[simp, norm_cast] lemma coe_to_ring_hom (f : A →ₐ[R] B) : ⇑(f : A →+* B) = f := rfl

-- as `simp` can already prove this lemma, it is not tagged with the `simp` attribute.
@[norm_cast] lemma coe_to_monoid_hom (f : A →ₐ[R] B) : ⇑(f : A →* B) = f := rfl

-- as `simp` can already prove this lemma, it is not tagged with the `simp` attribute.
@[norm_cast] lemma coe_to_add_monoid_hom (f : A →ₐ[R] B) : ⇑(f : A →+ B) = f := rfl

variables (φ : A →ₐ[R] B)

theorem coe_fn_injective : @function.injective (A →ₐ[R] B) (A → B) coe_fn :=
by { intros φ₁ φ₂ H, cases φ₁, cases φ₂, congr, exact H }

theorem coe_fn_inj {φ₁ φ₂ : A →ₐ[R] B} : (φ₁ : A → B) = φ₂ ↔ φ₁ = φ₂ := coe_fn_injective.eq_iff

theorem coe_ring_hom_injective : function.injective (coe : (A →ₐ[R] B) → (A →+* B)) :=
λ φ₁ φ₂ H, coe_fn_injective $ show ((φ₁ : (A →+* B)) : A → B) = ((φ₂ : (A →+* B)) : A → B),
  from congr_arg _ H

theorem coe_monoid_hom_injective : function.injective (coe : (A →ₐ[R] B)  → (A →* B)) :=
ring_hom.coe_monoid_hom_injective.comp coe_ring_hom_injective

theorem coe_add_monoid_hom_injective : function.injective (coe : (A →ₐ[R] B)  → (A →+ B)) :=
ring_hom.coe_add_monoid_hom_injective.comp coe_ring_hom_injective

protected lemma congr_fun {φ₁ φ₂ : A →ₐ[R] B} (H : φ₁ = φ₂) (x : A) : φ₁ x = φ₂ x := H ▸ rfl
protected lemma congr_arg (φ : A →ₐ[R] B) {x y : A} (h : x = y) : φ x = φ y := h ▸ rfl

@[ext]
theorem ext {φ₁ φ₂ : A →ₐ[R] B} (H : ∀ x, φ₁ x = φ₂ x) : φ₁ = φ₂ :=
coe_fn_injective $ funext H

theorem ext_iff {φ₁ φ₂ : A →ₐ[R] B} : φ₁ = φ₂ ↔ ∀ x, φ₁ x = φ₂ x :=
⟨alg_hom.congr_fun, ext⟩

@[simp] theorem mk_coe {f : A →ₐ[R] B} (h₁ h₂ h₃ h₄ h₅) :
  (⟨f, h₁, h₂, h₃, h₄, h₅⟩ : A →ₐ[R] B) = f := ext $ λ _, rfl

@[simp]
theorem commutes (r : R) : φ (algebra_map R A r) = algebra_map R B r := φ.commutes' r

theorem comp_algebra_map : (φ : A →+* B).comp (algebra_map R A) = algebra_map R B :=
ring_hom.ext $ φ.commutes

@[simp] lemma map_add (r s : A) : φ (r + s) = φ r + φ s :=
φ.to_ring_hom.map_add r s

@[simp] lemma map_zero : φ 0 = 0 :=
φ.to_ring_hom.map_zero

@[simp] lemma map_mul (x y) : φ (x * y) = φ x * φ y :=
φ.to_ring_hom.map_mul x y

@[simp] lemma map_one : φ 1 = 1 :=
φ.to_ring_hom.map_one

@[simp] lemma map_smul (r : R) (x : A) : φ (r • x) = r • φ x :=
by simp only [algebra.smul_def, map_mul, commutes]

@[simp] lemma map_pow (x : A) (n : ℕ) : φ (x ^ n) = (φ x) ^ n :=
φ.to_ring_hom.map_pow x n

lemma map_sum {ι : Type*} (f : ι → A) (s : finset ι) :
  φ (∑ x in s, f x) = ∑ x in s, φ (f x) :=
φ.to_ring_hom.map_sum f s

lemma map_finsupp_sum {α : Type*} [has_zero α] {ι : Type*} (f : ι →₀ α) (g : ι → α → A) :
  φ (f.sum g) = f.sum (λ i a, φ (g i a)) :=
φ.map_sum _ _

@[simp] lemma map_nat_cast (n : ℕ) : φ n = n :=
φ.to_ring_hom.map_nat_cast n

@[simp] lemma map_bit0 (x) : φ (bit0 x) = bit0 (φ x) :=
φ.to_ring_hom.map_bit0 x

@[simp] lemma map_bit1 (x) : φ (bit1 x) = bit1 (φ x) :=
φ.to_ring_hom.map_bit1 x

/-- If a `ring_hom` is `R`-linear, then it is an `alg_hom`. -/
def mk' (f : A →+* B) (h : ∀ (c : R) x, f (c • x) = c • f x) : A →ₐ[R] B :=
{ to_fun := f,
  commutes' := λ c, by simp only [algebra.algebra_map_eq_smul_one, h, f.map_one],
  .. f }

@[simp] lemma coe_mk' (f : A →+* B) (h : ∀ (c : R) x, f (c • x) = c • f x) : ⇑(mk' f h) = f := rfl

section

variables (R A)
/-- Identity map as an `alg_hom`. -/
protected def id : A →ₐ[R] A :=
{ commutes' := λ _, rfl,
  ..ring_hom.id A }

@[simp] lemma coe_id : ⇑(alg_hom.id R A) = id := rfl

@[simp] lemma id_to_ring_hom : (alg_hom.id R A : A →+* A) = ring_hom.id _ := rfl

end

lemma id_apply (p : A) : alg_hom.id R A p = p := rfl

/-- Composition of algebra homeomorphisms. -/
def comp (φ₁ : B →ₐ[R] C) (φ₂ : A →ₐ[R] B) : A →ₐ[R] C :=
{ commutes' := λ r : R, by rw [← φ₁.commutes, ← φ₂.commutes]; refl,
  .. φ₁.to_ring_hom.comp ↑φ₂ }

@[simp] lemma coe_comp (φ₁ : B →ₐ[R] C) (φ₂ : A →ₐ[R] B) : ⇑(φ₁.comp φ₂) = φ₁ ∘ φ₂ := rfl

lemma comp_apply (φ₁ : B →ₐ[R] C) (φ₂ : A →ₐ[R] B) (p : A) : φ₁.comp φ₂ p = φ₁ (φ₂ p) := rfl

lemma comp_to_ring_hom (φ₁ : B →ₐ[R] C) (φ₂ : A →ₐ[R] B) :
  ⇑(φ₁.comp φ₂ : A →+* C) = (φ₁ : B →+* C).comp ↑φ₂ := rfl

@[simp] theorem comp_id : φ.comp (alg_hom.id R A) = φ :=
ext $ λ x, rfl

@[simp] theorem id_comp : (alg_hom.id R B).comp φ = φ :=
ext $ λ x, rfl

theorem comp_assoc (φ₁ : C →ₐ[R] D) (φ₂ : B →ₐ[R] C) (φ₃ : A →ₐ[R] B) :
  (φ₁.comp φ₂).comp φ₃ = φ₁.comp (φ₂.comp φ₃) :=
ext $ λ x, rfl

/-- R-Alg ⥤ R-Mod -/
def to_linear_map : A →ₗ[R] B :=
{ to_fun := φ,
  map_add' := φ.map_add,
  map_smul' := φ.map_smul }

@[simp] lemma to_linear_map_apply (p : A) : φ.to_linear_map p = φ p := rfl

theorem to_linear_map_injective : function.injective (to_linear_map : _ → (A →ₗ[R] B)) :=
λ φ₁ φ₂ h, ext $ linear_map.congr_fun h

@[simp] lemma comp_to_linear_map (f : A →ₐ[R] B) (g : B →ₐ[R] C) :
  (g.comp f).to_linear_map = g.to_linear_map.comp f.to_linear_map := rfl

@[simp] lemma to_linear_map_id : to_linear_map (alg_hom.id R A) = linear_map.id :=
linear_map.ext $ λ _, rfl

/-- Promote a `linear_map` to an `alg_hom` by supplying proofs about the behavior on `1` and `*`. -/
@[simps]
def of_linear_map (f : A →ₗ[R] B) (map_one : f 1 = 1) (map_mul : ∀ x y, f (x * y) = f x * f y) :
  A →ₐ[R] B :=
{ to_fun := f,
  map_one' := map_one,
  map_mul' := map_mul,
  commutes' := λ c, by simp only [algebra.algebra_map_eq_smul_one, f.map_smul, map_one],
  .. f.to_add_monoid_hom }

@[simp] lemma of_linear_map_to_linear_map (map_one) (map_mul) :
  of_linear_map φ.to_linear_map map_one map_mul = φ :=
by { ext, refl }

@[simp] lemma to_linear_map_of_linear_map (f : A →ₗ[R] B) (map_one) (map_mul) :
  to_linear_map (of_linear_map f map_one map_mul) = f :=
by { ext, refl }

@[simp] lemma of_linear_map_id (map_one) (map_mul) :
  of_linear_map linear_map.id map_one map_mul = alg_hom.id R A :=
ext $ λ _, rfl

lemma map_list_prod (s : list A) :
  φ s.prod = (s.map φ).prod :=
φ.to_ring_hom.map_list_prod s

section prod

/-- First projection as `alg_hom`. -/
def fst : A × B →ₐ[R] A :=
{ commutes' := λ r, rfl, .. ring_hom.fst A B}

/-- Second projection as `alg_hom`. -/
def snd : A × B →ₐ[R] B :=
{ commutes' := λ r, rfl, .. ring_hom.snd A B}

end prod

lemma algebra_map_eq_apply (f : A →ₐ[R] B) {y : R} {x : A} (h : algebra_map R A y = x) :
  algebra_map R B y = f x :=
h ▸ (f.commutes _).symm

end semiring

section comm_semiring

variables [comm_semiring R] [comm_semiring A] [comm_semiring B]
variables [algebra R A] [algebra R B] (φ : A →ₐ[R] B)

lemma map_multiset_prod (s : multiset A) :
  φ s.prod = (s.map φ).prod :=
φ.to_ring_hom.map_multiset_prod s

lemma map_prod {ι : Type*} (f : ι → A) (s : finset ι) :
  φ (∏ x in s, f x) = ∏ x in s, φ (f x) :=
φ.to_ring_hom.map_prod f s

lemma map_finsupp_prod {α : Type*} [has_zero α] {ι : Type*} (f : ι →₀ α) (g : ι → α → A) :
  φ (f.prod g) = f.prod (λ i a, φ (g i a)) :=
φ.map_prod _ _

end comm_semiring

section ring

variables [comm_semiring R] [ring A] [ring B]
variables [algebra R A] [algebra R B] (φ : A →ₐ[R] B)

@[simp] lemma map_neg (x) : φ (-x) = -φ x :=
φ.to_ring_hom.map_neg x

@[simp] lemma map_sub (x y) : φ (x - y) = φ x - φ y :=
φ.to_ring_hom.map_sub x y

@[simp] lemma map_int_cast (n : ℤ) : φ n = n :=
φ.to_ring_hom.map_int_cast n

end ring

section division_ring

variables [comm_ring R] [division_ring A] [division_ring B]
variables [algebra R A] [algebra R B] (φ : A →ₐ[R] B)

@[simp] lemma map_inv (x) : φ (x⁻¹) = (φ x)⁻¹ :=
φ.to_ring_hom.map_inv x

@[simp] lemma map_div (x y) : φ (x / y) = φ x / φ y :=
φ.to_ring_hom.map_div x y

end division_ring

theorem injective_iff {R A B : Type*} [comm_semiring R] [ring A] [semiring B]
  [algebra R A] [algebra R B] (f : A →ₐ[R] B) :
  function.injective f ↔ (∀ x, f x = 0 → x = 0) :=
ring_hom.injective_iff (f : A →+* B)

end alg_hom

@[simp] lemma rat.smul_one_eq_coe {A : Type*} [division_ring A] [algebra ℚ A] (m : ℚ) :
  m • (1 : A) = ↑m :=
by rw [algebra.smul_def, mul_one, ring_hom.eq_rat_cast]

set_option old_structure_cmd true
/-- An equivalence of algebras is an equivalence of rings commuting with the actions of scalars. -/
structure alg_equiv (R : Type u) (A : Type v) (B : Type w)
  [comm_semiring R] [semiring A] [semiring B] [algebra R A] [algebra R B]
  extends A ≃ B, A ≃* B, A ≃+ B, A ≃+* B :=
(commutes' : ∀ r : R, to_fun (algebra_map R A r) = algebra_map R B r)

attribute [nolint doc_blame] alg_equiv.to_ring_equiv
attribute [nolint doc_blame] alg_equiv.to_equiv
attribute [nolint doc_blame] alg_equiv.to_add_equiv
attribute [nolint doc_blame] alg_equiv.to_mul_equiv

notation A ` ≃ₐ[`:50 R `] ` A' := alg_equiv R A A'

namespace alg_equiv

variables {R : Type u} {A₁ : Type v} {A₂ : Type w} {A₃ : Type u₁}

section semiring

variables [comm_semiring R] [semiring A₁] [semiring A₂] [semiring A₃]
variables [algebra R A₁] [algebra R A₂] [algebra R A₃]
variables (e : A₁ ≃ₐ[R] A₂)

instance : has_coe_to_fun (A₁ ≃ₐ[R] A₂) (λ _, A₁ → A₂) := ⟨alg_equiv.to_fun⟩

@[ext]
lemma ext {f g : A₁ ≃ₐ[R] A₂} (h : ∀ a, f a = g a) : f = g :=
begin
  have h₁ : f.to_equiv = g.to_equiv := equiv.ext h,
  cases f, cases g, congr,
  { exact (funext h) },
  { exact congr_arg equiv.inv_fun h₁ }
end

protected lemma congr_arg {f : A₁ ≃ₐ[R] A₂} : Π {x x' : A₁}, x = x' → f x = f x'
| _ _ rfl := rfl

protected lemma congr_fun {f g : A₁ ≃ₐ[R] A₂} (h : f = g) (x : A₁) : f x = g x := h ▸ rfl

lemma ext_iff {f g : A₁ ≃ₐ[R] A₂} : f = g ↔ ∀ x, f x = g x :=
⟨λ h x, h ▸ rfl, ext⟩

lemma coe_fun_injective : @function.injective (A₁ ≃ₐ[R] A₂) (A₁ → A₂) (λ e, (e : A₁ → A₂)) :=
begin
  intros f g w,
  ext,
  exact congr_fun w a,
end

instance has_coe_to_ring_equiv : has_coe (A₁ ≃ₐ[R] A₂) (A₁ ≃+* A₂) := ⟨alg_equiv.to_ring_equiv⟩

@[simp] lemma coe_mk {to_fun inv_fun left_inv right_inv map_mul map_add commutes} :
  ⇑(⟨to_fun, inv_fun, left_inv, right_inv, map_mul, map_add, commutes⟩ : A₁ ≃ₐ[R] A₂) = to_fun :=
rfl

@[simp] theorem mk_coe (e : A₁ ≃ₐ[R] A₂) (e' h₁ h₂ h₃ h₄ h₅) :
  (⟨e, e', h₁, h₂, h₃, h₄, h₅⟩ : A₁ ≃ₐ[R] A₂) = e := ext $ λ _, rfl

@[simp] lemma to_fun_eq_coe (e : A₁ ≃ₐ[R] A₂) : e.to_fun = e := rfl

@[simp] lemma to_ring_equiv_eq_coe : e.to_ring_equiv = e := rfl

@[simp, norm_cast] lemma coe_ring_equiv : ((e : A₁ ≃+* A₂) : A₁ → A₂) = e := rfl
lemma coe_ring_equiv' : (e.to_ring_equiv : A₁ → A₂) = e := rfl

lemma coe_ring_equiv_injective : function.injective (coe : (A₁ ≃ₐ[R] A₂) → (A₁ ≃+* A₂)) :=
λ e₁ e₂ h, ext $ ring_equiv.congr_fun h

@[simp] lemma map_add : ∀ x y, e (x + y) = e x + e y := e.to_add_equiv.map_add

@[simp] lemma map_zero : e 0 = 0 := e.to_add_equiv.map_zero

@[simp] lemma map_mul : ∀ x y, e (x * y) = (e x) * (e y) := e.to_mul_equiv.map_mul

@[simp] lemma map_one : e 1 = 1 := e.to_mul_equiv.map_one

@[simp] lemma commutes : ∀ (r : R), e (algebra_map R A₁ r) = algebra_map R A₂ r :=
  e.commutes'

lemma map_sum {ι : Type*} (f : ι → A₁) (s : finset ι) :
  e (∑ x in s, f x) = ∑ x in s, e (f x) :=
e.to_add_equiv.map_sum f s

lemma map_finsupp_sum {α : Type*} [has_zero α] {ι : Type*} (f : ι →₀ α) (g : ι → α → A₁) :
  e (f.sum g) = f.sum (λ i b, e (g i b)) :=
e.map_sum _ _

/-- Interpret an algebra equivalence as an algebra homomorphism.

This definition is included for symmetry with the other `to_*_hom` projections.
The `simp` normal form is to use the coercion of the `has_coe_to_alg_hom` instance. -/
def to_alg_hom : A₁ →ₐ[R] A₂ :=
{ map_one' := e.map_one, map_zero' := e.map_zero, ..e }

instance has_coe_to_alg_hom : has_coe (A₁ ≃ₐ[R] A₂) (A₁ →ₐ[R] A₂) :=
⟨to_alg_hom⟩

@[simp] lemma to_alg_hom_eq_coe : e.to_alg_hom = e := rfl

@[simp, norm_cast] lemma coe_alg_hom : ((e : A₁ →ₐ[R] A₂) : A₁ → A₂) = e :=
rfl

lemma coe_alg_hom_injective : function.injective (coe : (A₁ ≃ₐ[R] A₂) → (A₁ →ₐ[R] A₂)) :=
λ e₁ e₂ h, ext $ alg_hom.congr_fun h

/-- The two paths coercion can take to a `ring_hom` are equivalent -/
lemma coe_ring_hom_commutes : ((e : A₁ →ₐ[R] A₂) : A₁ →+* A₂) = ((e : A₁ ≃+* A₂) : A₁ →+* A₂) :=
rfl

@[simp] lemma map_pow : ∀ (x : A₁) (n : ℕ), e (x ^ n) = (e x) ^ n := e.to_alg_hom.map_pow

lemma injective : function.injective e := e.to_equiv.injective

lemma surjective : function.surjective e := e.to_equiv.surjective

lemma bijective : function.bijective e := e.to_equiv.bijective

instance : has_one (A₁ ≃ₐ[R] A₁) := ⟨{commutes' := λ r, rfl, ..(1 : A₁ ≃+* A₁)}⟩

instance : inhabited (A₁ ≃ₐ[R] A₁) := ⟨1⟩

/-- Algebra equivalences are reflexive. -/
@[refl]
def refl : A₁ ≃ₐ[R] A₁ := 1

@[simp] lemma refl_to_alg_hom : ↑(refl : A₁ ≃ₐ[R] A₁) = alg_hom.id R A₁ := rfl

@[simp] lemma coe_refl : ⇑(refl : A₁ ≃ₐ[R] A₁) = id := rfl

/-- Algebra equivalences are symmetric. -/
@[symm]
def symm (e : A₁ ≃ₐ[R] A₂) : A₂ ≃ₐ[R] A₁ :=
{ commutes' := λ r, by { rw ←e.to_ring_equiv.symm_apply_apply (algebra_map R A₁ r), congr,
                         change _ = e _, rw e.commutes, },
  ..e.to_ring_equiv.symm, }

/-- See Note [custom simps projection] -/
def simps.symm_apply (e : A₁ ≃ₐ[R] A₂) : A₂ → A₁ := e.symm

initialize_simps_projections alg_equiv (to_fun → apply, inv_fun → symm_apply)

@[simp] lemma inv_fun_eq_symm {e : A₁ ≃ₐ[R] A₂} : e.inv_fun = e.symm := rfl

@[simp] lemma symm_symm (e : A₁ ≃ₐ[R] A₂) : e.symm.symm = e :=
by { ext, refl, }

lemma symm_bijective : function.bijective (symm : (A₁ ≃ₐ[R] A₂) → (A₂ ≃ₐ[R] A₁)) :=
equiv.bijective ⟨symm, symm, symm_symm, symm_symm⟩

@[simp] lemma mk_coe' (e : A₁ ≃ₐ[R] A₂) (f h₁ h₂ h₃ h₄ h₅) :
  (⟨f, e, h₁, h₂, h₃, h₄, h₅⟩ : A₂ ≃ₐ[R] A₁) = e.symm :=
symm_bijective.injective $ ext $ λ x, rfl

@[simp] theorem symm_mk (f f') (h₁ h₂ h₃ h₄ h₅) :
  (⟨f, f', h₁, h₂, h₃, h₄, h₅⟩ : A₁ ≃ₐ[R] A₂).symm =
  { to_fun := f', inv_fun := f,
    ..(⟨f, f', h₁, h₂, h₃, h₄, h₅⟩ : A₁ ≃ₐ[R] A₂).symm } := rfl

/-- Algebra equivalences are transitive. -/
@[trans]
def trans (e₁ : A₁ ≃ₐ[R] A₂) (e₂ : A₂ ≃ₐ[R] A₃) : A₁ ≃ₐ[R] A₃ :=
{ commutes' := λ r, show e₂.to_fun (e₁.to_fun _) = _, by rw [e₁.commutes', e₂.commutes'],
  ..(e₁.to_ring_equiv.trans e₂.to_ring_equiv), }

@[simp] lemma apply_symm_apply (e : A₁ ≃ₐ[R] A₂) : ∀ x, e (e.symm x) = x :=
  e.to_equiv.apply_symm_apply

@[simp] lemma symm_apply_apply (e : A₁ ≃ₐ[R] A₂) : ∀ x, e.symm (e x) = x :=
  e.to_equiv.symm_apply_apply

@[simp] lemma symm_trans_apply (e₁ : A₁ ≃ₐ[R] A₂) (e₂ : A₂ ≃ₐ[R] A₃) (x : A₃) :
  (e₁.trans e₂).symm x = e₁.symm (e₂.symm x) := rfl

@[simp] lemma coe_trans (e₁ : A₁ ≃ₐ[R] A₂) (e₂ : A₂ ≃ₐ[R] A₃) :
  ⇑(e₁.trans e₂) = e₂ ∘ e₁ := rfl

lemma trans_apply (e₁ : A₁ ≃ₐ[R] A₂) (e₂ : A₂ ≃ₐ[R] A₃) (x : A₁) :
  (e₁.trans e₂) x = e₂ (e₁ x) := rfl

@[simp] lemma comp_symm (e : A₁ ≃ₐ[R] A₂) :
  alg_hom.comp (e : A₁ →ₐ[R] A₂) ↑e.symm = alg_hom.id R A₂ :=
by { ext, simp }

@[simp] lemma symm_comp (e : A₁ ≃ₐ[R] A₂) :
  alg_hom.comp ↑e.symm (e : A₁ →ₐ[R] A₂) = alg_hom.id R A₁ :=
by { ext, simp }

theorem left_inverse_symm (e : A₁ ≃ₐ[R] A₂) : function.left_inverse e.symm e := e.left_inv

theorem right_inverse_symm (e : A₁ ≃ₐ[R] A₂) : function.right_inverse e.symm e := e.right_inv

/-- If `A₁` is equivalent to `A₁'` and `A₂` is equivalent to `A₂'`, then the type of maps
`A₁ →ₐ[R] A₂` is equivalent to the type of maps `A₁' →ₐ[R] A₂'`. -/
def arrow_congr {A₁' A₂' : Type*} [semiring A₁'] [semiring A₂'] [algebra R A₁'] [algebra R A₂']
  (e₁ : A₁ ≃ₐ[R] A₁') (e₂ : A₂ ≃ₐ[R] A₂') : (A₁ →ₐ[R] A₂) ≃ (A₁' →ₐ[R] A₂') :=
{ to_fun := λ f, (e₂.to_alg_hom.comp f).comp e₁.symm.to_alg_hom,
  inv_fun := λ f, (e₂.symm.to_alg_hom.comp f).comp e₁.to_alg_hom,
  left_inv := λ f, by { simp only [alg_hom.comp_assoc, to_alg_hom_eq_coe, symm_comp],
    simp only [←alg_hom.comp_assoc, symm_comp, alg_hom.id_comp, alg_hom.comp_id] },
  right_inv := λ f, by { simp only [alg_hom.comp_assoc, to_alg_hom_eq_coe, comp_symm],
    simp only [←alg_hom.comp_assoc, comp_symm, alg_hom.id_comp, alg_hom.comp_id] } }

lemma arrow_congr_comp {A₁' A₂' A₃' : Type*} [semiring A₁'] [semiring A₂'] [semiring A₃']
  [algebra R A₁'] [algebra R A₂'] [algebra R A₃'] (e₁ : A₁ ≃ₐ[R] A₁') (e₂ : A₂ ≃ₐ[R] A₂')
  (e₃ : A₃ ≃ₐ[R] A₃') (f : A₁ →ₐ[R] A₂) (g : A₂ →ₐ[R] A₃) :
  arrow_congr e₁ e₃ (g.comp f) = (arrow_congr e₂ e₃ g).comp (arrow_congr e₁ e₂ f) :=
by { ext, simp only [arrow_congr, equiv.coe_fn_mk, alg_hom.comp_apply],
  congr, exact (e₂.symm_apply_apply _).symm }

@[simp] lemma arrow_congr_refl :
  arrow_congr alg_equiv.refl alg_equiv.refl = equiv.refl (A₁ →ₐ[R] A₂) :=
by { ext, refl }

@[simp] lemma arrow_congr_trans {A₁' A₂' A₃' : Type*} [semiring A₁'] [semiring A₂'] [semiring A₃']
  [algebra R A₁'] [algebra R A₂'] [algebra R A₃'] (e₁ : A₁ ≃ₐ[R] A₂) (e₁' : A₁' ≃ₐ[R] A₂')
  (e₂ : A₂ ≃ₐ[R] A₃) (e₂' : A₂' ≃ₐ[R] A₃') :
  arrow_congr (e₁.trans e₂) (e₁'.trans e₂') = (arrow_congr e₁ e₁').trans (arrow_congr e₂ e₂') :=
by { ext, refl }

@[simp] lemma arrow_congr_symm {A₁' A₂' : Type*} [semiring A₁'] [semiring A₂']
  [algebra R A₁'] [algebra R A₂'] (e₁ : A₁ ≃ₐ[R] A₁') (e₂ : A₂ ≃ₐ[R] A₂') :
  (arrow_congr e₁ e₂).symm = arrow_congr e₁.symm e₂.symm :=
by { ext, refl }

/-- If an algebra morphism has an inverse, it is a algebra isomorphism. -/
def of_alg_hom (f : A₁ →ₐ[R] A₂) (g : A₂ →ₐ[R] A₁) (h₁ : f.comp g = alg_hom.id R A₂)
  (h₂ : g.comp f = alg_hom.id R A₁) : A₁ ≃ₐ[R] A₂ :=
{ to_fun    := f,
  inv_fun   := g,
  left_inv  := alg_hom.ext_iff.1 h₂,
  right_inv := alg_hom.ext_iff.1 h₁,
  ..f }

lemma coe_alg_hom_of_alg_hom (f : A₁ →ₐ[R] A₂) (g : A₂ →ₐ[R] A₁) (h₁ h₂) :
  ↑(of_alg_hom f g h₁ h₂) = f := alg_hom.ext $ λ _, rfl

@[simp]
lemma of_alg_hom_coe_alg_hom (f : A₁ ≃ₐ[R] A₂) (g : A₂ →ₐ[R] A₁) (h₁ h₂) :
  of_alg_hom ↑f g h₁ h₂ = f := ext $ λ _, rfl

lemma of_alg_hom_symm (f : A₁ →ₐ[R] A₂) (g : A₂ →ₐ[R] A₁) (h₁ h₂) :
  (of_alg_hom f g h₁ h₂).symm = of_alg_hom g f h₂ h₁ := rfl

/-- Promotes a bijective algebra homomorphism to an algebra equivalence. -/
noncomputable def of_bijective (f : A₁ →ₐ[R] A₂) (hf : function.bijective f) : A₁ ≃ₐ[R] A₂ :=
{ .. ring_equiv.of_bijective (f : A₁ →+* A₂) hf, .. f }

/-- Forgetting the multiplicative structures, an equivalence of algebras is a linear equivalence. -/
@[simps apply] def to_linear_equiv (e : A₁ ≃ₐ[R] A₂) : A₁ ≃ₗ[R] A₂ :=
{ to_fun    := e,
  map_smul' := λ r x, by simp [algebra.smul_def],
  inv_fun   := e.symm,
  .. e }

@[simp] lemma to_linear_equiv_refl :
  (alg_equiv.refl : A₁ ≃ₐ[R] A₁).to_linear_equiv = linear_equiv.refl R A₁ := rfl

@[simp] lemma to_linear_equiv_symm (e : A₁ ≃ₐ[R] A₂) :
  e.to_linear_equiv.symm = e.symm.to_linear_equiv := rfl

@[simp] lemma to_linear_equiv_trans (e₁ : A₁ ≃ₐ[R] A₂) (e₂ : A₂ ≃ₐ[R] A₃) :
  (e₁.trans e₂).to_linear_equiv = e₁.to_linear_equiv.trans e₂.to_linear_equiv := rfl

theorem to_linear_equiv_injective : function.injective (to_linear_equiv : _ → (A₁ ≃ₗ[R] A₂)) :=
λ e₁ e₂ h, ext $ linear_equiv.congr_fun h

/-- Interpret an algebra equivalence as a linear map. -/
def to_linear_map : A₁ →ₗ[R] A₂ :=
e.to_alg_hom.to_linear_map

@[simp] lemma to_alg_hom_to_linear_map :
  (e : A₁ →ₐ[R] A₂).to_linear_map = e.to_linear_map := rfl

@[simp] lemma to_linear_equiv_to_linear_map :
  e.to_linear_equiv.to_linear_map = e.to_linear_map := rfl

@[simp] lemma to_linear_map_apply (x : A₁) : e.to_linear_map x = e x := rfl

theorem to_linear_map_injective : function.injective (to_linear_map : _ → (A₁ →ₗ[R] A₂)) :=
λ e₁ e₂ h, ext $ linear_map.congr_fun h

@[simp] lemma trans_to_linear_map (f : A₁ ≃ₐ[R] A₂) (g : A₂ ≃ₐ[R] A₃) :
  (f.trans g).to_linear_map = g.to_linear_map.comp f.to_linear_map := rfl

section of_linear_equiv

variables (l : A₁ ≃ₗ[R] A₂)
  (map_mul : ∀ x y : A₁, l (x * y) = l x * l y)
  (commutes : ∀ r : R, l (algebra_map R A₁ r) = algebra_map R A₂ r)

/--
Upgrade a linear equivalence to an algebra equivalence,
given that it distributes over multiplication and action of scalars.
-/
@[simps apply]
def of_linear_equiv : A₁ ≃ₐ[R] A₂ :=
{ to_fun := l,
  inv_fun := l.symm,
  map_mul' := map_mul,
  commutes' := commutes,
  ..l }

@[simp]
lemma of_linear_equiv_symm :
  (of_linear_equiv l map_mul commutes).symm = of_linear_equiv l.symm
    ((of_linear_equiv l map_mul commutes).symm.map_mul)
    ((of_linear_equiv l map_mul commutes).symm.commutes) :=
rfl

@[simp] lemma of_linear_equiv_to_linear_equiv (map_mul) (commutes) :
  of_linear_equiv e.to_linear_equiv map_mul commutes = e :=
by { ext, refl }

@[simp] lemma to_linear_equiv_of_linear_equiv :
  to_linear_equiv (of_linear_equiv l map_mul commutes) = l :=
by { ext, refl }

end of_linear_equiv

instance aut : group (A₁ ≃ₐ[R] A₁) :=
{ mul := λ ϕ ψ, ψ.trans ϕ,
  mul_assoc := λ ϕ ψ χ, rfl,
  one := 1,
  one_mul := λ ϕ, by { ext, refl },
  mul_one := λ ϕ, by { ext, refl },
  inv := symm,
  mul_left_inv := λ ϕ, by { ext, exact symm_apply_apply ϕ a } }

@[simp] lemma mul_apply (e₁ e₂ : A₁ ≃ₐ[R] A₁) (x : A₁) : (e₁ * e₂) x = e₁ (e₂ x) := rfl

/-- An algebra isomorphism induces a group isomorphism between automorphism groups -/
@[simps apply]
def aut_congr (ϕ : A₁ ≃ₐ[R] A₂) : (A₁ ≃ₐ[R] A₁) ≃* (A₂ ≃ₐ[R] A₂) :=
{ to_fun := λ ψ, ϕ.symm.trans (ψ.trans ϕ),
  inv_fun := λ ψ, ϕ.trans (ψ.trans ϕ.symm),
  left_inv := λ ψ, by { ext, simp_rw [trans_apply, symm_apply_apply] },
  right_inv := λ ψ, by { ext, simp_rw [trans_apply, apply_symm_apply] },
  map_mul' := λ ψ χ, by { ext, simp only [mul_apply, trans_apply, symm_apply_apply] } }

@[simp] lemma aut_congr_refl : aut_congr (alg_equiv.refl) = mul_equiv.refl (A₁ ≃ₐ[R] A₁) :=
by { ext, refl }

@[simp] lemma aut_congr_symm (ϕ : A₁ ≃ₐ[R] A₂) : (aut_congr ϕ).symm = aut_congr ϕ.symm := rfl

@[simp] lemma aut_congr_trans (ϕ : A₁ ≃ₐ[R] A₂) (ψ : A₂ ≃ₐ[R] A₃) :
  (aut_congr ϕ).trans (aut_congr ψ) = aut_congr (ϕ.trans ψ) := rfl

/-- The tautological action by `A₁ ≃ₐ[R] A₁` on `A₁`.

This generalizes `function.End.apply_mul_action`. -/
instance apply_mul_semiring_action : mul_semiring_action (A₁ ≃ₐ[R] A₁) A₁ :=
{ smul := ($),
  smul_zero := alg_equiv.map_zero,
  smul_add := alg_equiv.map_add,
  smul_one := alg_equiv.map_one,
  smul_mul := alg_equiv.map_mul,
  one_smul := λ _, rfl,
  mul_smul := λ _ _ _, rfl }

@[simp] protected lemma smul_def (f : A₁ ≃ₐ[R] A₁) (a : A₁) : f • a = f a := rfl

instance apply_has_faithful_scalar : has_faithful_scalar (A₁ ≃ₐ[R] A₁) A₁ :=
⟨λ _ _, alg_equiv.ext⟩

instance apply_smul_comm_class : smul_comm_class R (A₁ ≃ₐ[R] A₁) A₁ :=
{ smul_comm := λ r e a, (e.to_linear_equiv.map_smul r a).symm }

instance apply_smul_comm_class' : smul_comm_class (A₁ ≃ₐ[R] A₁) R A₁ :=
{ smul_comm := λ e r a, (e.to_linear_equiv.map_smul r a) }

@[simp] lemma algebra_map_eq_apply (e : A₁ ≃ₐ[R] A₂) {y : R} {x : A₁} :
  (algebra_map R A₂ y = e x) ↔ (algebra_map R A₁ y = x) :=
⟨λ h, by simpa using e.symm.to_alg_hom.algebra_map_eq_apply h,
 λ h, e.to_alg_hom.algebra_map_eq_apply h⟩

end semiring

section comm_semiring

variables [comm_semiring R] [comm_semiring A₁] [comm_semiring A₂]
variables [algebra R A₁] [algebra R A₂] (e : A₁ ≃ₐ[R] A₂)

lemma map_prod {ι : Type*} (f : ι → A₁) (s : finset ι) :
  e (∏ x in s, f x) = ∏ x in s, e (f x) :=
e.to_alg_hom.map_prod f s

lemma map_finsupp_prod {α : Type*} [has_zero α] {ι : Type*} (f : ι →₀ α) (g : ι → α → A₁) :
  e (f.prod g) = f.prod (λ i a, e (g i a)) :=
e.to_alg_hom.map_finsupp_prod f g

end comm_semiring

section ring

variables [comm_ring R] [ring A₁] [ring A₂]
variables [algebra R A₁] [algebra R A₂] (e : A₁ ≃ₐ[R] A₂)

@[simp] lemma map_neg (x) : e (-x) = -e x :=
e.to_alg_hom.map_neg x

@[simp] lemma map_sub (x y) : e (x - y) = e x - e y :=
e.to_alg_hom.map_sub x y

end ring

section division_ring

variables [comm_ring R] [division_ring A₁] [division_ring A₂]
variables [algebra R A₁] [algebra R A₂] (e : A₁ ≃ₐ[R] A₂)

@[simp] lemma map_inv (x) : e (x⁻¹) = (e x)⁻¹ :=
e.to_alg_hom.map_inv x

@[simp] lemma map_div (x y) : e (x / y) = e x / e y :=
e.to_alg_hom.map_div x y

end division_ring

end alg_equiv

namespace mul_semiring_action

variables {M G : Type*} (R A : Type*) [comm_semiring R] [semiring A] [algebra R A]

section
variables [monoid M] [mul_semiring_action M A] [smul_comm_class M R A]

/-- Each element of the monoid defines a algebra homomorphism.

This is a stronger version of `mul_semiring_action.to_ring_hom` and
`distrib_mul_action.to_linear_map`. -/
@[simps]
def to_alg_hom (m : M) : A →ₐ[R] A :=
alg_hom.mk' (mul_semiring_action.to_ring_hom _ _ m) (smul_comm _)

theorem to_alg_hom_injective [has_faithful_scalar M A] :
  function.injective (mul_semiring_action.to_alg_hom R A : M → A →ₐ[R] A) :=
λ m₁ m₂ h, eq_of_smul_eq_smul $ λ r, alg_hom.ext_iff.1 h r

end

section
variables [group G] [mul_semiring_action G A] [smul_comm_class G R A]

/-- Each element of the group defines a algebra equivalence.

This is a stronger version of `mul_semiring_action.to_ring_equiv` and
`distrib_mul_action.to_linear_equiv`. -/
@[simps]
def to_alg_equiv (g : G) : A ≃ₐ[R] A :=
{ .. mul_semiring_action.to_ring_equiv _ _ g,
  .. mul_semiring_action.to_alg_hom R A g }

theorem to_alg_equiv_injective [has_faithful_scalar G A] :
  function.injective (mul_semiring_action.to_alg_equiv R A : G → A ≃ₐ[R] A) :=
λ m₁ m₂ h, eq_of_smul_eq_smul $ λ r, alg_equiv.ext_iff.1 h r

end

end mul_semiring_action

section nat

variables {R : Type*} [semiring R]

-- Lower the priority so that `algebra.id` is picked most of the time when working with
-- `ℕ`-algebras. This is only an issue since `algebra.id` and `algebra_nat` are not yet defeq.
-- TODO: fix this by adding an `of_nat` field to semirings.
/-- Semiring ⥤ ℕ-Alg -/
@[priority 99] instance algebra_nat : algebra ℕ R :=
{ commutes' := nat.cast_commute,
  smul_def' := λ _ _, nsmul_eq_mul _ _,
  to_ring_hom := nat.cast_ring_hom R }

instance nat_algebra_subsingleton : subsingleton (algebra ℕ R) :=
⟨λ P Q, by { ext, simp, }⟩

end nat

namespace ring_hom

variables {R S : Type*}

/-- Reinterpret a `ring_hom` as an `ℕ`-algebra homomorphism. -/
def to_nat_alg_hom [semiring R] [semiring S] (f : R →+* S) :
  R →ₐ[ℕ] S :=
{ to_fun := f, commutes' := λ n, by simp, .. f }

/-- Reinterpret a `ring_hom` as a `ℤ`-algebra homomorphism. -/
def to_int_alg_hom [ring R] [ring S] [algebra ℤ R] [algebra ℤ S] (f : R →+* S) :
  R →ₐ[ℤ] S :=
{ commutes' := λ n, by simp, .. f }

@[simp] lemma map_rat_algebra_map [ring R] [ring S] [algebra ℚ R] [algebra ℚ S] (f : R →+* S)
  (r : ℚ) :
  f (algebra_map ℚ R r) = algebra_map ℚ S r :=
ring_hom.ext_iff.1 (subsingleton.elim (f.comp (algebra_map ℚ R)) (algebra_map ℚ S)) r

/-- Reinterpret a `ring_hom` as a `ℚ`-algebra homomorphism. -/
def to_rat_alg_hom [ring R] [ring S] [algebra ℚ R] [algebra ℚ S] (f : R →+* S) :
  R →ₐ[ℚ] S :=
{ commutes' := f.map_rat_algebra_map, .. f }

end ring_hom

namespace rat

instance algebra_rat {α} [division_ring α] [char_zero α] : algebra ℚ α :=
(rat.cast_hom α).to_algebra' $ λ r x, r.cast_commute x

@[simp] theorem algebra_map_rat_rat : algebra_map ℚ ℚ = ring_hom.id ℚ :=
subsingleton.elim _ _

-- TODO[gh-6025]: make this an instance once safe to do so
lemma algebra_rat_subsingleton {α} [semiring α] :
  subsingleton (algebra ℚ α) :=
⟨λ x y, algebra.algebra_ext x y $ ring_hom.congr_fun $ subsingleton.elim _ _⟩

end rat

namespace algebra
open module

variables (R : Type u) (A : Type v)

variables [comm_semiring R] [semiring A] [algebra R A]

/-- `algebra_map` as an `alg_hom`. -/
def of_id : R →ₐ[R] A :=
{ commutes' := λ _, rfl, .. algebra_map R A }
variables {R}

theorem of_id_apply (r) : of_id R A r = algebra_map R A r := rfl

end algebra

section int

variables (R : Type*) [ring R]

-- Lower the priority so that `algebra.id` is picked most of the time when working with
-- `ℤ`-algebras. This is only an issue since `algebra.id ℤ` and `algebra_int ℤ` are not yet defeq.
-- TODO: fix this by adding an `of_int` field to rings.
/-- Ring ⥤ ℤ-Alg -/
@[priority 99] instance algebra_int : algebra ℤ R :=
{ commutes' := int.cast_commute,
  smul_def' := λ _ _, zsmul_eq_mul _ _,
  to_ring_hom := int.cast_ring_hom R }

variables {R}

instance int_algebra_subsingleton : subsingleton (algebra ℤ R) :=
⟨λ P Q, by { ext, simp, }⟩

end int

/-!
The R-algebra structure on `Π i : I, A i` when each `A i` is an R-algebra.

We couldn't set this up back in `algebra.pi_instances` because this file imports it.
-/
namespace pi

variable {I : Type u}     -- The indexing type
variable {R : Type*}      -- The scalar type
variable {f : I → Type v} -- The family of types already equipped with instances
variables (x y : Π i, f i) (i : I)
variables (I f)

instance algebra {r : comm_semiring R}
  [s : ∀ i, semiring (f i)] [∀ i, algebra R (f i)] :
  algebra R (Π i : I, f i) :=
{ commutes' := λ a f, begin ext, simp [algebra.commutes], end,
  smul_def' := λ a f, begin ext, simp [algebra.smul_def], end,
  ..(pi.ring_hom (λ i, algebra_map R (f i)) : R →+* Π i : I, f i) }

@[simp] lemma algebra_map_apply {r : comm_semiring R}
  [s : ∀ i, semiring (f i)] [∀ i, algebra R (f i)] (a : R) (i : I) :
  algebra_map R (Π i, f i) a i = algebra_map R (f i) a := rfl

-- One could also build a `Π i, R i`-algebra structure on `Π i, A i`,
-- when each `A i` is an `R i`-algebra, although I'm not sure that it's useful.

variables {I} (R) (f)

/-- `function.eval` as an `alg_hom`. The name matches `pi.eval_ring_hom`, `pi.eval_monoid_hom`,
etc. -/
@[simps]
def eval_alg_hom {r : comm_semiring R} [Π i, semiring (f i)] [Π i, algebra R (f i)] (i : I) :
  (Π i, f i) →ₐ[R] f i :=
{ to_fun := λ f, f i, commutes' := λ r, rfl, .. pi.eval_ring_hom f i}

variables (A B : Type*) [comm_semiring R] [semiring B] [algebra R B]

/-- `function.const` as an `alg_hom`. The name matches `pi.const_ring_hom`, `pi.const_monoid_hom`,
etc. -/
@[simps]
def const_alg_hom : B →ₐ[R] (A → B) :=
{ to_fun := function.const _,
  commutes' := λ r, rfl,
  .. pi.const_ring_hom A B}

/-- When `R` is commutative and permits an `algebra_map`, `pi.const_ring_hom` is equal to that
map. -/
@[simp] lemma const_ring_hom_eq_algebra_map : const_ring_hom A R = algebra_map R (A → R) :=
rfl

@[simp] lemma const_alg_hom_eq_algebra_of_id : const_alg_hom R A R = algebra.of_id R (A → R) :=
rfl

end pi

section is_scalar_tower

variables {R : Type*} [comm_semiring R]
variables (A : Type*) [semiring A] [algebra R A]
variables {M : Type*} [add_comm_monoid M] [module A M] [module R M] [is_scalar_tower R A M]
variables {N : Type*} [add_comm_monoid N] [module A N] [module R N] [is_scalar_tower R A N]

lemma algebra_compatible_smul (r : R) (m : M) : r • m = ((algebra_map R A) r) • m :=
by rw [←(one_smul A m), ←smul_assoc, algebra.smul_def, mul_one, one_smul]

@[simp] lemma algebra_map_smul (r : R) (m : M) : ((algebra_map R A) r) • m = r • m :=
(algebra_compatible_smul A r m).symm

variable {A}

@[priority 100] -- see Note [lower instance priority]
instance is_scalar_tower.to_smul_comm_class : smul_comm_class R A M :=
⟨λ r a m, by rw [algebra_compatible_smul A r (a • m), smul_smul, algebra.commutes, mul_smul,
  ←algebra_compatible_smul]⟩

@[priority 100] -- see Note [lower instance priority]
instance is_scalar_tower.to_smul_comm_class' : smul_comm_class A R M :=
smul_comm_class.symm _ _ _

lemma smul_algebra_smul_comm (r : R) (a : A) (m : M) : a • r • m = r • a • m :=
smul_comm _ _ _

namespace linear_map

instance coe_is_scalar_tower : has_coe (M →ₗ[A] N) (M →ₗ[R] N) :=
⟨restrict_scalars R⟩

variables (R) {A M N}

@[simp, norm_cast squash] lemma coe_restrict_scalars_eq_coe (f : M →ₗ[A] N) :
  (f.restrict_scalars R : M → N) = f := rfl

@[simp, norm_cast squash] lemma coe_coe_is_scalar_tower (f : M →ₗ[A] N) :
  ((f : M →ₗ[R] N) : M → N) = f := rfl

/-- `A`-linearly coerce a `R`-linear map from `M` to `A` to a function, given an algebra `A` over
a commutative semiring `R` and `M` a module over `R`. -/
def lto_fun (R : Type u) (M : Type v) (A : Type w)
  [comm_semiring R] [add_comm_monoid M] [module R M] [comm_ring A] [algebra R A] :
  (M →ₗ[R] A) →ₗ[A] (M → A) :=
{ to_fun := linear_map.to_fun,
  map_add' := λ f g, rfl,
  map_smul' := λ c f, rfl }

end linear_map

end is_scalar_tower

/-! TODO: The following lemmas no longer involve `algebra` at all, and could be moved closer
to `algebra/module/submodule.lean`. Currently this is tricky because `ker`, `range`, `⊤`, and `⊥`
are all defined in `linear_algebra/basic.lean`. -/
section module
open module

variables (R S M N : Type*) [semiring R] [semiring S] [has_scalar R S]
variables [add_comm_monoid M] [module R M] [module S M] [is_scalar_tower R S M]
variables [add_comm_monoid N] [module R N] [module S N] [is_scalar_tower R S N]

variables {S M N}

@[simp]
lemma linear_map.ker_restrict_scalars (f : M →ₗ[S] N) :
  (f.restrict_scalars R).ker = f.ker.restrict_scalars R :=
rfl

end module

namespace submodule

variables (R A M : Type*)
variables [comm_semiring R] [semiring A] [algebra R A] [add_comm_monoid M]
variables [module R M] [module A M] [is_scalar_tower R A M]

/-- If `A` is an `R`-algebra such that the induced morhpsim `R →+* A` is surjective, then the
`R`-module generated by a set `X` equals the `A`-module generated by `X`. -/
lemma span_eq_restrict_scalars (X : set M) (hsur : function.surjective (algebra_map R A)) :
  span R X = restrict_scalars R (span A X) :=
begin
  apply (span_le_restrict_scalars R A X).antisymm (λ m hm, _),
  refine span_induction hm subset_span (zero_mem _) (λ _ _, add_mem _) (λ a m hm, _),
  obtain ⟨r, rfl⟩ := hsur a,
  simpa [algebra_map_smul] using smul_mem _ r hm
end

end submodule

namespace alg_hom

variables {R : Type u} {A : Type v} {B : Type w} {I : Type*}

variables [comm_semiring R] [semiring A] [semiring B]
variables [algebra R A] [algebra R B]

/-- `R`-algebra homomorphism between the function spaces `I → A` and `I → B`, induced by an
`R`-algebra homomorphism `f` between `A` and `B`. -/
@[simps] protected def comp_left (f : A →ₐ[R] B) (I : Type*) : (I → A) →ₐ[R] (I → B) :=
{ to_fun := λ h, f ∘ h,
  commutes' := λ c, by { ext, exact f.commutes' c },
  .. f.to_ring_hom.comp_left I }

end alg_hom