/-
Copyright (c) 2020 Yury Kudryashov. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Author: Yury Kudryashov
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.logic.function.basic
import Mathlib.PostPort

universes u_1 u_2 u_3

namespace Mathlib

/-!
# Semiconjugate and commuting maps

We define the following predicates:

* `function.semiconj`: `f : α → β` semiconjugates `ga : α → α` to `gb : β → β` if `f ∘ ga = gb ∘ f`;
* `function.semiconj₂: `f : α → β` semiconjugates a binary operation `ga : α → α → α`
  to `gb : β → β → β` if `f (ga x y) = gb (f x) (f y)`;
* `f : α → α` commutes with `g : α → α` if `f ∘ g = g ∘ f`, or equivalently `semiconj f g g`.

-/

namespace function

/-- We say that `f : α → β` semiconjugates `ga : α → α` to `gb : β → β` if `f ∘ ga = gb ∘ f`. -/
def semiconj {α : Type u_1} {β : Type u_2} (f : α → β) (ga : α → α) (gb : β → β) :=
  ∀ (x : α), f (ga x) = gb (f x)

namespace semiconj

protected theorem comp_eq {α : Type u_1} {β : Type u_2} {f : α → β} {ga : α → α} {gb : β → β} (h : semiconj f ga gb) : f ∘ ga = gb ∘ f :=
  funext h

protected theorem eq {α : Type u_1} {β : Type u_2} {f : α → β} {ga : α → α} {gb : β → β} (h : semiconj f ga gb) (x : α) : f (ga x) = gb (f x) :=
  h x

theorem comp_right {α : Type u_1} {β : Type u_2} {f : α → β} {ga : α → α} {ga' : α → α} {gb : β → β} {gb' : β → β} (h : semiconj f ga gb) (h' : semiconj f ga' gb') : semiconj f (ga ∘ ga') (gb ∘ gb') := sorry

theorem comp_left {α : Type u_1} {β : Type u_2} {γ : Type u_3} {fab : α → β} {fbc : β → γ} {ga : α → α} {gb : β → β} {gc : γ → γ} (hab : semiconj fab ga gb) (hbc : semiconj fbc gb gc) : semiconj (fbc ∘ fab) ga gc := sorry

theorem id_right {α : Type u_1} {β : Type u_2} {f : α → β} : semiconj f id id :=
  fun (_x : α) => rfl

theorem id_left {α : Type u_1} {ga : α → α} : semiconj id ga ga :=
  fun (_x : α) => rfl

theorem inverses_right {α : Type u_1} {β : Type u_2} {f : α → β} {ga : α → α} {ga' : α → α} {gb : β → β} {gb' : β → β} (h : semiconj f ga gb) (ha : right_inverse ga' ga) (hb : left_inverse gb' gb) : semiconj f ga' gb' := sorry

end semiconj

/-- Two maps `f g : α → α` commute if `f ∘ g = g ∘ f`. -/
def commute {α : Type u_1} (f : α → α) (g : α → α) :=
  semiconj f g g

theorem semiconj.commute {α : Type u_1} {f : α → α} {g : α → α} (h : semiconj f g g) : commute f g :=
  h

namespace commute

theorem refl {α : Type u_1} (f : α → α) : commute f f :=
  fun (_x : α) => Eq.refl (f (f _x))

theorem symm {α : Type u_1} {f : α → α} {g : α → α} (h : commute f g) : commute g f :=
  fun (x : α) => Eq.symm (h x)

theorem comp_right {α : Type u_1} {f : α → α} {g : α → α} {g' : α → α} (h : commute f g) (h' : commute f g') : commute f (g ∘ g') :=
  semiconj.comp_right h h'

theorem comp_left {α : Type u_1} {f : α → α} {f' : α → α} {g : α → α} (h : commute f g) (h' : commute f' g) : commute (f ∘ f') g :=
  symm (comp_right (symm h) (symm h'))

theorem id_right {α : Type u_1} {f : α → α} : commute f id :=
  semiconj.id_right

theorem id_left {α : Type u_1} {f : α → α} : commute id f :=
  semiconj.id_left

end commute

/-- A map `f` semiconjugates a binary operation `ga` to a binary operation `gb` if
for all `x`, `y` we have `f (ga x y) = gb (f x) (f y)`. E.g., a `monoid_hom`
semiconjugates `(*)` to `(*)`. -/
def semiconj₂ {α : Type u_1} {β : Type u_2} (f : α → β) (ga : α → α → α) (gb : β → β → β) :=
  ∀ (x y : α), f (ga x y) = gb (f x) (f y)

namespace semiconj₂

protected theorem eq {α : Type u_1} {β : Type u_2} {f : α → β} {ga : α → α → α} {gb : β → β → β} (h : semiconj₂ f ga gb) (x : α) (y : α) : f (ga x y) = gb (f x) (f y) :=
  h x y

protected theorem comp_eq {α : Type u_1} {β : Type u_2} {f : α → β} {ga : α → α → α} {gb : β → β → β} (h : semiconj₂ f ga gb) : bicompr f ga = bicompl gb f f :=
  funext fun (x : α) => funext (h x)

theorem id_left {α : Type u_1} (op : α → α → α) : semiconj₂ id op op :=
  fun (_x _x_1 : α) => rfl

theorem comp {α : Type u_1} {β : Type u_2} {γ : Type u_3} {f : α → β} {ga : α → α → α} {gb : β → β → β} {f' : β → γ} {gc : γ → γ → γ} (hf' : semiconj₂ f' gb gc) (hf : semiconj₂ f ga gb) : semiconj₂ (f' ∘ f) ga gc := sorry

theorem is_associative_right {α : Type u_1} {β : Type u_2} {f : α → β} {ga : α → α → α} {gb : β → β → β} [is_associative α ga] (h : semiconj₂ f ga gb) (h_surj : surjective f) : is_associative β gb := sorry

theorem is_associative_left {α : Type u_1} {β : Type u_2} {f : α → β} {ga : α → α → α} {gb : β → β → β} [is_associative β gb] (h : semiconj₂ f ga gb) (h_inj : injective f) : is_associative α ga := sorry

theorem is_idempotent_right {α : Type u_1} {β : Type u_2} {f : α → β} {ga : α → α → α} {gb : β → β → β} [is_idempotent α ga] (h : semiconj₂ f ga gb) (h_surj : surjective f) : is_idempotent β gb := sorry

theorem is_idempotent_left {α : Type u_1} {β : Type u_2} {f : α → β} {ga : α → α → α} {gb : β → β → β} [is_idempotent β gb] (h : semiconj₂ f ga gb) (h_inj : injective f) : is_idempotent α ga := sorry


/-
Copyright (c) 2019 Chris Hughes. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Chris Hughes
-/
import group_theory.perm group_theory.order_of_element group_theory.quotient_group

universes u v
open finset is_subgroup equiv equiv.perm quotient_group

instance {α β : Type*} [group α] [group β] [decidable_eq β] (f : α → β) [is_group_hom f] :
  decidable_pred (is_group_hom.ker f) :=
λ _, decidable_of_iff _ (is_group_hom.mem_ker f).symm

def alternating (α : Type*) [decidable_eq α] [fintype α] : Type* :=
is_group_hom.ker (sign : perm α → units ℤ)

def perm.of_list_swap (α : Type*) [decidable_eq α] [fintype α] :
  list {x : α × α // x.1 ≠ x.2} → perm α
| [] := 1
| (⟨(a, b), _⟩ :: l) := swap a b * perm.of_list_swap l

/- not definitionally equal to `subtype.decidable_eq`, since `subtype.decidable_eq` does
  not reduce in the kernel -/
instance (α : Type*) [decidable_eq α] [fintype α] : decidable_eq (alternating α) :=
λ a b, decidable_of_iff (a.1 = b.1) (by cases a; cases b; simp [subtype.mk.inj_eq])

instance (α : Type*) [decidable_eq α] [fintype α] : fintype (alternating α) :=
set_fintype _

instance (α : Type*) [decidable_eq α] [fintype α] : group (alternating α) :=
by unfold alternating; apply_instance

section classical

local attribute [instance, priority 0] classical.prop_decidable

lemma card_alternating {α : Type*} [decidable_eq α] [fintype α] (h : 2 ≤ fintype.card α):
  fintype.card (alternating α) = (fintype.card α).fact / 2 :=
have (quotient_group.quotient (is_group_hom.ker (sign : perm α → units ℤ))) ≃ units ℤ,
  from quotient_ker_equiv_of_surjective _ (sign_surjective h),
(nat.mul_right_inj (show 0 < 2, from dec_trivial)).1 $
calc fintype.card (alternating α) * 2 = fintype.card (units ℤ × alternating α) :
  by rw [mul_comm, fintype.card_prod, fintype.card_units_int]
... = fintype.card (perm α) : fintype.card_congr
  (calc (units ℤ × alternating α) ≃
    (quotient_group.quotient (is_group_hom.ker (sign : perm α → units ℤ)) × alternating α)  :
      equiv.prod_congr this.symm (by refl)
  ... ≃ perm α : (group_equiv_quotient_times_subgroup _).symm)
... = (fintype.card α).fact : fintype.card_perm
... = (fintype.card α).fact / 2 * 2 : eq.symm $
  nat.div_mul_cancel (nat.dvd_fact dec_trivial h)

end classical

local notation `A5` := alternating (fin 5)
variables {α : Type*} [fintype α] [decidable_eq α]

section meta_
local attribute [semireducible] reflected

meta instance fin_reflect (n : ℕ) : has_reflect (fin n) :=
λ a, `(@fin.mk %%`(n) %%(nat.reflect a.1) (of_as_true %%`(_root_.trivial)))

meta instance fin_fun.has_reflect : has_reflect (fin 5 → fin 5) :=
list.rec_on (quot.unquot (@univ (fin 5) _).1)
  (λ f, `(λ y : fin 5, y))
  (λ x l ih f, let e := ih f in
    if f x = x then e
    else let ex := fin_reflect 5 x in
      let efx := fin_reflect 5 (f x) in
      if e = `(λ y : fin 5, y)
      then `(λ y : fin 5, ite (y = %%ex) (%%efx) y)
      else `(λ y : fin 5, ite (y = %%ex) (%%efx) ((%%e : fin 5 → fin 5) y)))

meta instance : has_reflect (perm (fin 5)) :=
λ f, `(@equiv.mk.{1 1} (fin 5) (fin 5)
    %%(fin_fun.has_reflect f.to_fun)
  %%(fin_fun.has_reflect f.inv_fun)
  (of_as_true %%`(_root_.trivial)) (of_as_true %%`(_root_.trivial)))

meta instance I1 : has_reflect A5 :=
λ f, `(@subtype.mk (perm (fin 5)) (is_group_hom.ker (sign : perm (fin 5) → units ℤ))
   %%(@reflect (perm (fin 5)) f.1 (equiv.perm.has_reflect f.1))
  ((is_group_hom.mem_ker sign).2 %%`(@eq.refl (units ℤ) 1)))

meta instance multiset.has_reflect {α : Type} [reflected α] [has_reflect α] :
  has_reflect (multiset α) :=
λ s, let l : list α := quot.unquot s in `(@quotient.mk.{1} (list %%`(α)) _ %%`(l))

meta instance I2 (a : A5) :
  has_reflect {b : A5 × A5 // b.2 * a * b.2⁻¹ = b.1} :=
λ b, `(@subtype.mk (A5 × A5)
  (λ b, b.2 * %%`(a) * b.2⁻¹ = b.1)
  %%(prod.has_reflect _ _ b.1) (of_as_true %%`(_root_.trivial)))

meta instance I3 : reflected (A5 × A5) :=
`(A5 × A5)

meta instance I4 : has_reflect (A5 × multiset (A5 × A5)) :=
λ s, let ra : reflected s.1 := (I1 s.1) in
`(let a : A5 := %%ra in
  @prod.mk A5 (multiset (A5 × A5))
    a %%(multiset.has_reflect s.2))

meta instance I5 : has_reflect (A5 × list (A5 × A5)) :=
λ s, let ra : reflected s.1 := (I1 s.1) in
`(let a : A5 := %%ra in
  @prod.mk A5 (list (A5 × A5))
    a %%`(s.2))

meta def conjugacy_classes_A5_meta_aux : list A5 → list (A5 × list (A5 × A5))
| [] := []
| (a :: l) :=
let m : A5 × list (A5 × A5) :=
  ⟨a, ((quot.unquot (@univ A5 _).1).map
    (λ x, show A5 × A5,
      from (x * a * x⁻¹, x))).pw_filter (λ x y, x.1 ≠ y.1)⟩ in
m :: conjugacy_classes_A5_meta_aux (l.diff (m.2.map prod.fst))

meta def conjugacy_classes_A5_meta : multiset (A5 × multiset (A5 × A5)) :=
(quotient.mk ((conjugacy_classes_A5_meta_aux (quot.unquot univ.1)).map
    (λ a, ⟨a.1, (quotient.mk a.2)⟩)))

meta def exact_reflect {α : Sort*} [has_reflect α] (a : α) : tactic unit :=
tactic.exact `(a)

end meta_

@[irreducible] def conjugacy_classes_A5_aux :
  multiset (A5 × multiset (A5 × A5)) :=
by exact_reflect (conjugacy_classes_A5_meta)

def conjugacy_classes_A5_aux_list : list (A5 × list (A5 × A5)) :=
by exact_reflect (conjugacy_classes_A5_meta_aux (quot.unquot finset.univ.1))
#print conjugacy_classes_A5_aux

def conjugacy_classes_A5_aux2 : multiset (multiset A5) :=
conjugacy_classes_A5_aux.map (λ s, s.2.map prod.fst)

lemma nodup_conjugacy_classes_A5_aux2_bind : (conjugacy_classes_A5_aux2.bind id).nodup :=
dec_trivial

--#reduce nodup_conjugacy_classes_A5_aux2_bind

lemma nodup_conjugacy_classes_A5_aux2 : ∀ s : multiset A5,
  s ∈ conjugacy_classes_A5_aux2 → s.nodup :=
(multiset.nodup_bind.1 nodup_conjugacy_classes_A5_aux2_bind).1

def conjugacy_classes_A5 : finset (finset A5) :=
⟨conjugacy_classes_A5_aux2.pmap finset.mk nodup_conjugacy_classes_A5_aux2, dec_trivial⟩

lemma nodup_conjugacy_classes_A5_bind : (conjugacy_classes_A5.1.bind finset.val).nodup :=
have conjugacy_classes_A5.1.bind finset.val =
  conjugacy_classes_A5_aux2.bind id,
from multiset.ext.2 $ λ a,
  by rw [conjugacy_classes_A5, @multiset.count_bind A5, @multiset.count_bind A5,
    multiset.map_pmap, multiset.pmap_eq_map]; refl,
by rw this; exact nodup_conjugacy_classes_A5_aux2_bind

lemma g : ∀ x ∈ [0,0,0,0,0,0,0], x = 0 := dec_trivial
lemma ajfh : [0,1,2,3,4,5,6].nodup := dec_trivial

local attribute [instance, priority 1000] finset.decidable_dforall_finset
#print of_as_true
lemma is_conj_conjugacy_classes_A5 : ∀ x : A5 × A5 × A5,
  x ∈ conjugacy_classes_A5_aux_list.bind (λ s, s.2.map (λ y : A5 × A5, (s.1, y))) →
  x.2.2 * x.1 * x.2.2⁻¹ = x.2.1 :=
  @of_as_true _ (list.decidable_forall_mem _) (by trivial)

-- #print list.mem
-- lemma is_conj_conjugacy_classes_A5 : ∀ x : A5 × A5 × A5,
--   x ∈ conjugacy_classes_A5_aux_list.bind (λ s, s.2.map (λ y : A5 × A5, (s.1, y))) →
--   x.2.2 * x.1 * x.2.2⁻¹ = x.2.1 :=
-- begin
--   assume x hx,
--   repeat { refine or.rec_on hx (λ h, by rw h; exact dec_trivial)
--       (λ hx, _) <|> assumption },
-- end

lemma is_conj_conjugacy_classes_A5 (s : finset A5) (h : s ∈ conjugacy_classes_A5) :
  ∀ x y ∈ s, is_conj x y :=
assume x y hx hy,
begin
  simp only [conjugacy_classes_A5, finset.mem_def, multiset.mem_pmap,
    conjugacy_classes_A5_aux2] at h,
  rcases h with ⟨t, ht₁, ht₂⟩,
  rw [multiset.mem_map] at ht₁,
  rcases ht₁ with ⟨u, hu₁, hu₂⟩,
  have hx' : x ∈ multiset.map (λ (b : {b : A5 × A5 // b.2 * u.1 * b.2⁻¹ = b.1}), b.1.1) u.2,
  { simpa [ht₂.symm, hu₂] using hx },
  have hy' : y ∈ multiset.map (λ (b : {b : A5 × A5 // b.2 * u.1 * b.2⁻¹ = b.1}), b.1.1) u.2,
  { simpa [ht₂.symm, hu₂] using hy },
  cases multiset.mem_map.1 hx' with xc hxc,
  cases multiset.mem_map.1 hy' with yc hyc,
  exact is_conj_trans
    (is_conj_symm (show is_conj u.1 x, from hxc.2 ▸ ⟨_, xc.2⟩))
    (hyc.2 ▸ ⟨_, yc.2⟩)
end

variables {G : Type u} [group G] [decidable_eq G]

lemma normal_subgroup_eq_bind_conjugacy_classes (s : finset (finset G)) (h₁ : ∀ x, ∃ t ∈ s, x ∈ t)
  (h₂ : ∀ t ∈ s, ∀ x y ∈ t, is_conj x y) (I : finset G) [nI : normal_subgroup (↑I : set G)] :
  ∃ u ⊆ s, I = u.bind id :=
⟨(s.powerset.filter (λ u : finset (finset G), u.bind id ⊆ I)).bind id,
    (λ x, by simp only [finset.subset_iff, mem_bind, mem_filter, exists_imp_distrib, mem_powerset,
      and_imp, id.def] {contextual := tt}; tauto),
  le_antisymm
    (λ x hxI, let ⟨t, ht₁, ht₂⟩ := h₁ x in
      mem_bind.2 ⟨t, mem_bind.2 ⟨(s.powerset.filter (λ u : finset (finset G), u.bind id ⊆ I)).bind id,
          mem_filter.2 ⟨mem_powerset.2
            (λ u hu, let ⟨v, hv₁, hv₂⟩ := mem_bind.1 hu in
              mem_powerset.1 (mem_filter.1 hv₁).1 hv₂),
          λ y hy, let ⟨u, hu₁, hu₂⟩ := mem_bind.1 hy in
            let ⟨v, hv₁, hv₂⟩ := mem_bind.1 hu₁ in
            (mem_filter.1 hv₁).2 (mem_bind.2 ⟨u, hv₂, hu₂⟩)⟩,
        mem_bind.2 ⟨{t}, mem_filter.2 ⟨by simp [ht₁, finset.subset_iff],
            λ y hy, let ⟨u, hu₁, hu₂⟩ := mem_bind.1 hy in
              let ⟨z, hz⟩ := h₂ t ht₁ x y ht₂ (by simp * at *) in
              hz ▸ @normal_subgroup.normal G _ I.to_set nI _ hxI _⟩,
          by simp⟩⟩,
        ht₂⟩)
    (λ x, by simp only [finset.subset_iff, mem_bind, exists_imp_distrib, mem_filter, mem_powerset]; tauto)⟩

lemma simple_of_card_conjugacy_classes [fintype G] (s : finset (finset G))
  (h₁ : ∀ x, ∃ t ∈ s, x ∈ t) (h₂ : ∀ t ∈ s, ∀ x y ∈ t, is_conj x y)
  (hs : (s.1.bind finset.val).nodup)
  (h₃ : ∀ t ≤ s.1.map finset.card, 1 ∈ t → t.sum ∣ fintype.card G → t.sum = 1 ∨ t.sum = fintype.card G) :
  simple_group G :=
by haveI := classical.dec; exact
⟨λ H iH,
  let I := (set.to_finset H) in
  have Ii : normal_subgroup (↑I : set G), by simpa using iH,
  let ⟨u, hu₁, hu₂⟩ :=
    @normal_subgroup_eq_bind_conjugacy_classes G _ _ s h₁ h₂ I Ii in
  have hInd : ∀ (x : finset G), x ∈ u → ∀ (y : finset G), y ∈ u → x ≠ y → id x ∩ id y = ∅,
    from λ x hxu y hyu hxy,
      begin
        rw multiset.nodup_bind at hs,
        rw [← finset.disjoint_iff_inter_eq_empty, finset.disjoint_left],
        exact multiset.forall_of_pairwise
          (λ (a b : finset G) (h : multiset.disjoint a.1 b.1),
          multiset.disjoint.symm h) hs.2 x (hu₁ hxu) y (hu₁ hyu) hxy
      end,
  have hci : card I = u.sum finset.card,
    by rw [hu₂, card_bind hInd]; refl,
  have hu1 : (1 : G) ∈ u.bind id, by exactI hu₂ ▸ is_submonoid.one_mem (↑I : set G),
  let ⟨v, hv₁, hv₂⟩ := mem_bind.1 hu1 in
  have hv : v = finset.singleton (1 : G),
    from finset.ext.2 $ λ a, ⟨λ hav, mem_singleton.2 $
        is_conj_one_right.1 (h₂ v (hu₁ hv₁) _ _ hv₂ hav),
      by simp [show (1 : G) ∈ v, from hv₂] {contextual := tt}⟩,
  have hci' : card I = 1 ∨ card I = fintype.card G,
    begin
      rw [hci],
      exact h₃ _ (multiset.map_le_map (show u.1 ≤ s.1,
        from (multiset.le_iff_subset u.2).2 hu₁))
          (multiset.mem_map.2 ⟨finset.singleton 1, hv ▸ hv₁, rfl⟩)
          (calc u.sum finset.card = card I : hci.symm
            ... = fintype.card (↑I : set G) : (set.card_fintype_of_finset' I (by simp)).symm
            ... ∣ fintype.card G : by exactI card_subgroup_dvd_card _)
    end,
    hci'.elim
      (λ hci', or.inl (set.ext (λ x,
        let ⟨y, hy⟩ := finset.card_eq_one.1 hci' in
        by resetI;
          simp only [I, finset.ext, set.mem_to_finset, finset.mem_singleton] at hy;
          simp [is_subgroup.mem_trivial, hy, (hy 1).1 (is_submonoid.one_mem H)])))
      (λ hci', or.inr $
        suffices I = finset.univ,
          by simpa [I, set.ext_iff, finset.ext] using this,
        finset.eq_of_subset_of_card_le (λ _, by simp) (by rw hci'; refl))⟩

lemma card_A5 : fintype.card A5 = 60 := card_alternating dec_trivial

lemma conjugacy_classes_A5_bind_eq_univ :
  conjugacy_classes_A5.bind (λ t, t) = univ :=
eq_of_subset_of_card_le (λ _ _, finset.mem_univ _)
  (calc card univ = 60 : card_A5
    ... ≤ (conjugacy_classes_A5.1.bind finset.val).card : dec_trivial
    ... = (conjugacy_classes_A5.bind id).card :
      begin
        rw [finset.card_bind, multiset.card_bind], refl,
        { exact multiset.forall_of_pairwise (λ a b, by simp [finset.inter_comm])
            (by simp only [finset.disjoint_iff_inter_eq_empty.symm, finset.disjoint_left];
              exact (multiset.nodup_bind.1 nodup_conjugacy_classes_A5_bind).2) }
      end)

lemma simple_group_A5 : simple_group A5 :=
simple_of_card_conjugacy_classes conjugacy_classes_A5
  (λ x, mem_bind.1 $ by rw [conjugacy_classes_A5_bind_eq_univ]; simp)
  is_conj_conjugacy_classes_A5
  nodup_conjugacy_classes_A5_bind
  (by simp only [multiset.mem_powerset.symm, card_A5];
    exact dec_trivial)


/-
Copyright (c) 2019 Reid Barton. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Reid Barton
-/
import topology.category.Top.adjunctions

/-!
# Epi- and monomorphisms in `Top`

This file shows that a continuous function is an epimorphism in the category of topological spaces
if and only if it is surjective, and that a continuous function is a monomorphism in the category of
topological spaces if and only if it is injective.
-/

universe u

open category_theory
open Top

namespace Top

lemma epi_iff_surjective {X Y : Top.{u}} (f : X ⟶ Y) : epi f ↔ function.surjective f :=
begin
  suffices : epi f ↔ epi ((forget Top).map f),
  { rw [this, category_theory.epi_iff_surjective], refl },
  split,
  { introI, apply_instance },
  { apply functor.epi_of_epi_map }
end

lemma mono_iff_injective {X Y : Top.{u}} (f : X ⟶ Y) : mono f ↔ function.injective f :=
begin
  suffices : mono f ↔ mono ((forget Top).map f),
  { rw [this, category_theory.mono_iff_injective], refl },
  split,
  { introI, apply_instance },
  { apply functor.mono_of_mono_map }
end

end Top


/-
Copyright (c) 2021 Jakob Scholbach. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Jakob Scholbach, Joël Riou

! This file was ported from Lean 3 source module category_theory.lifting_properties.basic
! leanprover-community/mathlib commit 32253a1a1071173b33dc7d6a218cf722c6feb514
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathlib.CategoryTheory.CommSq

/-!
# Lifting properties

This file defines the lifting property of two morphisms in a category and
shows basic properties of this notion.

## Main results
- `HasLiftingProperty`: the definition of the lifting property

## Tags
lifting property

@TODO :
1) define llp/rlp with respect to a `morphism_property`
2) retracts, direct/inverse images, (co)products, adjunctions

-/

universe v

namespace CategoryTheory

open Category

variable {C : Type _} [Category C] {A B B' X Y Y' : C} (i : A ⟶ B) (i' : B ⟶ B') (p : X ⟶ Y)
  (p' : Y ⟶ Y')

/-- `HasLiftingProperty i p` means that `i` has the left lifting
property with respect to `p`, or equivalently that `p` has
the right lifting property with respect to `i`. -/
class HasLiftingProperty : Prop where
  /-- Unique field expressing the any commutative square built from `f` and `g` has a lift -/
  sq_hasLift : ∀ {f : A ⟶ X} {g : B ⟶ Y} (sq : CommSq f i p g), sq.HasLift
#align category_theory.has_lifting_property CategoryTheory.HasLiftingProperty
#align category_theory.has_lifting_property.sq_has_lift CategoryTheory.HasLiftingProperty.sq_hasLift

instance (priority := 100) sq_hasLift_of_hasLiftingProperty {f : A ⟶ X} {g : B ⟶ Y}
    (sq : CommSq f i p g) [hip : HasLiftingProperty i p] : sq.HasLift := by apply hip.sq_hasLift
#align category_theory.sq_has_lift_of_has_lifting_property CategoryTheory.sq_hasLift_of_hasLiftingProperty

namespace HasLiftingProperty

variable {i p}

theorem op (h : HasLiftingProperty i p) : HasLiftingProperty p.op i.op :=
  ⟨fun {f} {g} sq => by
    simp only [CommSq.HasLift.iff_unop, Quiver.Hom.unop_op]
    infer_instance⟩
#align category_theory.has_lifting_property.op CategoryTheory.HasLiftingProperty.op

theorem unop {A B X Y : Cᵒᵖ} {i : A ⟶ B} {p : X ⟶ Y} (h : HasLiftingProperty i p) :
    HasLiftingProperty p.unop i.unop :=
  ⟨fun {f} {g} sq => by
    rw [CommSq.HasLift.iff_op]
    simp only [Quiver.Hom.op_unop]
    infer_instance⟩
#align category_theory.has_lifting_property.unop CategoryTheory.HasLiftingProperty.unop

theorem iff_op : HasLiftingProperty i p ↔ HasLiftingProperty p.op i.op :=
  ⟨op, unop⟩
#align category_theory.has_lifting_property.iff_op CategoryTheory.HasLiftingProperty.iff_op

theorem iff_unop {A B X Y : Cᵒᵖ} (i : A ⟶ B) (p : X ⟶ Y) :
    HasLiftingProperty i p ↔ HasLiftingProperty p.unop i.unop :=
  ⟨unop, op⟩
#align category_theory.has_lifting_property.iff_unop CategoryTheory.HasLiftingProperty.iff_unop

variable (i p)

instance (priority := 100) of_left_iso [IsIso i] : HasLiftingProperty i p :=
  ⟨fun {f} {g} sq =>
    CommSq.HasLift.mk'
      { l := inv i ≫ f
        fac_left := by simp only [IsIso.hom_inv_id_assoc]
        fac_right := by simp only [sq.w, assoc, IsIso.inv_hom_id_assoc] }⟩
#align category_theory.has_lifting_property.of_left_iso CategoryTheory.HasLiftingProperty.of_left_iso

instance (priority := 100) of_right_iso [IsIso p] : HasLiftingProperty i p :=
  ⟨fun {f} {g} sq =>
    CommSq.HasLift.mk'
      { l := g ≫ inv p
        fac_left := by simp only [← sq.w_assoc, IsIso.hom_inv_id, comp_id]
        fac_right := by simp only [assoc, IsIso.inv_hom_id, comp_id] }⟩
#align category_theory.has_lifting_property.of_right_iso CategoryTheory.HasLiftingProperty.of_right_iso

instance of_comp_left [HasLiftingProperty i p] [HasLiftingProperty i' p] :
    HasLiftingProperty (i ≫ i') p :=
  ⟨fun {f} {g} sq => by
    have fac := sq.w
    rw [assoc] at fac
    exact
      CommSq.HasLift.mk'
        { l := (CommSq.mk (CommSq.mk fac).fac_right).lift
          fac_left := by simp only [assoc, CommSq.fac_left]
          fac_right := by simp only [CommSq.fac_right] }⟩
#align category_theory.has_lifting_property.of_comp_left CategoryTheory.HasLiftingProperty.of_comp_left

instance of_comp_right [HasLiftingProperty i p] [HasLiftingProperty i p'] :
    HasLiftingProperty i (p ≫ p') :=
  ⟨fun {f} {g} sq => by
    have fac := sq.w
    rw [← assoc] at fac
    let _ := (CommSq.mk (CommSq.mk fac).fac_left.symm).lift
    exact
      CommSq.HasLift.mk'
        { l := (CommSq.mk (CommSq.mk fac).fac_left.symm).lift
          fac_left := by simp only [CommSq.fac_left]
          fac_right := by simp only [CommSq.fac_right_assoc, CommSq.fac_right] }⟩
#align category_theory.has_lifting_property.of_comp_right CategoryTheory.HasLiftingProperty.of_comp_right

theorem of_arrow_iso_left {A B A' B' X Y : C} {i : A ⟶ B} {i' : A' ⟶ B'}
    (e : Arrow.mk i ≅ Arrow.mk i') (p : X ⟶ Y) [hip : HasLiftingProperty i p] :
    HasLiftingProperty i' p := by
  rw [Arrow.iso_w' e]
  infer_instance
#align category_theory.has_lifting_property.of_arrow_iso_left CategoryTheory.HasLiftingProperty.of_arrow_iso_left

theorem of_arrow_iso_right {A B X Y X' Y' : C} (i : A ⟶ B) {p : X ⟶ Y} {p' : X' ⟶ Y'}
    (e : Arrow.mk p ≅ Arrow.mk p') [hip : HasLiftingProperty i p] : HasLiftingProperty i p' := by
  rw [Arrow.iso_w' e]
  infer_instance
#align category_theory.has_lifting_property.of_arrow_iso_right CategoryTheory.HasLiftingProperty.of_arrow_iso_right

theorem iff_of_arrow_iso_left {A B A' B' X Y : C} {i : A ⟶ B} {i' : A' ⟶ B'}
    (e : Arrow.mk i ≅ Arrow.mk i') (p : X ⟶ Y) : HasLiftingProperty i p ↔ HasLiftingProperty i' p :=
  by
  constructor <;> intro
  exacts[of_arrow_iso_left e p, of_arrow_iso_left e.symm p]
#align category_theory.has_lifting_property.iff_of_arrow_iso_left CategoryTheory.HasLiftingProperty.iff_of_arrow_iso_left

theorem iff_of_arrow_iso_right {A B X Y X' Y' : C} (i : A ⟶ B) {p : X ⟶ Y} {p' : X' ⟶ Y'}
    (e : Arrow.mk p ≅ Arrow.mk p') : HasLiftingProperty i p ↔ HasLiftingProperty i p' := by
  constructor <;> intro
  exacts[of_arrow_iso_right i e, of_arrow_iso_right i e.symm]
#align category_theory.has_lifting_property.iff_of_arrow_iso_right CategoryTheory.HasLiftingProperty.iff_of_arrow_iso_right

end HasLiftingProperty

end CategoryTheory


/-
Copyright © 2018 François G. Dorais. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
-/

import .basic

namespace fin

definition cases_zero_succ {n : ℕ} {C : fin (n+1) → Sort*} :
C (fin.zero n) → (Π i, C (fin.succ i)) → (Π i, C i)
| hz _ ⟨0,_⟩ := hz
| _ hs ⟨i+1,hi⟩ := hs ⟨i, nat.lt_of_succ_lt_succ hi⟩

@[simp] lemma cases_zero {n : ℕ} {C : fin (n+1) → Sort*} (h : C 0) (hs : Π i, C (fin.succ i)) :
cases_zero_succ h hs (fin.zero n) = h := rfl

@[simp] lemma cases_succ {n : ℕ} {C : fin (n+1) → Sort*} (h : C 0) (hs : Π i, C (fin.succ i)) :
∀ i, cases_zero_succ h hs (fin.succ i) = hs i | ⟨_,_⟩ := rfl

@[reducible] definition cases_zero_succ_on {n : ℕ} {C : fin (n+1) → Sort*} (i : fin (n+1)) :
C 0 → (Π i, C (fin.succ i)) → C i :=
λ hz hs, fin.cases_zero_succ hz hs i

definition rec_zero_succ {C : Π {n : ℕ}, fin n → Sort*} :
(Π n, C (fin.zero n)) → (Π {n : ℕ} (i : fin n), C i → C (fin.succ i)) → (Π {n : ℕ} (i : fin n), C i) :=
λ hz hs n, nat.rec_on n (λ i, fin.elim0 i) $
λ n ih, cases_zero_succ (hz n) (λ i, hs i (ih i))

@[simp] lemma rec_zero {C : Π {n : ℕ}, fin n → Sort*} (h : Π n, C (fin.zero n)) (hs : Π {n : ℕ} (i : fin n), C i → C (fin.succ i)) :
∀ (n : ℕ), rec_zero_succ h @hs (fin.zero n) = h n | _ := rfl

@[simp] lemma rec_succ {C : Π {n : ℕ}, fin n → Sort*} (h : Π n, C (fin.zero n)) (hs : Π {n : ℕ} (i : fin n), C i → C (fin.succ i)) :
∀ {n : ℕ} (i : fin n), rec_zero_succ h @hs (fin.succ i) = hs i (rec_zero_succ h @hs i) | _ ⟨_,_⟩ := rfl

@[reducible] definition rec_zero_succ_on {C : Π {n : ℕ}, fin n → Sort*} {n : ℕ} (i : fin n) :
(Π (n : ℕ), C (fin.zero n)) → (Π (n : ℕ) (i : fin n), C i → C (fin.succ i)) → C i :=
λ hz hs, rec_zero_succ hz hs i

definition cases_lift_last {n : ℕ} {C : fin (n+1) → Sort*} :
(Π i, C (fin.lift i)) → C (fin.last n) → (Π i, C i) :=
λ hl h ⟨i,hi⟩,
if hin : i = n then
have fin.mk i hi = fin.last n, from fin.eq_of_veq hin,
show C ⟨i,hi⟩, from eq.rec_on (eq.symm this) h
else
let j := fin.mk i (lt_of_le_of_ne (nat.le_of_lt_succ hi) hin) in
have fin.mk i hi = fin.lift j, from fin.eq_of_veq rfl,
show C ⟨i,hi⟩, from eq.rec_on (eq.symm this) (hl j)

@[simp] lemma cases_lift {n : ℕ} {C : fin (n+1) → Sort*} (hl : Π i, C (fin.lift i)) (h : C (fin.last n)) :
∀ i, cases_lift_last hl h (fin.lift i) = hl i | ⟨i,hi⟩ := dif_neg (ne_of_lt hi)

@[simp] lemma cases_last {n : ℕ} {C : fin (n+1) → Sort*} (hl : Π i, C (fin.lift i)) (h : C (fin.last n)) :
cases_lift_last hl h (fin.last n) = h := dif_pos rfl

@[reducible] definition cases_lift_last_on {n : ℕ} {C : fin (n+1) → Sort*} (i : fin (n+1)) :
(Π i, C (fin.lift i)) → C (fin.last n) → C i :=
λ hl h, fin.cases_lift_last hl h i

definition rec_lift_last {C : Π {n : ℕ}, fin n → Sort*} :
(Π {n : ℕ} (i : fin n), C i → C (fin.lift i)) → (Π n, C (fin.last n)) → (Π {n : ℕ} (i : fin n), C i) :=
λ hnl hn n, nat.rec_on n (λ i, fin.elim0 i) $
λ n ih, cases_lift_last (λ i, hnl i (ih i)) (hn n)

@[simp] lemma rec_lift {C : Π {n : ℕ}, fin n → Sort*} {hl : Π {n : ℕ} (i : fin n), C i → C (fin.lift i)} {h : Π n, C (fin.last n)} :
∀ {n : ℕ} (i : fin n), rec_lift_last @hl h (fin.lift i) = hl i (rec_lift_last @hl h i) | _ ⟨i,hi⟩ := dif_neg (ne_of_lt hi)

@[simp] lemma rec_last {C : Π {n : ℕ}, fin n → Sort*} {hl : Π {n : ℕ} (i : fin n), C i → C (fin.lift i)} {h : Π n, C (fin.last n)} :
∀ (n : ℕ), rec_lift_last @hl h (fin.last n) = h n | _ := dif_pos rfl

@[reducible] definition rec_lift_last_on {C : Π {n : ℕ}, fin n → Sort*} {n : ℕ} (i : fin n) :
(Π (n : ℕ) (i : fin n), C i → C (fin.lift i)) → (Π (n : ℕ), C (fin.last n)) → C i :=
λ hl h, rec_lift_last hl h i

end fin


inductive Tree (β : Type v) where
  | leaf
  | node (left : Tree β) (key : Nat) (value : β) (right : Tree β)
  deriving Repr

def Tree.find? (t : Tree β) (k : Nat) : Option β :=
  match t with
  | leaf => none
  | node left key value right =>
    if k < key then
      left.find? k
    else if key < k then
      right.find? k
    else
      some value

def Tree.insert (t : Tree β) (k : Nat) (v : β) : Tree β :=
  match t with
  | leaf => node leaf k v leaf
  | node left key value right =>
    if k < key then
      node (left.insert k v) key value right
    else if key < k then
      node left key value (right.insert k v)
    else
      node left k v right

inductive ForallTree (p : Nat → β → Prop) : Tree β → Prop
  | leaf : ForallTree p .leaf
  | node :
     ForallTree p left →
     p key value →
     ForallTree p right →
     ForallTree p (.node left key value right)

inductive BST : Tree β → Prop
  | leaf : BST .leaf
  | node :
     {value : β} →
     ForallTree (fun k v => k < key) left →
     ForallTree (fun k v => key < k) right →
     BST left → BST right →
     BST (.node left key value right)

def BinTree (β : Type u) := { t : Tree β // BST t }

def BinTree.mk : BinTree β :=
  ⟨.leaf, .leaf⟩

def BinTree.find? (b : BinTree β) (k : Nat) : Option β :=
  b.val.find? k

def BinTree.insert (b : BinTree β) (k : Nat) (v : β) : BinTree β :=
  ⟨b.val.insert k v, sorry⟩

attribute [local simp]
  BinTree.mk BinTree.find?
  BinTree.insert Tree.find? Tree.insert

theorem BinTree.find_insert (b : BinTree β) (k : Nat) (v : β)
        : (b.insert k v).find? k = some v := by
  let ⟨t, h⟩ := b; simp
  induction t with simp
  | node left key value right ihl ihr =>
    by_cases k < key <;> simp [*]
    . cases h; apply ihl; done
    . sorry


/-
Copyright (c) 2020 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Scott Morrison, Johan Commelin
-/

import linear_algebra.tensor_product_basis
import ring_theory.adjoin.basic

/-!
# The tensor product of R-algebras

Let `R` be a (semi)ring and `A` an `R`-algebra.
In this file we:

- Define the `A`-module structure on `A ⊗ M`, for an `R`-module `M`.
- Define the `R`-algebra structure on `A ⊗ B`, for another `R`-algebra `B`.
  and provide the structure isomorphisms
  * `R ⊗[R] A ≃ₐ[R] A`
  * `A ⊗[R] R ≃ₐ[R] A`
  * `A ⊗[R] B ≃ₐ[R] B ⊗[R] A`
  * `((A ⊗[R] B) ⊗[R] C) ≃ₐ[R] (A ⊗[R] (B ⊗[R] C))`

## Main declaration

- `linear_map.base_change A f` is the `A`-linear map `A ⊗ f`, for an `R`-linear map `f`.

## Implementation notes

The heterobasic definitions below such as:
 * `tensor_product.algebra_tensor_module.curry`
 * `tensor_product.algebra_tensor_module.uncurry`
 * `tensor_product.algebra_tensor_module.lcurry`
 * `tensor_product.algebra_tensor_module.lift`
 * `tensor_product.algebra_tensor_module.lift.equiv`
 * `tensor_product.algebra_tensor_module.mk`
 * `tensor_product.algebra_tensor_module.assoc`

are just more general versions of the definitions already in `linear_algebra/tensor_product`. We
could thus consider replacing the less general definitions with these ones. If we do this, we
probably should still implement the less general ones as abbreviations to the more general ones with
fewer type arguments.
-/

universes u v₁ v₂ v₃ v₄

open_locale tensor_product
open tensor_product

namespace tensor_product

variables {R A M N P : Type*}

/-!
### The `A`-module structure on `A ⊗[R] M`
-/

open linear_map
open algebra (lsmul)

namespace algebra_tensor_module

section semiring
variables [comm_semiring R] [semiring A] [algebra R A]
variables [add_comm_monoid M] [module R M] [module A M] [is_scalar_tower R A M]
variables [add_comm_monoid N] [module R N]
variables [add_comm_monoid P] [module R P] [module A P] [is_scalar_tower R A P]

lemma smul_eq_lsmul_rtensor (a : A) (x : M ⊗[R] N) : a • x = (lsmul R M a).rtensor N x := rfl

/-- Heterobasic version of `tensor_product.curry`:

Given a linear map `M ⊗[R] N →[A] P`, compose it with the canonical
bilinear map `M →[A] N →[R] M ⊗[R] N` to form a bilinear map `M →[A] N →[R] P`. -/
@[simps] def curry (f : (M ⊗[R] N) →ₗ[A] P) : M →ₗ[A] (N →ₗ[R] P) :=
{ map_smul' := λ c x, linear_map.ext $ λ y, f.map_smul c (x ⊗ₜ y),
  .. curry (f.restrict_scalars R) }

lemma restrict_scalars_curry (f : (M ⊗[R] N) →ₗ[A] P) :
  restrict_scalars R (curry f) = curry (f.restrict_scalars R) :=
rfl

/-- Just as `tensor_product.ext` is marked `ext` instead of `tensor_product.ext'`, this is
a better `ext` lemma than `tensor_product.algebra_tensor_module.ext` below.

See note [partially-applied ext lemmas]. -/
@[ext] lemma curry_injective :
  function.injective (curry : (M ⊗ N →ₗ[A] P) → (M →ₗ[A] N →ₗ[R] P)) :=
λ x y h, linear_map.restrict_scalars_injective R $ curry_injective $
  (congr_arg (linear_map.restrict_scalars R) h : _)

theorem ext {g h : (M ⊗[R] N) →ₗ[A] P}
  (H : ∀ x y, g (x ⊗ₜ y) = h (x ⊗ₜ y)) : g = h :=
curry_injective $ linear_map.ext₂ H

end semiring

section comm_semiring
variables [comm_semiring R] [comm_semiring A] [algebra R A]
variables [add_comm_monoid M] [module R M] [module A M] [is_scalar_tower R A M]
variables [add_comm_monoid N] [module R N]
variables [add_comm_monoid P] [module R P] [module A P] [is_scalar_tower R A P]

/-- Heterobasic version of `tensor_product.lift`:

Constructing a linear map `M ⊗[R] N →[A] P` given a bilinear map `M →[A] N →[R] P` with the
property that its composition with the canonical bilinear map `M →[A] N →[R] M ⊗[R] N` is
the given bilinear map `M →[A] N →[R] P`. -/
@[simps] def lift (f : M →ₗ[A] (N →ₗ[R] P)) : (M ⊗[R] N) →ₗ[A] P :=
{ map_smul' := λ c, show ∀ x : M ⊗[R] N, (lift (f.restrict_scalars R)).comp (lsmul R _ c) x =
      (lsmul R _ c).comp (lift (f.restrict_scalars R)) x,
    from ext_iff.1 $ tensor_product.ext' $ λ x y,
    by simp only [comp_apply, algebra.lsmul_coe, smul_tmul', lift.tmul, coe_restrict_scalars_eq_coe,
        f.map_smul, smul_apply],
  .. lift (f.restrict_scalars R) }

@[simp] lemma lift_tmul (f : M →ₗ[A] (N →ₗ[R] P)) (x : M) (y : N) :
  lift f (x ⊗ₜ y) = f x y :=
lift.tmul' x y

variables (R A M N P)
/-- Heterobasic version of `tensor_product.uncurry`:

Linearly constructing a linear map `M ⊗[R] N →[A] P` given a bilinear map `M →[A] N →[R] P`
with the property that its composition with the canonical bilinear map `M →[A] N →[R] M ⊗[R] N` is
the given bilinear map `M →[A] N →[R] P`. -/
@[simps] def uncurry : (M →ₗ[A] (N →ₗ[R] P)) →ₗ[A] ((M ⊗[R] N) →ₗ[A] P) :=
{ to_fun := lift,
  map_add' := λ f g, ext $ λ x y, by simp only [lift_tmul, add_apply],
  map_smul' := λ c f, ext $ λ x y, by simp only [lift_tmul, smul_apply, ring_hom.id_apply] }

/-- Heterobasic version of `tensor_product.lcurry`:

Given a linear map `M ⊗[R] N →[A] P`, compose it with the canonical
bilinear map `M →[A] N →[R] M ⊗[R] N` to form a bilinear map `M →[A] N →[R] P`. -/
@[simps] def lcurry : ((M ⊗[R] N) →ₗ[A] P) →ₗ[A] (M →ₗ[A] (N →ₗ[R] P)) :=
{ to_fun := curry,
  map_add' := λ f g, rfl,
  map_smul' := λ c f, rfl }

/-- Heterobasic version of `tensor_product.lift.equiv`:

A linear equivalence constructing a linear map `M ⊗[R] N →[A] P` given a
bilinear map `M →[A] N →[R] P` with the property that its composition with the
canonical bilinear map `M →[A] N →[R] M ⊗[R] N` is the given bilinear map `M →[A] N →[R] P`. -/
def lift.equiv : (M →ₗ[A] (N →ₗ[R] P)) ≃ₗ[A] ((M ⊗[R] N) →ₗ[A] P) :=
linear_equiv.of_linear (uncurry R A M N P) (lcurry R A M N P)
  (linear_map.ext $ λ f, ext $ λ x y, lift_tmul _ x y)
  (linear_map.ext $ λ f, linear_map.ext $ λ x, linear_map.ext $ λ y, lift_tmul f x y)

variables (R A M N P)
/-- Heterobasic version of `tensor_product.mk`:

The canonical bilinear map `M →[A] N →[R] M ⊗[R] N`. -/
@[simps] def mk : M →ₗ[A] N →ₗ[R] M ⊗[R] N :=
{ map_smul' := λ c x, rfl,
  .. mk R M N }

local attribute [ext] tensor_product.ext

/-- Heterobasic version of `tensor_product.assoc`:

Linear equivalence between `(M ⊗[A] N) ⊗[R] P` and `M ⊗[A] (N ⊗[R] P)`. -/
def assoc : ((M ⊗[A] P) ⊗[R] N) ≃ₗ[A] (M ⊗[A] (P ⊗[R] N)) :=
linear_equiv.of_linear
  (lift $ tensor_product.uncurry A _ _ _ $ comp (lcurry R A _ _ _) $
    tensor_product.mk A M (P ⊗[R] N))
  (tensor_product.uncurry A _ _ _ $ comp (uncurry R A _ _ _) $
    by { apply tensor_product.curry, exact (mk R A _ _) })
  (by { ext, refl, })
  (by { ext, simp only [curry_apply, tensor_product.curry_apply, mk_apply, tensor_product.mk_apply,
              uncurry_apply, tensor_product.uncurry_apply, id_apply, lift_tmul, compr₂_apply,
              restrict_scalars_apply, function.comp_app, to_fun_eq_coe, lcurry_apply,
              linear_map.comp_apply] })

end comm_semiring

end algebra_tensor_module

end tensor_product

namespace linear_map
open tensor_product

/-!
### The base-change of a linear map of `R`-modules to a linear map of `A`-modules
-/

section semiring

variables {R A B M N : Type*} [comm_semiring R]
variables [semiring A] [algebra R A] [semiring B] [algebra R B]
variables [add_comm_monoid M] [module R M] [add_comm_monoid N] [module R N]
variables (r : R) (f g : M →ₗ[R] N)

variables (A)

/-- `base_change A f` for `f : M →ₗ[R] N` is the `A`-linear map `A ⊗[R] M →ₗ[A] A ⊗[R] N`. -/
def base_change (f : M →ₗ[R] N) : A ⊗[R] M →ₗ[A] A ⊗[R] N :=
{ to_fun := f.ltensor A,
  map_add' := (f.ltensor A).map_add,
  map_smul' := λ a x,
    show (f.ltensor A) (rtensor M (algebra.lmul R A a) x) =
      (rtensor N ((algebra.lmul R A) a)) ((ltensor A f) x),
    by { rw [← comp_apply, ← comp_apply],
      simp only [ltensor_comp_rtensor, rtensor_comp_ltensor] } }

variables {A}

@[simp] lemma base_change_tmul (a : A) (x : M) :
  f.base_change A (a ⊗ₜ x) = a ⊗ₜ (f x) := rfl

lemma base_change_eq_ltensor :
  (f.base_change A : A ⊗ M → A ⊗ N) = f.ltensor A := rfl

@[simp] lemma base_change_add :
  (f + g).base_change A = f.base_change A + g.base_change A :=
by { ext, simp [base_change_eq_ltensor], }

@[simp] lemma base_change_zero : base_change A (0 : M →ₗ[R] N) = 0 :=
by { ext, simp [base_change_eq_ltensor], }

@[simp] lemma base_change_smul : (r • f).base_change A = r • (f.base_change A) :=
by { ext, simp [base_change_tmul], }

variables (R A M N)
/-- `base_change` as a linear map. -/
@[simps] def base_change_hom : (M →ₗ[R] N) →ₗ[R] A ⊗[R] M →ₗ[A] A ⊗[R] N :=
{ to_fun := base_change A,
  map_add' := base_change_add,
  map_smul' := base_change_smul }

end semiring

section ring

variables {R A B M N : Type*} [comm_ring R]
variables [ring A] [algebra R A] [ring B] [algebra R B]
variables [add_comm_group M] [module R M] [add_comm_group N] [module R N]
variables (f g : M →ₗ[R] N)

@[simp] lemma base_change_sub :
  (f - g).base_change A = f.base_change A - g.base_change A :=
by { ext, simp [base_change_eq_ltensor], }

@[simp] lemma base_change_neg : (-f).base_change A = -(f.base_change A) :=
by { ext, simp [base_change_eq_ltensor], }

end ring

end linear_map

namespace algebra
namespace tensor_product

section semiring

variables {R : Type u} [comm_semiring R]
variables {A : Type v₁} [semiring A] [algebra R A]
variables {B : Type v₂} [semiring B] [algebra R B]

/-!
### The `R`-algebra structure on `A ⊗[R] B`
-/

/--
(Implementation detail)
The multiplication map on `A ⊗[R] B`,
for a fixed pure tensor in the first argument,
as an `R`-linear map.
-/
def mul_aux (a₁ : A) (b₁ : B) : (A ⊗[R] B) →ₗ[R] (A ⊗[R] B) :=
tensor_product.map (lmul_left R a₁) (lmul_left R b₁)

@[simp]
lemma mul_aux_apply (a₁ a₂ : A) (b₁ b₂ : B) :
  (mul_aux a₁ b₁) (a₂ ⊗ₜ[R] b₂) = (a₁ * a₂) ⊗ₜ[R] (b₁ * b₂) :=
rfl

/--
(Implementation detail)
The multiplication map on `A ⊗[R] B`,
as an `R`-bilinear map.
-/
def mul : (A ⊗[R] B) →ₗ[R] (A ⊗[R] B) →ₗ[R] (A ⊗[R] B) :=
tensor_product.lift $ linear_map.mk₂ R mul_aux
  (λ x₁ x₂ y, tensor_product.ext' $ λ x' y',
    by simp only [mul_aux_apply, linear_map.add_apply, add_mul, add_tmul])
  (λ c x y, tensor_product.ext' $ λ x' y',
    by simp only [mul_aux_apply, linear_map.smul_apply, smul_tmul', smul_mul_assoc])
  (λ x y₁ y₂, tensor_product.ext' $ λ x' y',
    by simp only [mul_aux_apply, linear_map.add_apply, add_mul, tmul_add])
  (λ c x y, tensor_product.ext' $ λ x' y',
    by simp only [mul_aux_apply, linear_map.smul_apply, smul_tmul, smul_tmul', smul_mul_assoc])

@[simp]
lemma mul_apply (a₁ a₂ : A) (b₁ b₂ : B) :
  mul (a₁ ⊗ₜ[R] b₁) (a₂ ⊗ₜ[R] b₂) = (a₁ * a₂) ⊗ₜ[R] (b₁ * b₂) :=
rfl

lemma mul_assoc' (mul : (A ⊗[R] B) →ₗ[R] (A ⊗[R] B) →ₗ[R] (A ⊗[R] B))
  (h : ∀ (a₁ a₂ a₃ : A) (b₁ b₂ b₃ : B),
    mul (mul (a₁ ⊗ₜ[R] b₁) (a₂ ⊗ₜ[R] b₂)) (a₃ ⊗ₜ[R] b₃) =
      mul (a₁ ⊗ₜ[R] b₁) (mul (a₂ ⊗ₜ[R] b₂) (a₃ ⊗ₜ[R] b₃))) :
  ∀ (x y z : A ⊗[R] B), mul (mul x y) z = mul x (mul y z) :=
begin
  intros,
  apply tensor_product.induction_on x,
  { simp only [linear_map.map_zero, linear_map.zero_apply], },
  apply tensor_product.induction_on y,
  { simp only [linear_map.map_zero, forall_const, linear_map.zero_apply], },
  apply tensor_product.induction_on z,
  { simp only [linear_map.map_zero, forall_const], },
  { intros, simp only [h], },
  { intros, simp only [linear_map.map_add, *], },
  { intros, simp only [linear_map.map_add, *, linear_map.add_apply], },
  { intros, simp only [linear_map.map_add, *, linear_map.add_apply], },
end

lemma mul_assoc (x y z : A ⊗[R] B) : mul (mul x y) z = mul x (mul y z) :=
mul_assoc' mul (by { intros, simp only [mul_apply, mul_assoc], }) x y z

lemma one_mul (x : A ⊗[R] B) : mul (1 ⊗ₜ 1) x = x :=
begin
  apply tensor_product.induction_on x;
  simp {contextual := tt},
end

lemma mul_one (x : A ⊗[R] B) : mul x (1 ⊗ₜ 1) = x :=
begin
  apply tensor_product.induction_on x;
  simp {contextual := tt},
end

instance : semiring (A ⊗[R] B) :=
{ zero := 0,
  add := (+),
  one := 1 ⊗ₜ 1,
  mul := λ a b, mul a b,
  one_mul := one_mul,
  mul_one := mul_one,
  mul_assoc := mul_assoc,
  zero_mul := by simp,
  mul_zero := by simp,
  left_distrib := by simp,
  right_distrib := by simp,
  .. (by apply_instance : add_comm_monoid (A ⊗[R] B)) }.

lemma one_def : (1 : A ⊗[R] B) = (1 : A) ⊗ₜ (1 : B) := rfl

@[simp]
lemma tmul_mul_tmul (a₁ a₂ : A) (b₁ b₂ : B) :
  (a₁ ⊗ₜ[R] b₁) * (a₂ ⊗ₜ[R] b₂) = (a₁ * a₂) ⊗ₜ[R] (b₁ * b₂) :=
rfl

@[simp]
lemma tmul_pow (a : A) (b : B) (k : ℕ) :
  (a ⊗ₜ[R] b)^k = (a^k) ⊗ₜ[R] (b^k) :=
begin
  induction k with k ih,
  { simp [one_def], },
  { simp [pow_succ, ih], }
end

/--
The algebra map `R →+* (A ⊗[R] B)` giving `A ⊗[R] B` the structure of an `R`-algebra.
-/
def tensor_algebra_map : R →+* (A ⊗[R] B) :=
{ to_fun := λ r, algebra_map R A r ⊗ₜ[R] 1,
  map_one' := by { simp, refl },
  map_mul' := by simp,
  map_zero' := by simp [zero_tmul],
  map_add' := by simp [add_tmul], }

instance : algebra R (A ⊗[R] B) :=
{ commutes' := λ r x,
  begin
    apply tensor_product.induction_on x,
    { simp, },
    { intros a b, simp [tensor_algebra_map, algebra.commutes], },
    { intros y y' h h', simp at h h', simp [mul_add, add_mul, h, h'], },
  end,
  smul_def' := λ r x,
  begin
    apply tensor_product.induction_on x,
    { simp [smul_zero], },
    { intros a b,
      rw [tensor_algebra_map, ←tmul_smul, ←smul_tmul, algebra.smul_def r a],
      simp, },
    { intros, dsimp, simp [smul_add, mul_add, *], },
  end,
  .. tensor_algebra_map,
  .. (by apply_instance : module R (A ⊗[R] B)) }.

@[simp]
lemma algebra_map_apply (r : R) :
  (algebra_map R (A ⊗[R] B)) r = ((algebra_map R A) r) ⊗ₜ[R] 1 := rfl

variables {C : Type v₃} [semiring C] [algebra R C]

@[ext]
theorem ext {g h : (A ⊗[R] B) →ₐ[R] C}
  (H : ∀ a b, g (a ⊗ₜ b) = h (a ⊗ₜ b)) : g = h :=
begin
  apply @alg_hom.to_linear_map_injective R (A ⊗[R] B) C _ _ _ _ _ _ _ _,
  ext,
  simp [H],
end

/-- The algebra morphism `A →ₐ[R] A ⊗[R] B` sending `a` to `a ⊗ₜ 1`. -/
def include_left : A →ₐ[R] A ⊗[R] B :=
{ to_fun := λ a, a ⊗ₜ 1,
  map_zero' := by simp,
  map_add' := by simp [add_tmul],
  map_one' := rfl,
  map_mul' := by simp,
  commutes' := by simp, }

@[simp]
lemma include_left_apply (a : A) : (include_left : A →ₐ[R] A ⊗[R] B) a = a ⊗ₜ 1 := rfl

/-- The algebra morphism `B →ₐ[R] A ⊗[R] B` sending `b` to `1 ⊗ₜ b`. -/
def include_right : B →ₐ[R] A ⊗[R] B :=
{ to_fun := λ b, 1 ⊗ₜ b,
  map_zero' := by simp,
  map_add' := by simp [tmul_add],
  map_one' := rfl,
  map_mul' := by simp,
  commutes' := λ r,
  begin
    simp only [algebra_map_apply],
    transitivity r • ((1 : A) ⊗ₜ[R] (1 : B)),
    { rw [←tmul_smul, algebra.smul_def], simp, },
    { simp [algebra.smul_def], },
  end, }

@[simp]
lemma include_right_apply (b : B) : (include_right : B →ₐ[R] A ⊗[R] B) b = 1 ⊗ₜ b := rfl

end semiring

section ring

variables {R : Type u} [comm_ring R]
variables {A : Type v₁} [ring A] [algebra R A]
variables {B : Type v₂} [ring B] [algebra R B]

instance : ring (A ⊗[R] B) :=
{ .. (by apply_instance : add_comm_group (A ⊗[R] B)),
  .. (by apply_instance : semiring (A ⊗[R] B)) }.

end ring

section comm_ring

variables {R : Type u} [comm_ring R]
variables {A : Type v₁} [comm_ring A] [algebra R A]
variables {B : Type v₂} [comm_ring B] [algebra R B]

instance : comm_ring (A ⊗[R] B) :=
{ mul_comm := λ x y,
  begin
    apply tensor_product.induction_on x,
    { simp, },
    { intros a₁ b₁,
      apply tensor_product.induction_on y,
      { simp, },
      { intros a₂ b₂,
        simp [mul_comm], },
      { intros a₂ b₂ ha hb,
        simp [mul_add, add_mul, ha, hb], }, },
    { intros x₁ x₂ h₁ h₂,
      simp [mul_add, add_mul, h₁, h₂], },
  end
  .. (by apply_instance : ring (A ⊗[R] B)) }.

end comm_ring

/--
Verify that typeclass search finds the ring structure on `A ⊗[ℤ] B`
when `A` and `B` are merely rings, by treating both as `ℤ`-algebras.
-/
example {A : Type v₁} [ring A] {B : Type v₂} [ring B] : ring (A ⊗[ℤ] B) :=
by apply_instance

/--
Verify that typeclass search finds the comm_ring structure on `A ⊗[ℤ] B`
when `A` and `B` are merely comm_rings, by treating both as `ℤ`-algebras.
-/
example {A : Type v₁} [comm_ring A] {B : Type v₂} [comm_ring B] : comm_ring (A ⊗[ℤ] B) :=
by apply_instance

/-!
We now build the structure maps for the symmetric monoidal category of `R`-algebras.
-/
section monoidal

section
variables {R : Type u} [comm_semiring R]
variables {A : Type v₁} [semiring A] [algebra R A]
variables {B : Type v₂} [semiring B] [algebra R B]
variables {C : Type v₃} [semiring C] [algebra R C]
variables {D : Type v₄} [semiring D] [algebra R D]

/--
Build an algebra morphism from a linear map out of a tensor product,
and evidence of multiplicativity on pure tensors.
-/
def alg_hom_of_linear_map_tensor_product
  (f : A ⊗[R] B →ₗ[R] C)
  (w₁ : ∀ (a₁ a₂ : A) (b₁ b₂ : B), f ((a₁ * a₂) ⊗ₜ (b₁ * b₂)) = f (a₁ ⊗ₜ b₁) * f (a₂ ⊗ₜ b₂))
  (w₂ : ∀ r, f ((algebra_map R A) r ⊗ₜ[R] 1) = (algebra_map R C) r):
  A ⊗[R] B →ₐ[R] C :=
{ map_one' := by rw [←(algebra_map R C).map_one, ←w₂, (algebra_map R A).map_one]; refl,
  map_zero' := by rw [linear_map.to_fun_eq_coe, map_zero],
  map_mul' := λ x y, by
  { rw linear_map.to_fun_eq_coe,
    apply tensor_product.induction_on x,
    { rw [zero_mul, map_zero, zero_mul] },
    { intros a₁ b₁,
      apply tensor_product.induction_on y,
      { rw [mul_zero, map_zero, mul_zero] },
      { intros a₂ b₂,
        rw [tmul_mul_tmul, w₁] },
      { intros x₁ x₂ h₁ h₂,
        rw [mul_add, map_add, map_add, mul_add, h₁, h₂] } },
    { intros x₁ x₂ h₁ h₂,
      rw [add_mul, map_add, map_add, add_mul, h₁, h₂] } },
  commutes' := λ r, by rw [linear_map.to_fun_eq_coe, algebra_map_apply, w₂],
  .. f }

@[simp]
lemma alg_hom_of_linear_map_tensor_product_apply (f w₁ w₂ x) :
  (alg_hom_of_linear_map_tensor_product f w₁ w₂ : A ⊗[R] B →ₐ[R] C) x = f x := rfl

/--
Build an algebra equivalence from a linear equivalence out of a tensor product,
and evidence of multiplicativity on pure tensors.
-/
def alg_equiv_of_linear_equiv_tensor_product
  (f : A ⊗[R] B ≃ₗ[R] C)
  (w₁ : ∀ (a₁ a₂ : A) (b₁ b₂ : B), f ((a₁ * a₂) ⊗ₜ (b₁ * b₂)) = f (a₁ ⊗ₜ b₁) * f (a₂ ⊗ₜ b₂))
  (w₂ : ∀ r, f ((algebra_map R A) r ⊗ₜ[R] 1) = (algebra_map R C) r):
  A ⊗[R] B ≃ₐ[R] C :=
{ .. alg_hom_of_linear_map_tensor_product (f : A ⊗[R] B →ₗ[R] C) w₁ w₂,
  .. f }

@[simp]
lemma alg_equiv_of_linear_equiv_tensor_product_apply (f w₁ w₂ x) :
  (alg_equiv_of_linear_equiv_tensor_product f w₁ w₂ : A ⊗[R] B ≃ₐ[R] C) x = f x := rfl

/--
Build an algebra equivalence from a linear equivalence out of a triple tensor product,
and evidence of multiplicativity on pure tensors.
-/
def alg_equiv_of_linear_equiv_triple_tensor_product
  (f : ((A ⊗[R] B) ⊗[R] C) ≃ₗ[R] D)
  (w₁ : ∀ (a₁ a₂ : A) (b₁ b₂ : B) (c₁ c₂ : C),
    f ((a₁ * a₂) ⊗ₜ (b₁ * b₂) ⊗ₜ (c₁ * c₂)) = f (a₁ ⊗ₜ b₁ ⊗ₜ c₁) * f (a₂ ⊗ₜ b₂ ⊗ₜ c₂))
  (w₂ : ∀ r, f (((algebra_map R A) r ⊗ₜ[R] (1 : B)) ⊗ₜ[R] (1 : C)) = (algebra_map R D) r) :
  (A ⊗[R] B) ⊗[R] C ≃ₐ[R] D :=
{ to_fun := f,
  map_mul' := λ x y,
  begin
    apply tensor_product.induction_on x,
    { simp only [map_zero, zero_mul] },
    { intros ab₁ c₁,
      apply tensor_product.induction_on y,
      { simp only [map_zero, mul_zero] },
      { intros ab₂ c₂,
        apply tensor_product.induction_on ab₁,
        { simp only [zero_tmul, map_zero, zero_mul] },
        { intros a₁ b₁,
          apply tensor_product.induction_on ab₂,
          { simp only [zero_tmul, map_zero, mul_zero] },
          { intros, simp only [tmul_mul_tmul, w₁] },
          { intros x₁ x₂ h₁ h₂,
            simp only [tmul_mul_tmul] at h₁ h₂,
            simp only [tmul_mul_tmul, mul_add, add_tmul, map_add, h₁, h₂] } },
        { intros x₁ x₂ h₁ h₂,
          simp only [tmul_mul_tmul] at h₁ h₂,
          simp only [tmul_mul_tmul, add_mul, add_tmul, map_add, h₁, h₂] } },
      { intros x₁ x₂ h₁ h₂,
        simp only [tmul_mul_tmul, map_add, mul_add, add_mul, h₁, h₂], }, },
    { intros x₁ x₂ h₁ h₂,
      simp only [tmul_mul_tmul, map_add, mul_add, add_mul, h₁, h₂], }
  end,
  commutes' := λ r, by simp [w₂],
  .. f }

@[simp]
lemma alg_equiv_of_linear_equiv_triple_tensor_product_apply (f w₁ w₂ x) :
  (alg_equiv_of_linear_equiv_triple_tensor_product f w₁ w₂ : (A ⊗[R] B) ⊗[R] C ≃ₐ[R] D) x = f x :=
rfl

end

variables {R : Type u} [comm_semiring R]
variables {A : Type v₁} [semiring A] [algebra R A]
variables {B : Type v₂} [semiring B] [algebra R B]
variables {C : Type v₃} [semiring C] [algebra R C]
variables {D : Type v₄} [semiring D] [algebra R D]

section
variables (R A)
/--
The base ring is a left identity for the tensor product of algebra, up to algebra isomorphism.
-/
protected def lid : R ⊗[R] A ≃ₐ[R] A :=
alg_equiv_of_linear_equiv_tensor_product (tensor_product.lid R A)
(by simp [mul_smul]) (by simp [algebra.smul_def])

@[simp]

/--
The base ring is a right identity for the tensor product of algebra, up to algebra isomorphism.
-/
protected def rid : A ⊗[R] R ≃ₐ[R] A :=
alg_equiv_of_linear_equiv_tensor_product (tensor_product.rid R A)
(by simp [mul_smul]) (by simp [algebra.smul_def])

@[simp] theorem rid_tmul (r : R) (a : A) :
  (tensor_product.rid R A : (A ⊗ R → A)) (a ⊗ₜ r) = r • a :=
by simp [tensor_product.rid]

section
variables (R A B)

/--
The tensor product of R-algebras is commutative, up to algebra isomorphism.
-/
protected def comm : A ⊗[R] B ≃ₐ[R] B ⊗[R] A :=
alg_equiv_of_linear_equiv_tensor_product (tensor_product.comm R A B)
(by simp)
(λ r, begin
  transitivity r • ((1 : B) ⊗ₜ[R] (1 : A)),
  { rw [←tmul_smul, algebra.smul_def], simp, },
  { simp [algebra.smul_def], },
end)

@[simp]
theorem comm_tmul (a : A) (b : B) :
  (tensor_product.comm R A B : (A ⊗[R] B → B ⊗[R] A)) (a ⊗ₜ b) = (b ⊗ₜ a) :=
by simp [tensor_product.comm]

lemma adjoin_tmul_eq_top : adjoin R {t : A ⊗[R] B | ∃ a b, a ⊗ₜ[R] b = t} = ⊤ :=
top_le_iff.mp $ (top_le_iff.mpr $ span_tmul_eq_top R A B).trans (span_le_adjoin R _)

end

section
variables {R A B C}

lemma assoc_aux_1 (a₁ a₂ : A) (b₁ b₂ : B) (c₁ c₂ : C) :
  (tensor_product.assoc R A B C) (((a₁ * a₂) ⊗ₜ[R] (b₁ * b₂)) ⊗ₜ[R] (c₁ * c₂)) =
    (tensor_product.assoc R A B C) ((a₁ ⊗ₜ[R] b₁) ⊗ₜ[R] c₁) *
      (tensor_product.assoc R A B C) ((a₂ ⊗ₜ[R] b₂) ⊗ₜ[R] c₂) :=
rfl

lemma assoc_aux_2 (r : R) :
  (tensor_product.assoc R A B C) (((algebra_map R A) r ⊗ₜ[R] 1) ⊗ₜ[R] 1) =
    (algebra_map R (A ⊗ (B ⊗ C))) r := rfl

-- variables (R A B C)

-- -- local attribute [elab_simple] alg_equiv_of_linear_equiv_triple_tensor_product

-- /-- The associator for tensor product of R-algebras, as an algebra isomorphism. -/
-- -- FIXME This is _really_ slow to compile. :-(
-- protected def assoc : ((A ⊗[R] B) ⊗[R] C) ≃ₐ[R] (A ⊗[R] (B ⊗[R] C)) :=
-- alg_equiv_of_linear_equiv_triple_tensor_product
--   (tensor_product.assoc R A B C)
--   assoc_aux_1 assoc_aux_2

-- variables {R A B C}

-- @[simp] theorem assoc_tmul (a : A) (b : B) (c : C) :
--   ((tensor_product.assoc R A B C) :
--   (A ⊗[R] B) ⊗[R] C → A ⊗[R] (B ⊗[R] C)) ((a ⊗ₜ b) ⊗ₜ c) = a ⊗ₜ (b ⊗ₜ c) :=
-- rfl

end

variables {R A B C D}

/-- The tensor product of a pair of algebra morphisms. -/
def map (f : A →ₐ[R] B) (g : C →ₐ[R] D) : A ⊗[R] C →ₐ[R] B ⊗[R] D :=
alg_hom_of_linear_map_tensor_product
  (tensor_product.map f.to_linear_map g.to_linear_map)
  (by simp)
  (by simp [alg_hom.commutes])

@[simp] theorem map_tmul (f : A →ₐ[R] B) (g : C →ₐ[R] D) (a : A) (c : C) :
  map f g (a ⊗ₜ c) = f a ⊗ₜ g c :=
rfl

@[simp] lemma map_comp_include_left (f : A →ₐ[R] B) (g : C →ₐ[R] D) :
  (map f g).comp include_left = include_left.comp f := alg_hom.ext $ by simp

@[simp] lemma map_comp_include_right (f : A →ₐ[R] B) (g : C →ₐ[R] D) :
  (map f g).comp include_right = include_right.comp g := alg_hom.ext $ by simp

lemma map_range (f : A →ₐ[R] B) (g : C →ₐ[R] D) :
  (map f g).range = (include_left.comp f).range ⊔ (include_right.comp g).range :=
begin
  apply le_antisymm,
  { rw [←map_top, ←adjoin_tmul_eq_top, ←adjoin_image, adjoin_le_iff],
    rintros _ ⟨_, ⟨a, b, rfl⟩, rfl⟩,
    rw [map_tmul, ←_root_.mul_one (f a), ←_root_.one_mul (g b), ←tmul_mul_tmul],
    exact mul_mem_sup (alg_hom.mem_range_self _ a) (alg_hom.mem_range_self _ b) },
  { rw [←map_comp_include_left f g, ←map_comp_include_right f g],
    exact sup_le (alg_hom.range_comp_le_range _ _) (alg_hom.range_comp_le_range _ _) },
end

/--
Construct an isomorphism between tensor products of R-algebras
from isomorphisms between the tensor factors.
-/
def congr (f : A ≃ₐ[R] B) (g : C ≃ₐ[R] D) : A ⊗[R] C ≃ₐ[R] B ⊗[R] D :=
alg_equiv.of_alg_hom (map f g) (map f.symm g.symm)
  (ext $ λ b d, by simp)
  (ext $ λ a c, by simp)

@[simp]
lemma congr_apply (f : A ≃ₐ[R] B) (g : C ≃ₐ[R] D) (x) :
  congr f g x = (map (f : A →ₐ[R] B) (g : C →ₐ[R] D)) x := rfl

@[simp]
lemma congr_symm_apply (f : A ≃ₐ[R] B) (g : C ≃ₐ[R] D) (x) :
  (congr f g).symm x = (map (f.symm : B →ₐ[R] A) (g.symm : D →ₐ[R] C)) x := rfl

end

end monoidal

section

variables {R A B S : Type*} [comm_semiring R] [semiring A] [semiring B] [comm_semiring S]
variables [algebra R A] [algebra R B] [algebra R S]
variables (f : A →ₐ[R] S) (g : B →ₐ[R] S)

variables (R)

/-- `algebra.lmul'` is an alg_hom on commutative rings. -/
def lmul' : S ⊗[R] S →ₐ[R] S :=
alg_hom_of_linear_map_tensor_product (algebra.lmul' R)
  (λ a₁ a₂ b₁ b₂, by simp only [algebra.lmul'_apply, mul_mul_mul_comm])
  (λ r, by simp only [algebra.lmul'_apply, _root_.mul_one])

variables {R}

lemma lmul'_to_linear_map : (lmul' R : _ →ₐ[R] S).to_linear_map = algebra.lmul' R := rfl

@[simp] lemma lmul'_apply_tmul (a b : S) : lmul' R (a ⊗ₜ[R] b) = a * b := lmul'_apply

@[simp]
lemma lmul'_comp_include_left : (lmul' R : _ →ₐ[R] S).comp include_left = alg_hom.id R S :=
alg_hom.ext $ λ _, (lmul'_apply_tmul _ _).trans (_root_.mul_one _)

@[simp]
lemma lmul'_comp_include_right : (lmul' R : _ →ₐ[R] S).comp include_right = alg_hom.id R S :=
alg_hom.ext $ λ _, (lmul'_apply_tmul _ _).trans (_root_.one_mul _)

/--
If `S` is commutative, for a pair of morphisms `f : A →ₐ[R] S`, `g : B →ₐ[R] S`,
We obtain a map `A ⊗[R] B →ₐ[R] S` that commutes with `f`, `g` via `a ⊗ b ↦ f(a) * g(b)`.
-/
def product_map : A ⊗[R] B →ₐ[R] S := (lmul' R).comp (tensor_product.map f g)

@[simp] lemma product_map_apply_tmul (a : A) (b : B) : product_map f g (a ⊗ₜ b) = f a * g b :=
by { unfold product_map lmul', simp }

lemma product_map_left_apply (a : A) : product_map f g (include_left a) = f a := by simp

@[simp] lemma product_map_left : (product_map f g).comp include_left = f := alg_hom.ext $ by simp

lemma product_map_right_apply (b : B) : product_map f g (include_right b) = g b := by simp

@[simp] lemma product_map_right : (product_map f g).comp include_right = g := alg_hom.ext $ by simp

lemma product_map_range : (product_map f g).range = f.range ⊔ g.range :=
by rw [product_map, alg_hom.range_comp, map_range, map_sup, ←alg_hom.range_comp,
    ←alg_hom.range_comp, ←alg_hom.comp_assoc, ←alg_hom.comp_assoc, lmul'_comp_include_left,
    lmul'_comp_include_right, alg_hom.id_comp, alg_hom.id_comp]

end
end tensor_product
end algebra

lemma subalgebra.finite_dimensional_sup {K L : Type*} [field K] [comm_ring L] [algebra K L]
  (E1 E2 : subalgebra K L) [finite_dimensional K E1] [finite_dimensional K E2] :
  finite_dimensional K ↥(E1 ⊔ E2) :=
begin
  rw [←E1.range_val, ←E2.range_val, ←algebra.tensor_product.product_map_range],
  exact (algebra.tensor_product.product_map E1.val E2.val).to_linear_map.finite_dimensional_range,
end