/-
Copyright (c) 2017 Johannes Hölzl. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Johannes Hölzl, Yury G. Kudryashov, Scott Morrison
-/
import algebra.big_operators.finsupp
import algebra.hom.non_unital_alg
import linear_algebra.finsupp

/-!
# Monoid algebras

When the domain of a `finsupp` has a multiplicative or additive structure, we can define
a convolution product. To mathematicians this structure is known as the "monoid algebra",
i.e. the finite formal linear combinations over a given semiring of elements of the monoid.
The "group ring" ℤ[G] or the "group algebra" k[G] are typical uses.

In fact the construction of the "monoid algebra" makes sense when `G` is not even a monoid, but
merely a magma, i.e., when `G` carries a multiplication which is not required to satisfy any
conditions at all. In this case the construction yields a not-necessarily-unital,
not-necessarily-associative algebra but it is still adjoint to the forgetful functor from such
algebras to magmas, and we prove this as `monoid_algebra.lift_magma`.

In this file we define `monoid_algebra k G := G →₀ k`, and `add_monoid_algebra k G`
in the same way, and then define the convolution product on these.

When the domain is additive, this is used to define polynomials:
```
polynomial α := add_monoid_algebra ℕ α
mv_polynomial σ α := add_monoid_algebra (σ →₀ ℕ) α
```

When the domain is multiplicative, e.g. a group, this will be used to define the group ring.

## Implementation note
Unfortunately because additive and multiplicative structures both appear in both cases,
it doesn't appear to be possible to make much use of `to_additive`, and we just settle for
saying everything twice.

Similarly, I attempted to just define
`add_monoid_algebra k G := monoid_algebra k (multiplicative G)`, but the definitional equality
`multiplicative G = G` leaks through everywhere, and seems impossible to use.
-/

noncomputable theory
open_locale big_operators

open finset finsupp

universes u₁ u₂ u₃
variables (k : Type u₁) (G : Type u₂) {R : Type*}

/-! ### Multiplicative monoids -/
section
variables [semiring k]

/--
The monoid algebra over a semiring `k` generated by the monoid `G`.
It is the type of finite formal `k`-linear combinations of terms of `G`,
endowed with the convolution product.
-/
@[derive [inhabited, add_comm_monoid]]
def monoid_algebra : Type (max u₁ u₂) := G →₀ k

instance : has_coe_to_fun (monoid_algebra k G) (λ _, G → k) :=
finsupp.has_coe_to_fun

end

namespace monoid_algebra

variables {k G}

section
variables [semiring k] [non_unital_non_assoc_semiring R]

/-- A non-commutative version of `monoid_algebra.lift`: given a additive homomorphism `f : k →+ R`
and a homomorphism `g : G → R`, returns the additive homomorphism from
`monoid_algebra k G` such that `lift_nc f g (single a b) = f b * g a`. If `f` is a ring homomorphism
and the range of either `f` or `g` is in center of `R`, then the result is a ring homomorphism.  If
`R` is a `k`-algebra and `f = algebra_map k R`, then the result is an algebra homomorphism called
`monoid_algebra.lift`. -/
def lift_nc (f : k →+ R) (g : G → R) : monoid_algebra k G →+ R :=
lift_add_hom (λ x : G, (add_monoid_hom.mul_right (g x)).comp f)

@[simp] lemma lift_nc_single (f : k →+ R) (g : G → R) (a : G) (b : k) :
  lift_nc f g (single a b) = f b * g a :=
lift_add_hom_apply_single _ _ _

end

section has_mul

variables [semiring k] [has_mul G]

/-- The product of `f g : monoid_algebra k G` is the finitely supported function
  whose value at `a` is the sum of `f x * g y` over all pairs `x, y`
  such that `x * y = a`. (Think of the group ring of a group.) -/
instance : has_mul (monoid_algebra k G) :=
⟨λf g, f.sum $ λa₁ b₁, g.sum $ λa₂ b₂, single (a₁ * a₂) (b₁ * b₂)⟩

lemma mul_def {f g : monoid_algebra k G} :
  f * g = (f.sum $ λa₁ b₁, g.sum $ λa₂ b₂, single (a₁ * a₂) (b₁ * b₂)) :=
rfl

instance : non_unital_non_assoc_semiring (monoid_algebra k G) :=
{ zero          := 0,
  mul           := (*),
  add           := (+),
  left_distrib  := assume f g h, by simp only [mul_def, sum_add_index, mul_add, mul_zero,
    single_zero, single_add, eq_self_iff_true, forall_true_iff, forall_3_true_iff, sum_add],
  right_distrib := assume f g h, by simp only [mul_def, sum_add_index, add_mul, zero_mul,
    single_zero, single_add, eq_self_iff_true, forall_true_iff, forall_3_true_iff, sum_zero,
    sum_add],
  zero_mul  := assume f, by simp only [mul_def, sum_zero_index],
  mul_zero  := assume f, by simp only [mul_def, sum_zero_index, sum_zero],
  .. finsupp.add_comm_monoid }

variables [semiring R]

lemma lift_nc_mul {g_hom : Type*} [mul_hom_class g_hom G R] (f : k →+* R) (g : g_hom)
  (a b : monoid_algebra k G) (h_comm : ∀ {x y}, y ∈ a.support → commute (f (b x)) (g y)) :
  lift_nc (f : k →+ R) g (a * b) = lift_nc (f : k →+ R) g a * lift_nc (f : k →+ R) g b :=
begin
  conv_rhs { rw [← sum_single a, ← sum_single b] },
  simp_rw [mul_def, (lift_nc _ g).map_finsupp_sum, lift_nc_single, finsupp.sum_mul,
    finsupp.mul_sum],
  refine finset.sum_congr rfl (λ y hy, finset.sum_congr rfl (λ x hx, _)),
  simp [mul_assoc, (h_comm hy).left_comm]
end

end has_mul

section semigroup

variables [semiring k] [semigroup G] [semiring R]

instance : non_unital_semiring (monoid_algebra k G) :=
{ zero          := 0,
  mul           := (*),
  add           := (+),
  mul_assoc := assume f g h, by simp only [mul_def, sum_sum_index, sum_zero_index, sum_add_index,
    sum_single_index, single_zero, single_add, eq_self_iff_true, forall_true_iff, forall_3_true_iff,
    add_mul, mul_add, add_assoc, mul_assoc, zero_mul, mul_zero, sum_zero, sum_add],
  .. monoid_algebra.non_unital_non_assoc_semiring}

end semigroup

section has_one

variables [non_assoc_semiring R] [semiring k] [has_one G]

/-- The unit of the multiplication is `single 1 1`, i.e. the function
  that is `1` at `1` and zero elsewhere. -/
instance : has_one (monoid_algebra k G) :=
⟨single 1 1⟩

lemma one_def : (1 : monoid_algebra k G) = single 1 1 :=
rfl

@[simp] lemma lift_nc_one {g_hom : Type*} [one_hom_class g_hom G R] (f : k →+* R) (g : g_hom) :
  lift_nc (f : k →+ R) g 1 = 1 :=

by simp [one_def]

end has_one

section mul_one_class

variables [semiring k] [mul_one_class G]

instance : non_assoc_semiring (monoid_algebra k G) :=
{ one       := 1,
  mul       := (*),
  zero      := 0,
  add       := (+),
  nat_cast  := λ n, single 1 n,
  nat_cast_zero := by simp [nat.cast],
  nat_cast_succ := λ _, by simp [nat.cast]; refl,
  one_mul   := assume f, by simp only [mul_def, one_def, sum_single_index, zero_mul,
    single_zero, sum_zero, zero_add, one_mul, sum_single],
  mul_one   := assume f, by simp only [mul_def, one_def, sum_single_index, mul_zero,
    single_zero, sum_zero, add_zero, mul_one, sum_single],
  ..monoid_algebra.non_unital_non_assoc_semiring }

end mul_one_class

/-! #### Semiring structure -/
section semiring

variables [semiring k] [monoid G]

instance : semiring (monoid_algebra k G) :=
{ one       := 1,
  mul       := (*),
  zero      := 0,
  add       := (+),
  .. monoid_algebra.non_unital_semiring,
  .. monoid_algebra.non_assoc_semiring }

variables [semiring R]

/-- `lift_nc` as a `ring_hom`, for when `f x` and `g y` commute -/
def lift_nc_ring_hom (f : k →+* R) (g : G →* R) (h_comm : ∀ x y, commute (f x) (g y)) :
  monoid_algebra k G →+* R :=
{ to_fun := lift_nc (f : k →+ R) g,
  map_one' := lift_nc_one _ _,
  map_mul' := λ a b, lift_nc_mul _ _ _ _ $ λ _ _ _, h_comm _ _,
  ..(lift_nc (f : k →+ R) g)}

end semiring

instance [comm_semiring k] [comm_semigroup G] : non_unital_comm_semiring (monoid_algebra k G) :=
{ mul_comm := assume f g,
  begin
    simp only [mul_def, finsupp.sum, mul_comm],
    rw [finset.sum_comm],
    simp only [mul_comm]
  end,
  .. monoid_algebra.non_unital_semiring }

instance [semiring k] [nontrivial k] [nonempty G]: nontrivial (monoid_algebra k G) :=
finsupp.nontrivial

/-! #### Derived instances -/
section derived_instances

instance [comm_semiring k] [comm_monoid G] : comm_semiring (monoid_algebra k G) :=
{ .. monoid_algebra.non_unital_comm_semiring,
  .. monoid_algebra.semiring }

instance [semiring k] [subsingleton k] : unique (monoid_algebra k G) :=
finsupp.unique_of_right

instance [ring k] : add_comm_group (monoid_algebra k G) :=
finsupp.add_comm_group

instance [ring k] [has_mul G] : non_unital_non_assoc_ring (monoid_algebra k G) :=
{ .. monoid_algebra.add_comm_group,
  .. monoid_algebra.non_unital_non_assoc_semiring }

instance [ring k] [semigroup G] : non_unital_ring (monoid_algebra k G) :=
{ .. monoid_algebra.add_comm_group,
  .. monoid_algebra.non_unital_semiring }

instance [ring k] [mul_one_class G] : non_assoc_ring (monoid_algebra k G) :=
{ .. monoid_algebra.add_comm_group,
  .. monoid_algebra.non_assoc_semiring }

instance [ring k] [monoid G] : ring (monoid_algebra k G) :=
{ .. monoid_algebra.non_unital_non_assoc_ring,
  .. monoid_algebra.semiring }

instance [comm_ring k] [comm_semigroup G] : non_unital_comm_ring (monoid_algebra k G) :=
{ .. monoid_algebra.non_unital_comm_semiring,
  .. monoid_algebra.non_unital_ring }

instance [comm_ring k] [comm_monoid G] : comm_ring (monoid_algebra k G) :=
{ .. monoid_algebra.non_unital_comm_ring,
  .. monoid_algebra.ring }

variables {S : Type*}

instance [monoid R] [semiring k] [distrib_mul_action R k] :
  has_scalar R (monoid_algebra k G) :=
finsupp.has_scalar

instance [monoid R] [semiring k] [distrib_mul_action R k] :
  distrib_mul_action R (monoid_algebra k G) :=
finsupp.distrib_mul_action G k

instance [semiring R] [semiring k] [module R k] :
  module R (monoid_algebra k G) :=
finsupp.module G k

instance [monoid R] [semiring k] [distrib_mul_action R k] [has_faithful_smul R k] [nonempty G] :
  has_faithful_smul R (monoid_algebra k G) :=
finsupp.has_faithful_smul

instance [monoid R] [monoid S] [semiring k] [distrib_mul_action R k] [distrib_mul_action S k]
  [has_scalar R S] [is_scalar_tower R S k] :
  is_scalar_tower R S (monoid_algebra k G) :=
finsupp.is_scalar_tower G k

instance [monoid R] [monoid S] [semiring k] [distrib_mul_action R k] [distrib_mul_action S k]
  [smul_comm_class R S k] :
  smul_comm_class R S (monoid_algebra k G) :=
finsupp.smul_comm_class G k

instance [monoid R] [semiring k] [distrib_mul_action R k] [distrib_mul_action Rᵐᵒᵖ k]
  [is_central_scalar R k] :
  is_central_scalar R (monoid_algebra k G) :=
finsupp.is_central_scalar G k

/-- This is not an instance as it conflicts with `monoid_algebra.distrib_mul_action` when `G = kˣ`.
-/
def comap_distrib_mul_action_self [group G] [semiring k] :
  distrib_mul_action G (monoid_algebra k G) :=
finsupp.comap_distrib_mul_action

end derived_instances

section misc_theorems

variables [semiring k]
local attribute [reducible] monoid_algebra

lemma mul_apply [decidable_eq G] [has_mul G] (f g : monoid_algebra k G) (x : G) :
  (f * g) x = (f.sum $ λa₁ b₁, g.sum $ λa₂ b₂, if a₁ * a₂ = x then b₁ * b₂ else 0) :=
begin
  rw [mul_def],
  simp only [finsupp.sum_apply, single_apply],
end

lemma mul_apply_antidiagonal [has_mul G] (f g : monoid_algebra k G) (x : G) (s : finset (G × G))
  (hs : ∀ {p : G × G}, p ∈ s ↔ p.1 * p.2 = x) :
  (f * g) x = ∑ p in s, (f p.1 * g p.2) :=
let F : G × G → k := λ p, by classical; exact if p.1 * p.2 = x then f p.1 * g p.2 else 0 in
calc (f * g) x = (∑ a₁ in f.support, ∑ a₂ in g.support, F (a₁, a₂)) :
  mul_apply f g x
... = ∑ p in f.support.product g.support, F p : finset.sum_product.symm
... = ∑ p in (f.support.product g.support).filter (λ p : G × G, p.1 * p.2 = x), f p.1 * g p.2 :
  (finset.sum_filter _ _).symm
... = ∑ p in s.filter (λ p : G × G, p.1 ∈ f.support ∧ p.2 ∈ g.support), f p.1 * g p.2 :
  sum_congr (by { ext, simp only [mem_filter, mem_product, hs, and_comm] }) (λ _ _, rfl)
... = ∑ p in s, f p.1 * g p.2 : sum_subset (filter_subset _ _) $ λ p hps hp,
  begin
    simp only [mem_filter, mem_support_iff, not_and, not_not] at hp ⊢,
    by_cases h1 : f p.1 = 0,
    { rw [h1, zero_mul] },
    { rw [hp hps h1, mul_zero] }
  end

lemma support_mul [has_mul G] [decidable_eq G] (a b : monoid_algebra k G) :
  (a * b).support ⊆ a.support.bUnion (λa₁, b.support.bUnion $ λa₂, {a₁ * a₂}) :=
subset.trans support_sum $ bUnion_mono $ assume a₁ _,
  subset.trans support_sum $ bUnion_mono $ assume a₂ _, support_single_subset

@[simp] lemma single_mul_single [has_mul G] {a₁ a₂ : G} {b₁ b₂ : k} :
  (single a₁ b₁ : monoid_algebra k G) * single a₂ b₂ = single (a₁ * a₂) (b₁ * b₂) :=
(sum_single_index (by simp only [zero_mul, single_zero, sum_zero])).trans
  (sum_single_index (by rw [mul_zero, single_zero]))

@[simp] lemma single_pow [monoid G] {a : G} {b : k} :
  ∀ n : ℕ, (single a b : monoid_algebra k G)^n = single (a^n) (b ^ n)
| 0 := by { simp only [pow_zero], refl }
| (n+1) := by simp only [pow_succ, single_pow n, single_mul_single]

section

/-- Like `finsupp.map_domain_zero`, but for the `1` we define in this file -/
@[simp] lemma map_domain_one {α : Type*} {β : Type*} {α₂ : Type*}
  [semiring β] [has_one α] [has_one α₂] {F : Type*} [one_hom_class F α α₂] (f : F) :
  (map_domain f (1 : monoid_algebra β α) : monoid_algebra β α₂) = (1 : monoid_algebra β α₂) :=
by simp_rw [one_def, map_domain_single, map_one]

/-- Like `finsupp.map_domain_add`, but for the convolutive multiplication we define in this file -/
lemma map_domain_mul {α : Type*} {β : Type*} {α₂ : Type*} [semiring β] [has_mul α] [has_mul α₂]
  {F : Type*} [mul_hom_class F α α₂] (f : F) (x y : monoid_algebra β α) :
  (map_domain f (x * y : monoid_algebra β α) : monoid_algebra β α₂) =
    (map_domain f x * map_domain f y : monoid_algebra β α₂) :=
begin
  simp_rw [mul_def, map_domain_sum, map_domain_single, map_mul],
  rw finsupp.sum_map_domain_index,
  { congr,
    ext a b,
    rw finsupp.sum_map_domain_index,
    { simp },
    { simp [mul_add] } },
  { simp },
  { simp [add_mul] }
end

variables (k G)

/-- The embedding of a magma into its magma algebra. -/
@[simps] def of_magma [has_mul G] : G →ₙ* (monoid_algebra k G) :=
{ to_fun   := λ a, single a 1,
  map_mul' := λ a b, by simp only [mul_def, mul_one, sum_single_index, single_eq_zero, mul_zero], }

/-- The embedding of a unital magma into its magma algebra. -/
@[simps] def of [mul_one_class G] : G →* monoid_algebra k G :=
{ to_fun := λ a, single a 1,
  map_one' := rfl,
  .. of_magma k G }

end

lemma smul_of [mul_one_class G] (g : G) (r : k) :
  r • (of k G g) = single g r := by simp

lemma of_injective [mul_one_class G] [nontrivial k] : function.injective (of k G) :=
λ a b h, by simpa using (single_eq_single_iff _ _ _ _).mp h

/--
`finsupp.single` as a `monoid_hom` from the product type into the monoid algebra.

Note the order of the elements of the product are reversed compared to the arguments of
`finsupp.single`.
-/
@[simps] def single_hom [mul_one_class G] : k × G →* monoid_algebra k G :=
{ to_fun := λ a, single a.2 a.1,
  map_one' := rfl,
  map_mul' := λ a b, single_mul_single.symm }

lemma mul_single_apply_aux [has_mul G] (f : monoid_algebra k G) {r : k}
  {x y z : G} (H : ∀ a, a * x = z ↔ a = y) :
  (f * single x r) z = f y * r :=
by classical; exact
have A : ∀ a₁ b₁, (single x r).sum (λ a₂ b₂, ite (a₁ * a₂ = z) (b₁ * b₂) 0) =
  ite (a₁ * x = z) (b₁ * r) 0,
from λ a₁ b₁, sum_single_index $ by simp,
calc (f * single x r) z = sum f (λ a b, if (a = y) then (b * r) else 0) :
  by simp only [mul_apply, A, H]
... = if y ∈ f.support then f y * r else 0 : f.support.sum_ite_eq' _ _
... = f y * r : by split_ifs with h; simp at h; simp [h]

lemma mul_single_one_apply [mul_one_class G] (f : monoid_algebra k G) (r : k) (x : G) :
  (f * single 1 r) x = f x * r :=
f.mul_single_apply_aux $ λ a, by rw [mul_one]

lemma support_mul_single [right_cancel_semigroup G]
  (f : monoid_algebra k G) (r : k) (hr : ∀ y, y * r = 0 ↔ y = 0) (x : G) :
  (f * single x r).support = f.support.map (mul_right_embedding x) :=
begin
  ext y, simp only [mem_support_iff, mem_map, exists_prop, mul_right_embedding_apply],
  by_cases H : ∃ a, a * x = y,
  { rcases H with ⟨a, rfl⟩,
    rw [mul_single_apply_aux f (λ _, mul_left_inj x)],
    simp [hr] },
  { push_neg at H,
    classical,
    simp [mul_apply, H] }
end

lemma single_mul_apply_aux [has_mul G] (f : monoid_algebra k G) {r : k} {x y z : G}
  (H : ∀ a, x * a = y ↔ a = z) :
  (single x r * f) y = r * f z :=
by classical; exact (
have f.sum (λ a b, ite (x * a = y) (0 * b) 0) = 0, by simp,
calc (single x r * f) y = sum f (λ a b, ite (x * a = y) (r * b) 0) :
  (mul_apply _ _ _).trans $ sum_single_index (by exact this)
... = f.sum (λ a b, ite (a = z) (r * b) 0) : by simp only [H]
... = if z ∈ f.support then (r * f z) else 0 : f.support.sum_ite_eq' _ _
... = _ : by split_ifs with h; simp at h; simp [h])

lemma single_one_mul_apply [mul_one_class G] (f : monoid_algebra k G) (r : k) (x : G) :
  (single 1 r * f) x = r * f x :=
f.single_mul_apply_aux $ λ a, by rw [one_mul]

lemma support_single_mul [left_cancel_semigroup G]
  (f : monoid_algebra k G) (r : k) (hr : ∀ y, r * y = 0 ↔ y = 0) (x : G) :
  (single x r * f).support = f.support.map (mul_left_embedding x) :=
begin
  ext y, simp only [mem_support_iff, mem_map, exists_prop, mul_left_embedding_apply],
  by_cases H : ∃ a, x * a = y,
  { rcases H with ⟨a, rfl⟩,
    rw [single_mul_apply_aux f (λ _, mul_right_inj x)],
    simp [hr] },
  { push_neg at H,
    classical,
    simp [mul_apply, H] }
end

lemma lift_nc_smul [mul_one_class G] {R : Type*} [semiring R] (f : k →+* R) (g : G →* R) (c : k)
  (φ : monoid_algebra k G) :
  lift_nc (f : k →+ R) g (c • φ) = f c * lift_nc (f : k →+ R) g φ :=
begin
  suffices : (lift_nc ↑f g).comp (smul_add_hom k (monoid_algebra k G) c) =
    (add_monoid_hom.mul_left (f c)).comp (lift_nc ↑f g),
    from add_monoid_hom.congr_fun this φ,
  ext a b, simp [mul_assoc]
end

end misc_theorems

/-! #### Non-unital, non-associative algebra structure -/
section non_unital_non_assoc_algebra

variables (k) [monoid R] [semiring k] [distrib_mul_action R k] [has_mul G]

instance is_scalar_tower_self [is_scalar_tower R k k] :
  is_scalar_tower R (monoid_algebra k G) (monoid_algebra k G) :=
⟨λ t a b,
begin
  ext m,
  classical,
  simp only [mul_apply, finsupp.smul_sum, smul_ite, smul_mul_assoc, sum_smul_index', zero_mul,
     if_t_t, implies_true_iff, eq_self_iff_true, sum_zero, coe_smul, smul_eq_mul, pi.smul_apply,
     smul_zero],
end⟩

/-- Note that if `k` is a `comm_semiring` then we have `smul_comm_class k k k` and so we can take
`R = k` in the below. In other words, if the coefficients are commutative amongst themselves, they
also commute with the algebra multiplication. -/
instance smul_comm_class_self [smul_comm_class R k k] :
  smul_comm_class R (monoid_algebra k G) (monoid_algebra k G) :=
⟨λ t a b,
begin
  ext m,
  simp only [mul_apply, finsupp.sum, finset.smul_sum, smul_ite, mul_smul_comm, sum_smul_index',
    implies_true_iff, eq_self_iff_true, coe_smul, ite_eq_right_iff, smul_eq_mul, pi.smul_apply,
    mul_zero, smul_zero],
end⟩

instance smul_comm_class_symm_self [smul_comm_class k R k] :
  smul_comm_class (monoid_algebra k G) R (monoid_algebra k G) :=
⟨λ t a b, by { haveI := smul_comm_class.symm k R k, rw ← smul_comm, } ⟩

variables {A : Type u₃} [non_unital_non_assoc_semiring A]

/-- A non_unital `k`-algebra homomorphism from `monoid_algebra k G` is uniquely defined by its
values on the functions `single a 1`. -/
lemma non_unital_alg_hom_ext [distrib_mul_action k A]
  {φ₁ φ₂ : monoid_algebra k G →ₙₐ[k] A}
  (h : ∀ x, φ₁ (single x 1) = φ₂ (single x 1)) : φ₁ = φ₂ :=
non_unital_alg_hom.to_distrib_mul_action_hom_injective $
  finsupp.distrib_mul_action_hom_ext' $
  λ a, distrib_mul_action_hom.ext_ring (h a)

/-- See note [partially-applied ext lemmas]. -/
@[ext] lemma non_unital_alg_hom_ext' [distrib_mul_action k A]
  {φ₁ φ₂ : monoid_algebra k G →ₙₐ[k] A}
  (h : φ₁.to_mul_hom.comp (of_magma k G) = φ₂.to_mul_hom.comp (of_magma k G)) : φ₁ = φ₂ :=
non_unital_alg_hom_ext k $ mul_hom.congr_fun h

/-- The functor `G ↦ monoid_algebra k G`, from the category of magmas to the category of non-unital,
non-associative algebras over `k` is adjoint to the forgetful functor in the other direction. -/
@[simps] def lift_magma [module k A] [is_scalar_tower k A A] [smul_comm_class k A A] :
  (G →ₙ* A) ≃ (monoid_algebra k G →ₙₐ[k] A) :=
{ to_fun    := λ f,
    { to_fun    := λ a, a.sum (λ m t, t • f m),
      map_smul' :=  λ t' a,
        begin
          rw [finsupp.smul_sum, sum_smul_index'],
          { simp_rw smul_assoc, },
          { intros m, exact zero_smul k (f m), },
        end,
      map_mul'  := λ a₁ a₂,
        begin
          let g : G → k → A := λ m t, t • f m,
          have h₁ : ∀ m, g m 0 = 0, { intros, exact zero_smul k (f m), },
          have h₂ : ∀ m (t₁ t₂ : k), g m (t₁ + t₂) = g m t₁ + g m t₂, { intros, rw ← add_smul, },
          simp_rw [finsupp.mul_sum, finsupp.sum_mul, smul_mul_smul, ← f.map_mul, mul_def,
            sum_comm a₂ a₁, sum_sum_index h₁ h₂, sum_single_index (h₁ _)],
        end,
      .. lift_add_hom (λ x, (smul_add_hom k A).flip (f x)) },
  inv_fun   := λ F, F.to_mul_hom.comp (of_magma k G),
  left_inv  := λ f, by { ext m, simp only [non_unital_alg_hom.coe_mk, of_magma_apply,
    non_unital_alg_hom.to_mul_hom_eq_coe, sum_single_index, function.comp_app, one_smul, zero_smul,
    mul_hom.coe_comp, non_unital_alg_hom.coe_to_mul_hom], },
  right_inv := λ F, by { ext m, simp only [non_unital_alg_hom.coe_mk, of_magma_apply,
    non_unital_alg_hom.to_mul_hom_eq_coe, sum_single_index, function.comp_app, one_smul, zero_smul,
    mul_hom.coe_comp, non_unital_alg_hom.coe_to_mul_hom], }, }

end non_unital_non_assoc_algebra

/-! #### Algebra structure -/
section algebra

local attribute [reducible] monoid_algebra

lemma single_one_comm [comm_semiring k] [mul_one_class G] (r : k) (f : monoid_algebra k G) :
  single 1 r * f = f * single 1 r :=
by { ext, rw [single_one_mul_apply, mul_single_one_apply, mul_comm] }

/-- `finsupp.single 1` as a `ring_hom` -/
@[simps] def single_one_ring_hom [semiring k] [mul_one_class G] : k →+* monoid_algebra k G :=
{ map_one' := rfl,
  map_mul' := λ x y, by rw [single_add_hom, single_mul_single, one_mul],
  ..finsupp.single_add_hom 1}

/-- If `f : G → H` is a multiplicative homomorphism between two monoids, then
`finsupp.map_domain f` is a ring homomorphism between their monoid algebras. -/
@[simps]
def map_domain_ring_hom (k : Type*) {H F : Type*} [semiring k] [monoid G] [monoid H]
  [monoid_hom_class F G H] (f : F) :
  monoid_algebra k G →+* monoid_algebra k H :=
{ map_one' := map_domain_one f,
  map_mul' := λ x y, map_domain_mul f x y,
  ..(finsupp.map_domain.add_monoid_hom f : monoid_algebra k G →+ monoid_algebra k H) }

/-- If two ring homomorphisms from `monoid_algebra k G` are equal on all `single a 1`
and `single 1 b`, then they are equal. -/
lemma ring_hom_ext {R} [semiring k] [mul_one_class G] [semiring R]
  {f g : monoid_algebra k G →+* R} (h₁ : ∀ b, f (single 1 b) = g (single 1 b))
  (h_of : ∀ a, f (single a 1) = g (single a 1)) : f = g :=
ring_hom.coe_add_monoid_hom_injective $ add_hom_ext $ λ a b,
  by rw [← one_mul a, ← mul_one b, ← single_mul_single, f.coe_add_monoid_hom,
    g.coe_add_monoid_hom, f.map_mul, g.map_mul, h₁, h_of]

/-- If two ring homomorphisms from `monoid_algebra k G` are equal on all `single a 1`
and `single 1 b`, then they are equal.

See note [partially-applied ext lemmas]. -/
@[ext] lemma ring_hom_ext' {R} [semiring k] [mul_one_class G] [semiring R]
  {f g : monoid_algebra k G →+* R} (h₁ : f.comp single_one_ring_hom = g.comp single_one_ring_hom)
  (h_of : (f : monoid_algebra k G →* R).comp (of k G) =
    (g : monoid_algebra k G →* R).comp (of k G)) :
  f = g :=
ring_hom_ext (ring_hom.congr_fun h₁) (monoid_hom.congr_fun h_of)

/--
The instance `algebra k (monoid_algebra A G)` whenever we have `algebra k A`.

In particular this provides the instance `algebra k (monoid_algebra k G)`.
-/
instance {A : Type*} [comm_semiring k] [semiring A] [algebra k A] [monoid G] :
  algebra k (monoid_algebra A G) :=
{ smul_def' := λ r a, by { ext, simp [single_one_mul_apply, algebra.smul_def, pi.smul_apply], },
  commutes' := λ r f, by { ext, simp [single_one_mul_apply, mul_single_one_apply,
    algebra.commutes], },
  ..single_one_ring_hom.comp (algebra_map k A) }

/-- `finsupp.single 1` as a `alg_hom` -/
@[simps]
def single_one_alg_hom {A : Type*} [comm_semiring k] [semiring A] [algebra k A] [monoid G] :
  A →ₐ[k] monoid_algebra A G :=
{ commutes' := λ r, by { ext, simp, refl, }, ..single_one_ring_hom}

@[simp] lemma coe_algebra_map {A : Type*} [comm_semiring k] [semiring A] [algebra k A] [monoid G] :
  ⇑(algebra_map k (monoid_algebra A G)) = single 1 ∘ (algebra_map k A) :=
rfl

lemma single_eq_algebra_map_mul_of [comm_semiring k] [monoid G] (a : G) (b : k) :
  single a b = algebra_map k (monoid_algebra k G) b * of k G a :=
by simp

lemma single_algebra_map_eq_algebra_map_mul_of {A : Type*} [comm_semiring k] [semiring A]
  [algebra k A] [monoid G] (a : G) (b : k) :
  single a (algebra_map k A b) = algebra_map k (monoid_algebra A G) b * of A G a :=
by simp

lemma induction_on [semiring k] [monoid G] {p : monoid_algebra k G → Prop} (f : monoid_algebra k G)
  (hM : ∀ g, p (of k G g)) (hadd : ∀ f g : monoid_algebra k G, p f → p g → p (f + g))
  (hsmul : ∀ (r : k) f, p f → p (r • f)) : p f :=
begin
  refine finsupp.induction_linear f _ (λ f g hf hg, hadd f g hf hg) (λ g r, _),
  { simpa using hsmul 0 (of k G 1) (hM 1) },
  { convert hsmul r (of k G g) (hM g),
    simp only [mul_one, smul_single', of_apply] },
end

end algebra

section lift

variables {k G} [comm_semiring k] [monoid G]
variables {A : Type u₃} [semiring A] [algebra k A] {B : Type*} [semiring B] [algebra k B]

/-- `lift_nc_ring_hom` as a `alg_hom`, for when `f` is an `alg_hom` -/
def lift_nc_alg_hom (f : A →ₐ[k] B) (g : G →* B) (h_comm : ∀ x y, commute (f x) (g y)) :
  monoid_algebra A G →ₐ[k] B :=
{ to_fun := lift_nc_ring_hom (f : A →+* B) g h_comm,
  commutes' := by simp [lift_nc_ring_hom],
  ..(lift_nc_ring_hom (f : A →+* B) g h_comm)}

/-- A `k`-algebra homomorphism from `monoid_algebra k G` is uniquely defined by its
values on the functions `single a 1`. -/
lemma alg_hom_ext ⦃φ₁ φ₂ : monoid_algebra k G →ₐ[k] A⦄
  (h : ∀ x, φ₁ (single x 1) = φ₂ (single x 1)) : φ₁ = φ₂ :=
alg_hom.to_linear_map_injective $ finsupp.lhom_ext' $ λ a, linear_map.ext_ring (h a)

/-- See note [partially-applied ext lemmas]. -/
@[ext] lemma alg_hom_ext' ⦃φ₁ φ₂ : monoid_algebra k G →ₐ[k] A⦄
  (h : (φ₁ : monoid_algebra k G →* A).comp (of k G) =
    (φ₂ : monoid_algebra k G →* A).comp (of k G)) : φ₁ = φ₂ :=
alg_hom_ext $ monoid_hom.congr_fun h

variables (k G A)

/-- Any monoid homomorphism `G →* A` can be lifted to an algebra homomorphism
`monoid_algebra k G →ₐ[k] A`. -/
def lift : (G →* A) ≃ (monoid_algebra k G →ₐ[k] A) :=
{ inv_fun := λ f, (f : monoid_algebra k G →* A).comp (of k G),
  to_fun := λ F, lift_nc_alg_hom (algebra.of_id k A) F $ λ _ _, algebra.commutes _ _,
  left_inv := λ f, by { ext, simp [lift_nc_alg_hom, lift_nc_ring_hom] },
  right_inv := λ F, by { ext, simp [lift_nc_alg_hom, lift_nc_ring_hom] } }

variables {k G A}

lemma lift_apply' (F : G →* A) (f : monoid_algebra k G) :
  lift k G A F f = f.sum (λ a b, (algebra_map k A b) * F a) := rfl

lemma lift_apply (F : G →* A) (f : monoid_algebra k G) :
  lift k G A F f = f.sum (λ a b, b • F a) :=
by simp only [lift_apply', algebra.smul_def]

lemma lift_def (F : G →* A) :
  ⇑(lift k G A F) = lift_nc ((algebra_map k A : k →+* A) : k →+ A) F :=
rfl

@[simp] lemma lift_symm_apply (F : monoid_algebra k G →ₐ[k] A) (x : G) :
  (lift k G A).symm F x = F (single x 1) := rfl

lemma lift_of (F : G →* A) (x) :
  lift k G A F (of k G x) = F x :=
by rw [of_apply, ← lift_symm_apply, equiv.symm_apply_apply]

@[simp] lemma lift_single (F : G →* A) (a b) :
  lift k G A F (single a b) = b • F a :=
by rw [lift_def, lift_nc_single, algebra.smul_def, ring_hom.coe_add_monoid_hom]

/-- Decomposition of a `k`-algebra homomorphism from `monoid_algebra k G` by
its values on `F (single a 1)`. -/
lemma lift_unique (F : monoid_algebra k G →ₐ[k] A) (f : monoid_algebra k G) :
  F f = f.sum (λ a b, b • F (single a 1)) :=
by conv_lhs { rw lift_unique' F, simp [lift_apply] }

/-- If `f : G → H` is a homomorphism between two magmas, then
`finsupp.map_domain f` is a non-unital algebra homomorphism between their magma algebras. -/
@[simps]
def map_domain_non_unital_alg_hom (k A : Type*) [comm_semiring k] [semiring A] [algebra k A]
  {G H F : Type*} [has_mul G] [has_mul H] [mul_hom_class F G H] (f : F) :
  monoid_algebra A G →ₙₐ[k] monoid_algebra A H :=
{ map_mul' := λ x y, map_domain_mul f x y,
  map_smul' := λ r x, map_domain_smul r x,
  ..(finsupp.map_domain.add_monoid_hom f : monoid_algebra A G →+ monoid_algebra A H) }

lemma map_domain_algebra_map (k A : Type*) {H F : Type*} [comm_semiring k] [semiring A]
  [algebra k A] [monoid H] [monoid_hom_class F G H] (f : F) (r : k) :
  map_domain f (algebra_map k (monoid_algebra A G) r) =
    algebra_map k (monoid_algebra A H) r :=
by simp only [coe_algebra_map, map_domain_single, map_one]

/-- If `f : G → H` is a multiplicative homomorphism between two monoids, then
`finsupp.map_domain f` is an algebra homomorphism between their monoid algebras. -/
@[simps]
def map_domain_alg_hom (k A : Type*) [comm_semiring k] [semiring A] [algebra k A] {H F : Type*}
  [monoid H] [monoid_hom_class F G H] (f : F) :
  monoid_algebra A G →ₐ[k] monoid_algebra A H :=
{ commutes' := map_domain_algebra_map k A f,
  ..map_domain_ring_hom A f}

end lift

section
local attribute [reducible] monoid_algebra

variables (k)
/-- When `V` is a `k[G]`-module, multiplication by a group element `g` is a `k`-linear map. -/
def group_smul.linear_map [monoid G] [comm_semiring k]
  (V : Type u₃) [add_comm_monoid V] [module k V] [module (monoid_algebra k G) V]
  [is_scalar_tower k (monoid_algebra k G) V] (g : G) :
  V →ₗ[k] V :=
{ to_fun    := λ v, (single g (1 : k) • v : V),
  map_add'  := λ x y, smul_add (single g (1 : k)) x y,
  map_smul' := λ c x, smul_algebra_smul_comm _ _ _ }

@[simp]
lemma group_smul.linear_map_apply [monoid G] [comm_semiring k]
  (V : Type u₃) [add_comm_monoid V] [module k V] [module (monoid_algebra k G) V]
  [is_scalar_tower k (monoid_algebra k G) V] (g : G) (v : V) :
  (group_smul.linear_map k V g) v = (single g (1 : k) • v : V) :=
rfl

section
variables {k}
variables [monoid G] [comm_semiring k] {V W : Type u₃}
  [add_comm_monoid V] [module k V] [module (monoid_algebra k G) V]
  [is_scalar_tower k (monoid_algebra k G) V]
  [add_comm_monoid W] [module k W] [module (monoid_algebra k G) W]
  [is_scalar_tower k (monoid_algebra k G) W]
  (f : V →ₗ[k] W)
  (h : ∀ (g : G) (v : V), f (single g (1 : k) • v : V) = (single g (1 : k) • (f v) : W))
include h

/-- Build a `k[G]`-linear map from a `k`-linear map and evidence that it is `G`-equivariant. -/
def equivariant_of_linear_of_comm : V →ₗ[monoid_algebra k G] W :=
{ to_fun := f,
  map_add' := λ v v', by simp,
  map_smul' := λ c v,
  begin
  apply finsupp.induction c,
  { simp, },
  { intros g r c' nm nz w,
    dsimp at *,
    simp only [add_smul, f.map_add, w, add_left_inj, single_eq_algebra_map_mul_of, ← smul_smul],
    erw [algebra_map_smul (monoid_algebra k G) r, algebra_map_smul (monoid_algebra k G) r,
      f.map_smul, h g v, of_apply],
    all_goals { apply_instance } }
  end, }

@[simp]
lemma equivariant_of_linear_of_comm_apply (v : V) : (equivariant_of_linear_of_comm f h) v = f v :=
rfl

end
end

section
universe ui
variable {ι : Type ui}
local attribute [reducible] monoid_algebra

lemma prod_single [comm_semiring k] [comm_monoid G]
  {s : finset ι} {a : ι → G} {b : ι → k} :
  (∏ i in s, single (a i) (b i)) = single (∏ i in s, a i) (∏ i in s, b i) :=
finset.cons_induction_on s rfl $ λ a s has ih, by rw [prod_cons has, ih,
  single_mul_single, prod_cons has, prod_cons has]

end

section -- We now prove some additional statements that hold for group algebras.
variables [semiring k] [group G]
local attribute [reducible] monoid_algebra

@[simp]
lemma mul_single_apply (f : monoid_algebra k G) (r : k) (x y : G) :
  (f * single x r) y = f (y * x⁻¹) * r :=
f.mul_single_apply_aux $ λ a, eq_mul_inv_iff_mul_eq.symm

@[simp]
lemma single_mul_apply (r : k) (x : G) (f : monoid_algebra k G) (y : G) :
  (single x r * f) y = r * f (x⁻¹ * y) :=
f.single_mul_apply_aux $ λ z, eq_inv_mul_iff_mul_eq.symm

lemma mul_apply_left (f g : monoid_algebra k G) (x : G) :
  (f * g) x = (f.sum $ λ a b, b * (g (a⁻¹ * x))) :=
calc (f * g) x = sum f (λ a b, (single a b * g) x) :
  by rw [← finsupp.sum_apply, ← finsupp.sum_mul, f.sum_single]
... = _ : by simp only [single_mul_apply, finsupp.sum]

-- If we'd assumed `comm_semiring`, we could deduce this from `mul_apply_left`.
lemma mul_apply_right (f g : monoid_algebra k G) (x : G) :
  (f * g) x = (g.sum $ λa b, (f (x * a⁻¹)) * b) :=
calc (f * g) x = sum g (λ a b, (f * single a b) x) :
  by rw [← finsupp.sum_apply, ← finsupp.mul_sum, g.sum_single]
... = _ : by simp only [mul_single_apply, finsupp.sum]

end

section span

variables [semiring k] [mul_one_class G]

/-- An element of `monoid_algebra R M` is in the subalgebra generated by its support. -/
lemma mem_span_support (f : monoid_algebra k G) :
  f ∈ submodule.span k (of k G '' (f.support : set G)) :=
by rw [of, monoid_hom.coe_mk, ← finsupp.supported_eq_span_single, finsupp.mem_supported]

end span

section opposite

open finsupp mul_opposite

variables [semiring k]

/-- The opposite of an `monoid_algebra R I` equivalent as a ring to
the `monoid_algebra Rᵐᵒᵖ Iᵐᵒᵖ` over the opposite ring, taking elements to their opposite. -/
@[simps {simp_rhs := tt}] protected noncomputable def op_ring_equiv [monoid G] :
  (monoid_algebra k G)ᵐᵒᵖ ≃+* monoid_algebra kᵐᵒᵖ Gᵐᵒᵖ :=
{ map_mul' := begin
    dsimp only [add_equiv.to_fun_eq_coe, ←add_equiv.coe_to_add_monoid_hom],
    rw add_monoid_hom.map_mul_iff,
    ext i₁ r₁ i₂ r₂ : 6,
    simp
  end,
  ..op_add_equiv.symm.trans $ (finsupp.map_range.add_equiv (op_add_equiv : k ≃+ kᵐᵒᵖ)).trans $
    finsupp.dom_congr op_equiv }

@[simp] lemma op_ring_equiv_single [monoid G] (r : k) (x : G) :
  monoid_algebra.op_ring_equiv (op (single x r)) = single (op x) (op r) :=
by simp

@[simp] lemma op_ring_equiv_symm_single [monoid G] (r : kᵐᵒᵖ) (x : Gᵐᵒᵖ) :
  monoid_algebra.op_ring_equiv.symm (single x r) = op (single x.unop r.unop) :=
by simp

end opposite

section submodule

variables {k G} [comm_semiring k] [monoid G]
variables {V : Type*} [add_comm_monoid V]
variables [module k V] [module (monoid_algebra k G) V] [is_scalar_tower k (monoid_algebra k G) V]

/-- A submodule over `k` which is stable under scalar multiplication by elements of `G` is a
submodule over `monoid_algebra k G`  -/
def submodule_of_smul_mem (W : submodule k V) (h : ∀ (g : G) (v : V), v ∈ W → (of k G g) • v ∈ W) :
  submodule (monoid_algebra k G) V :=
{ carrier := W,
  zero_mem' := W.zero_mem',
  add_mem' := W.add_mem',
  smul_mem' := begin
    intros f v hv,
    rw [←finsupp.sum_single f, finsupp.sum, finset.sum_smul],
    simp_rw [←smul_of, smul_assoc],
    exact submodule.sum_smul_mem W _ (λ g _, h g v hv)
  end  }

end submodule

end monoid_algebra

/-! ### Additive monoids -/
section
variables [semiring k]

/--
The monoid algebra over a semiring `k` generated by the additive monoid `G`.
It is the type of finite formal `k`-linear combinations of terms of `G`,
endowed with the convolution product.
-/
@[derive [inhabited, add_comm_monoid]]
def add_monoid_algebra := G →₀ k

instance : has_coe_to_fun (add_monoid_algebra k G) (λ _, G → k) :=
finsupp.has_coe_to_fun

end

namespace add_monoid_algebra

variables {k G}

section
variables [semiring k] [non_unital_non_assoc_semiring R]

/-- A non-commutative version of `add_monoid_algebra.lift`: given a additive homomorphism `f : k →+
R` and a map `g : multiplicative G → R`, returns the additive
homomorphism from `add_monoid_algebra k G` such that `lift_nc f g (single a b) = f b * g a`. If `f`
is a ring homomorphism and the range of either `f` or `g` is in center of `R`, then the result is a
ring homomorphism.  If `R` is a `k`-algebra and `f = algebra_map k R`, then the result is an algebra
homomorphism called `add_monoid_algebra.lift`. -/
def lift_nc (f : k →+ R) (g : multiplicative G → R) : add_monoid_algebra k G →+ R :=
lift_add_hom (λ x : G, (add_monoid_hom.mul_right (g $ multiplicative.of_add x)).comp f)

@[simp] lemma lift_nc_single (f : k →+ R) (g : multiplicative G → R) (a : G) (b : k) :
  lift_nc f g (single a b) = f b * g (multiplicative.of_add a) :=
lift_add_hom_apply_single _ _ _
end

section has_mul

variables [semiring k] [has_add G]

/-- The product of `f g : add_monoid_algebra k G` is the finitely supported function
  whose value at `a` is the sum of `f x * g y` over all pairs `x, y`
  such that `x + y = a`. (Think of the product of multivariate
  polynomials where `α` is the additive monoid of monomial exponents.) -/
instance : has_mul (add_monoid_algebra k G) :=
⟨λf g, f.sum $ λa₁ b₁, g.sum $ λa₂ b₂, single (a₁ + a₂) (b₁ * b₂)⟩

lemma mul_def {f g : add_monoid_algebra k G} :
  f * g = (f.sum $ λa₁ b₁, g.sum $ λa₂ b₂, single (a₁ + a₂) (b₁ * b₂)) :=
rfl

instance : non_unital_non_assoc_semiring (add_monoid_algebra k G) :=
{ zero          := 0,
  mul           := (*),
  add           := (+),
  left_distrib  := assume f g h, by simp only [mul_def, sum_add_index, mul_add, mul_zero,
    single_zero, single_add, eq_self_iff_true, forall_true_iff, forall_3_true_iff, sum_add],
  right_distrib := assume f g h, by simp only [mul_def, sum_add_index, add_mul, mul_zero, zero_mul,
    single_zero, single_add, eq_self_iff_true, forall_true_iff, forall_3_true_iff, sum_zero,
    sum_add],
  zero_mul  := assume f, by simp only [mul_def, sum_zero_index],
  mul_zero  := assume f, by simp only [mul_def, sum_zero_index, sum_zero],
  nsmul     := λ n f, n • f,
  nsmul_zero' := by { intros, ext, simp [-nsmul_eq_mul, add_smul] },
  nsmul_succ' := by { intros, ext, simp [-nsmul_eq_mul, nat.succ_eq_one_add, add_smul] },
  .. finsupp.add_comm_monoid }

variables [semiring R]

lemma lift_nc_mul {g_hom : Type*} [mul_hom_class g_hom (multiplicative G) R] (f : k →+* R)
  (g : g_hom) (a b : add_monoid_algebra k G)
  (h_comm : ∀ {x y}, y ∈ a.support → commute (f (b x)) (g $ multiplicative.of_add y)) :
  lift_nc (f : k →+ R) g (a * b) = lift_nc (f : k →+ R) g a * lift_nc (f : k →+ R) g b :=
(monoid_algebra.lift_nc_mul f g _ _ @h_comm : _)

end has_mul

section has_one

variables [semiring k] [has_zero G] [non_assoc_semiring R]

/-- The unit of the multiplication is `single 1 1`, i.e. the function
  that is `1` at `0` and zero elsewhere. -/
instance : has_one (add_monoid_algebra k G) :=
⟨single 0 1⟩

lemma one_def : (1 : add_monoid_algebra k G) = single 0 1 :=
rfl

@[simp] lemma lift_nc_one {g_hom : Type*} [one_hom_class g_hom (multiplicative G) R]
  (f : k →+* R) (g : g_hom) :
  lift_nc (f : k →+ R) g 1 = 1 :=
(monoid_algebra.lift_nc_one f g : _)

end has_one

section semigroup

variables [semiring k] [add_semigroup G]

instance : non_unital_semiring (add_monoid_algebra k G) :=
{ zero      := 0,
  mul       := (*),
  add       := (+),
  mul_assoc := assume f g h, by simp only [mul_def, sum_sum_index, sum_zero_index, sum_add_index,
    sum_single_index, single_zero, single_add, eq_self_iff_true, forall_true_iff, forall_3_true_iff,
    add_mul, mul_add, add_assoc, mul_assoc, zero_mul, mul_zero, sum_zero, sum_add],
  .. add_monoid_algebra.non_unital_non_assoc_semiring }

end semigroup

section mul_one_class

variables [semiring k] [add_zero_class G]

instance : non_assoc_semiring (add_monoid_algebra k G) :=
{ one       := 1,
  mul       := (*),
  zero      := 0,
  add       := (+),
  nat_cast  := λ n, single 0 n,
  nat_cast_zero := by simp [nat.cast],
  nat_cast_succ := λ _, by simp [nat.cast]; refl,
  one_mul   := assume f, by simp only [mul_def, one_def, sum_single_index, zero_mul,
    single_zero, sum_zero, zero_add, one_mul, sum_single],
  mul_one   := assume f, by simp only [mul_def, one_def, sum_single_index, mul_zero,
    single_zero, sum_zero, add_zero, mul_one, sum_single],
  .. add_monoid_algebra.non_unital_non_assoc_semiring }

end mul_one_class

/-! #### Semiring structure -/
section semiring

instance {R : Type*} [monoid R] [semiring k] [distrib_mul_action R k] :
  has_scalar R (add_monoid_algebra k G) :=
finsupp.has_scalar

variables [semiring k] [add_monoid G]

instance : semiring (add_monoid_algebra k G) :=
{ one       := 1,
  mul       := (*),
  zero      := 0,
  add       := (+),
  .. add_monoid_algebra.non_unital_semiring,
  .. add_monoid_algebra.non_assoc_semiring, }

variables [semiring R]

/-- `lift_nc` as a `ring_hom`, for when `f` and `g` commute -/
def lift_nc_ring_hom (f : k →+* R) (g : multiplicative G →* R)
  (h_comm : ∀ x y, commute (f x) (g y)) :
  add_monoid_algebra k G →+* R :=
{ to_fun := lift_nc (f : k →+ R) g,
  map_one' := lift_nc_one _ _,
  map_mul' := λ a b, lift_nc_mul _ _ _ _ $ λ _ _ _, h_comm _ _,
  ..(lift_nc (f : k →+ R) g)}

end semiring

instance [comm_semiring k] [add_comm_semigroup G] :
  non_unital_comm_semiring (add_monoid_algebra k G) :=
{ mul_comm := @mul_comm (monoid_algebra k $ multiplicative G) _,
  .. add_monoid_algebra.non_unital_semiring }

instance [semiring k] [nontrivial k] [nonempty G] : nontrivial (add_monoid_algebra k G) :=
finsupp.nontrivial

/-! #### Derived instances -/
section derived_instances

instance [comm_semiring k] [add_comm_monoid G] : comm_semiring (add_monoid_algebra k G) :=
{ .. add_monoid_algebra.non_unital_comm_semiring,
  .. add_monoid_algebra.semiring }

instance [semiring k] [subsingleton k] : unique (add_monoid_algebra k G) :=
finsupp.unique_of_right

instance [ring k] : add_comm_group (add_monoid_algebra k G) :=
finsupp.add_comm_group

instance [ring k] [has_add G] : non_unital_non_assoc_ring (add_monoid_algebra k G) :=
{ .. add_monoid_algebra.add_comm_group,
  .. add_monoid_algebra.non_unital_non_assoc_semiring }

instance [ring k] [add_semigroup G] : non_unital_ring (add_monoid_algebra k G) :=
{ .. add_monoid_algebra.add_comm_group,
  .. add_monoid_algebra.non_unital_semiring }

instance [ring k] [add_zero_class G] : non_assoc_ring (add_monoid_algebra k G) :=
{ .. add_monoid_algebra.add_comm_group,
  .. add_monoid_algebra.non_assoc_semiring }

instance [ring k] [add_monoid G] : ring (add_monoid_algebra k G) :=
{ .. add_monoid_algebra.non_unital_non_assoc_ring,
  .. add_monoid_algebra.semiring }

instance [comm_ring k] [add_comm_semigroup G] : non_unital_comm_ring (add_monoid_algebra k G) :=
{ .. add_monoid_algebra.non_unital_comm_semiring,
  .. add_monoid_algebra.non_unital_ring }

instance [comm_ring k] [add_comm_monoid G] : comm_ring (add_monoid_algebra k G) :=
{ .. add_monoid_algebra.non_unital_comm_ring,
  .. add_monoid_algebra.ring }

variables {S : Type*}

instance [monoid R] [semiring k] [distrib_mul_action R k] :
  distrib_mul_action R (add_monoid_algebra k G) :=
finsupp.distrib_mul_action G k

instance [monoid R] [semiring k] [distrib_mul_action R k] [has_faithful_smul R k] [nonempty G] :
  has_faithful_smul R (add_monoid_algebra k G) :=
finsupp.has_faithful_smul

instance [semiring R] [semiring k] [module R k] : module R (add_monoid_algebra k G) :=
finsupp.module G k

instance [monoid R] [monoid S] [semiring k] [distrib_mul_action R k] [distrib_mul_action S k]
  [has_scalar R S] [is_scalar_tower R S k] :
  is_scalar_tower R S (add_monoid_algebra k G) :=
finsupp.is_scalar_tower G k

instance [monoid R] [monoid S] [semiring k] [distrib_mul_action R k] [distrib_mul_action S k]
  [smul_comm_class R S k] :
  smul_comm_class R S (add_monoid_algebra k G) :=
finsupp.smul_comm_class G k

instance [monoid R] [semiring k] [distrib_mul_action R k] [distrib_mul_action Rᵐᵒᵖ k]
  [is_central_scalar R k] :
  is_central_scalar R (add_monoid_algebra k G) :=
finsupp.is_central_scalar G k

/-! It is hard to state the equivalent of `distrib_mul_action G (add_monoid_algebra k G)`
because we've never discussed actions of additive groups. -/

end derived_instances

section misc_theorems

variables [semiring k]

lemma mul_apply [decidable_eq G] [has_add G] (f g : add_monoid_algebra k G) (x : G) :
  (f * g) x = (f.sum $ λa₁ b₁, g.sum $ λa₂ b₂, if a₁ + a₂ = x then b₁ * b₂ else 0) :=
@monoid_algebra.mul_apply k (multiplicative G) _ _ _ _ _ _

lemma mul_apply_antidiagonal [has_add G] (f g : add_monoid_algebra k G) (x : G) (s : finset (G × G))
  (hs : ∀ {p : G × G}, p ∈ s ↔ p.1 + p.2 = x) :
  (f * g) x = ∑ p in s, (f p.1 * g p.2) :=
@monoid_algebra.mul_apply_antidiagonal k (multiplicative G) _ _ _ _ _ s @hs

lemma support_mul [decidable_eq G] [has_add G] (a b : add_monoid_algebra k G) :
  (a * b).support ⊆ a.support.bUnion (λa₁, b.support.bUnion $ λa₂, {a₁ + a₂}) :=
@monoid_algebra.support_mul k (multiplicative G) _ _ _ _ _

lemma single_mul_single [has_add G] {a₁ a₂ : G} {b₁ b₂ : k} :
  (single a₁ b₁ * single a₂ b₂ : add_monoid_algebra k G) = single (a₁ + a₂) (b₁ * b₂) :=
@monoid_algebra.single_mul_single k (multiplicative G) _ _ _ _ _ _

-- This should be a `@[simp]` lemma, but the simp_nf linter times out if we add this.
-- Probably the correct fix is to make a `[add_]monoid_algebra.single` with the correct type,
-- instead of relying on `finsupp.single`.
lemma single_pow [add_monoid G] {a : G} {b : k} :
  ∀ n : ℕ, ((single a b)^n : add_monoid_algebra k G) = single (n • a) (b ^ n)
| 0 := by { simp only [pow_zero, zero_nsmul], refl }
| (n+1) :=
by rw [pow_succ, pow_succ, single_pow n, single_mul_single, add_comm, add_nsmul, one_nsmul]

/-- Like `finsupp.map_domain_zero`, but for the `1` we define in this file -/
@[simp] lemma map_domain_one {α : Type*} {β : Type*} {α₂ : Type*}
  [semiring β] [has_zero α] [has_zero α₂] {F : Type*} [zero_hom_class F α α₂] (f : F) :
  (map_domain f (1 : add_monoid_algebra β α) : add_monoid_algebra β α₂) =
    (1 : add_monoid_algebra β α₂) :=
by simp_rw [one_def, map_domain_single, map_zero]

/-- Like `finsupp.map_domain_add`, but for the convolutive multiplication we define in this file -/
lemma map_domain_mul {α : Type*} {β : Type*} {α₂ : Type*} [semiring β] [has_add α] [has_add α₂]
  {F : Type*} [add_hom_class F α α₂] (f : F) (x y : add_monoid_algebra β α) :
  (map_domain f (x * y : add_monoid_algebra β α) : add_monoid_algebra β α₂) =
    (map_domain f x * map_domain f y : add_monoid_algebra β α₂) :=
begin
  simp_rw [mul_def, map_domain_sum, map_domain_single, map_add],
  rw finsupp.sum_map_domain_index,
  { congr,
    ext a b,
    rw finsupp.sum_map_domain_index,
    { simp },
    { simp [mul_add] } },
  { simp },
  { simp [add_mul] }
end

section

variables (k G)

/-- The embedding of an additive magma into its additive magma algebra. -/
@[simps] def of_magma [has_add G] : multiplicative G →ₙ* add_monoid_algebra k G :=
{ to_fun   := λ a, single a 1,
  map_mul' := λ a b, by simpa only [mul_def, mul_one, sum_single_index, single_eq_zero, mul_zero], }

/-- Embedding of a magma with zero into its magma algebra. -/
def of [add_zero_class G] : multiplicative G →* add_monoid_algebra k G :=
{ to_fun := λ a, single a 1,
  map_one' := rfl,
  .. of_magma k G }

/-- Embedding of a magma with zero `G`, into its magma algebra, having `G` as source. -/
def of' : G → add_monoid_algebra k G := λ a, single a 1

end

@[simp] lemma of_apply [add_zero_class G] (a : multiplicative G) : of k G a = single a.to_add 1 :=
rfl

@[simp] lemma of'_apply (a : G) : of' k G a = single a 1 := rfl

lemma of'_eq_of [add_zero_class G] (a : G) : of' k G a = of k G a := rfl

lemma of_injective [nontrivial k] [add_zero_class G] : function.injective (of k G) :=
λ a b h, by simpa using (single_eq_single_iff _ _ _ _).mp h

/--
`finsupp.single` as a `monoid_hom` from the product type into the additive monoid algebra.

Note the order of the elements of the product are reversed compared to the arguments of
`finsupp.single`.
-/
@[simps] def single_hom [add_zero_class G] : k × multiplicative G →* add_monoid_algebra k G :=
{ to_fun := λ a, single a.2.to_add a.1,
  map_one' := rfl,
  map_mul' := λ a b, single_mul_single.symm }

lemma mul_single_apply_aux [has_add G] (f : add_monoid_algebra k G) (r : k)
  (x y z : G) (H : ∀ a, a + x = z ↔ a = y) :
  (f * single x r) z = f y * r :=
@monoid_algebra.mul_single_apply_aux k (multiplicative G) _ _ _ _ _ _ _ H

lemma mul_single_zero_apply [add_zero_class G] (f : add_monoid_algebra k G) (r : k) (x : G) :
  (f * single 0 r) x = f x * r :=
f.mul_single_apply_aux r _ _ _ $ λ a, by rw [add_zero]

lemma single_mul_apply_aux [has_add G] (f : add_monoid_algebra k G) (r : k) (x y z : G)
  (H : ∀ a, x + a = y ↔ a = z) :
  (single x r * f : add_monoid_algebra k G) y = r * f z :=
@monoid_algebra.single_mul_apply_aux k (multiplicative G) _ _ _ _ _ _ _ H

lemma single_zero_mul_apply [add_zero_class G] (f : add_monoid_algebra k G) (r : k) (x : G) :
  (single 0 r * f : add_monoid_algebra k G) x = r * f x :=
f.single_mul_apply_aux r _ _ _ $ λ a, by rw [zero_add]

lemma mul_single_apply [add_group G] (f : add_monoid_algebra k G) (r : k) (x y : G) :
  (f * single x r) y = f (y - x) * r :=
(sub_eq_add_neg y x).symm ▸
  @monoid_algebra.mul_single_apply k (multiplicative G) _ _ _ _ _ _

lemma single_mul_apply [add_group G] (r : k) (x : G) (f : add_monoid_algebra k G) (y : G) :
  (single x r * f : add_monoid_algebra k G) y = r * f (- x + y) :=
@monoid_algebra.single_mul_apply k (multiplicative G) _ _ _ _ _ _

lemma support_mul_single [add_right_cancel_semigroup G]
  (f : add_monoid_algebra k G) (r : k) (hr : ∀ y, y * r = 0 ↔ y = 0) (x : G) :
  (f * single x r : add_monoid_algebra k G).support = f.support.map (add_right_embedding x) :=
@monoid_algebra.support_mul_single k (multiplicative G) _ _ _ _ hr _

lemma support_single_mul [add_left_cancel_semigroup G]
  (f : add_monoid_algebra k G) (r : k) (hr : ∀ y, r * y = 0 ↔ y = 0) (x : G) :
  (single x r * f : add_monoid_algebra k G).support = f.support.map (add_left_embedding x) :=
@monoid_algebra.support_single_mul k (multiplicative G) _ _ _ _ hr _

lemma lift_nc_smul {R : Type*} [add_zero_class G] [semiring R] (f : k →+* R)
  (g : multiplicative G →* R) (c : k) (φ : monoid_algebra k G) :
  lift_nc (f : k →+ R) g (c • φ) = f c * lift_nc (f : k →+ R) g φ :=
@monoid_algebra.lift_nc_smul k (multiplicative G) _ _ _ _ f g c φ

lemma induction_on [add_monoid G] {p : add_monoid_algebra k G → Prop} (f : add_monoid_algebra k G)
  (hM : ∀ g, p (of k G (multiplicative.of_add g)))
  (hadd : ∀ f g : add_monoid_algebra k G, p f → p g → p (f + g))
  (hsmul : ∀ (r : k) f, p f → p (r • f)) : p f :=
begin
  refine finsupp.induction_linear f _ (λ f g hf hg, hadd f g hf hg) (λ g r, _),
  { simpa using hsmul 0 (of k G (multiplicative.of_add 0)) (hM 0) },
  { convert hsmul r (of k G (multiplicative.of_add g)) (hM g),
    simp only [mul_one, to_add_of_add, smul_single', of_apply] },
end

/-- If `f : G → H` is an additive homomorphism between two additive monoids, then
`finsupp.map_domain f` is a ring homomorphism between their add monoid algebras. -/
@[simps]
def map_domain_ring_hom (k : Type*) [semiring k] {H F : Type*} [add_monoid G] [add_monoid H]
  [add_monoid_hom_class F G H] (f : F) :
  add_monoid_algebra k G →+* add_monoid_algebra k H :=
{ map_one' := map_domain_one f,
  map_mul' := λ x y, map_domain_mul f x y,
  ..(finsupp.map_domain.add_monoid_hom f : monoid_algebra k G →+ monoid_algebra k H) }

end misc_theorems

section span

variables [semiring k]

/-- An element of `add_monoid_algebra R M` is in the submodule generated by its support. -/
lemma mem_span_support [add_zero_class G] (f : add_monoid_algebra k G) :
  f ∈ submodule.span k (of k G '' (f.support : set G)) :=
by rw [of, monoid_hom.coe_mk, ← finsupp.supported_eq_span_single, finsupp.mem_supported]

/-- An element of `add_monoid_algebra R M` is in the subalgebra generated by its support, using
unbundled inclusion. -/
lemma mem_span_support' (f : add_monoid_algebra k G) :
  f ∈ submodule.span k (of' k G '' (f.support : set G)) :=
by rw [of', ← finsupp.supported_eq_span_single, finsupp.mem_supported]

end span

end add_monoid_algebra

/-!
#### Conversions between `add_monoid_algebra` and `monoid_algebra`

We have not defined `add_monoid_algebra k G = monoid_algebra k (multiplicative G)`
because historically this caused problems;
since the changes that have made `nsmul` definitional, this would be possible,
but for now we just contruct the ring isomorphisms using `ring_equiv.refl _`.
-/

/-- The equivalence between `add_monoid_algebra` and `monoid_algebra` in terms of
`multiplicative` -/
protected def add_monoid_algebra.to_multiplicative [semiring k] [has_add G] :
  add_monoid_algebra k G ≃+* monoid_algebra k (multiplicative G) :=
{ to_fun := equiv_map_domain multiplicative.of_add,
  map_mul' := λ x y, begin
    repeat {rw equiv_map_domain_eq_map_domain},
    dsimp [multiplicative.of_add],
    convert monoid_algebra.map_domain_mul (mul_hom.id (multiplicative G)) _ _,
  end,
  ..finsupp.dom_congr multiplicative.of_add }

/-- The equivalence between `monoid_algebra` and `add_monoid_algebra` in terms of `additive` -/
protected def monoid_algebra.to_additive [semiring k] [has_mul G] :
  monoid_algebra k G ≃+* add_monoid_algebra k (additive G) :=
{ to_fun := equiv_map_domain additive.of_mul,
  map_mul' := λ x y, begin
    repeat {rw equiv_map_domain_eq_map_domain},
    dsimp [additive.of_mul],
    convert monoid_algebra.map_domain_mul (mul_hom.id G) _ _,
  end,
  ..finsupp.dom_congr additive.of_mul }

namespace add_monoid_algebra

variables {k G}

/-! #### Non-unital, non-associative algebra structure -/

section non_unital_non_assoc_algebra

variables (k) [monoid R] [semiring k] [distrib_mul_action R k] [has_add G]

instance is_scalar_tower_self [is_scalar_tower R k k] :
  is_scalar_tower R (add_monoid_algebra k G) (add_monoid_algebra k G) :=
@monoid_algebra.is_scalar_tower_self k (multiplicative G) R _ _ _ _ _

/-- Note that if `k` is a `comm_semiring` then we have `smul_comm_class k k k` and so we can take
`R = k` in the below. In other words, if the coefficients are commutative amongst themselves, they
also commute with the algebra multiplication. -/
instance smul_comm_class_self [smul_comm_class R k k] :
  smul_comm_class R (add_monoid_algebra k G) (add_monoid_algebra k G) :=
@monoid_algebra.smul_comm_class_self k (multiplicative G) R _ _ _ _ _

instance smul_comm_class_symm_self [smul_comm_class k R k] :
  smul_comm_class (add_monoid_algebra k G) R (add_monoid_algebra k G) :=
@monoid_algebra.smul_comm_class_symm_self k (multiplicative G) R _ _ _ _ _

variables {A : Type u₃} [non_unital_non_assoc_semiring A]

/-- A non_unital `k`-algebra homomorphism from `add_monoid_algebra k G` is uniquely defined by its
values on the functions `single a 1`. -/
lemma non_unital_alg_hom_ext [distrib_mul_action k A]
  {φ₁ φ₂ : add_monoid_algebra k G →ₙₐ[k] A}
  (h : ∀ x, φ₁ (single x 1) = φ₂ (single x 1)) : φ₁ = φ₂ :=
@monoid_algebra.non_unital_alg_hom_ext k (multiplicative G) _ _ _ _ _ φ₁ φ₂ h

/-- See note [partially-applied ext lemmas]. -/
@[ext] lemma non_unital_alg_hom_ext' [distrib_mul_action k A]
  {φ₁ φ₂ : add_monoid_algebra k G →ₙₐ[k] A}
  (h : φ₁.to_mul_hom.comp (of_magma k G) = φ₂.to_mul_hom.comp (of_magma k G)) : φ₁ = φ₂ :=
@monoid_algebra.non_unital_alg_hom_ext' k (multiplicative G) _ _ _ _ _ φ₁ φ₂ h

/-- The functor `G ↦ add_monoid_algebra k G`, from the category of magmas to the category of
non-unital, non-associative algebras over `k` is adjoint to the forgetful functor in the other
direction. -/
@[simps] def lift_magma [module k A] [is_scalar_tower k A A] [smul_comm_class k A A] :
  (multiplicative G →ₙ* A) ≃ (add_monoid_algebra k G →ₙₐ[k] A) :=
{ to_fun := λ f, { to_fun := λ a, sum a (λ m t, t • f (multiplicative.of_add m)),
                   .. (monoid_algebra.lift_magma k f : _)},
  inv_fun := λ F, F.to_mul_hom.comp (of_magma k G),
  .. (monoid_algebra.lift_magma k : (multiplicative G →ₙ* A) ≃ (_ →ₙₐ[k] A)) }

end non_unital_non_assoc_algebra

/-! #### Algebra structure -/
section algebra

local attribute [reducible] add_monoid_algebra

/-- `finsupp.single 0` as a `ring_hom` -/
@[simps] def single_zero_ring_hom [semiring k] [add_monoid G] : k →+* add_monoid_algebra k G :=
{ map_one' := rfl,
  map_mul' := λ x y, by rw [single_add_hom, single_mul_single, zero_add],
  ..finsupp.single_add_hom 0}

/-- If two ring homomorphisms from `add_monoid_algebra k G` are equal on all `single a 1`
and `single 0 b`, then they are equal. -/
lemma ring_hom_ext {R} [semiring k] [add_monoid G] [semiring R]
  {f g : add_monoid_algebra k G →+* R} (h₀ : ∀ b, f (single 0 b) = g (single 0 b))
  (h_of : ∀ a, f (single a 1) = g (single a 1)) : f = g :=
@monoid_algebra.ring_hom_ext k (multiplicative G) R _ _ _ _ _ h₀ h_of

/-- If two ring homomorphisms from `add_monoid_algebra k G` are equal on all `single a 1`
and `single 0 b`, then they are equal.

See note [partially-applied ext lemmas]. -/
@[ext] lemma ring_hom_ext' {R} [semiring k] [add_monoid G] [semiring R]
  {f g : add_monoid_algebra k G →+* R}
  (h₁ : f.comp single_zero_ring_hom = g.comp single_zero_ring_hom)
  (h_of : (f : add_monoid_algebra k G →* R).comp (of k G) =
    (g : add_monoid_algebra k G →* R).comp (of k G)) :
  f = g :=
ring_hom_ext (ring_hom.congr_fun h₁) (monoid_hom.congr_fun h_of)

section opposite

open finsupp mul_opposite

variables [semiring k]

/-- The opposite of an `add_monoid_algebra R I` is ring equivalent to
the `add_monoid_algebra Rᵐᵒᵖ I` over the opposite ring, taking elements to their opposite. -/
@[simps {simp_rhs := tt}] protected noncomputable def op_ring_equiv [add_comm_monoid G] :
  (add_monoid_algebra k G)ᵐᵒᵖ ≃+* add_monoid_algebra kᵐᵒᵖ G :=
{ map_mul' := begin
    dsimp only [add_equiv.to_fun_eq_coe, ←add_equiv.coe_to_add_monoid_hom],
    rw add_monoid_hom.map_mul_iff,
    ext i r i' r' : 6,
    dsimp,
    simp only [map_range_single, single_mul_single, ←op_mul, add_comm]
  end,
  ..mul_opposite.op_add_equiv.symm.trans
    (finsupp.map_range.add_equiv (mul_opposite.op_add_equiv : k ≃+ kᵐᵒᵖ))}

@[simp] lemma op_ring_equiv_single [add_comm_monoid G] (r : k) (x : G) :
  add_monoid_algebra.op_ring_equiv (op (single x r)) = single x (op r) :=
by simp

@[simp] lemma op_ring_equiv_symm_single [add_comm_monoid G] (r : kᵐᵒᵖ) (x : Gᵐᵒᵖ) :
  add_monoid_algebra.op_ring_equiv.symm (single x r) = op (single x r.unop) :=
by simp

end opposite

/--
The instance `algebra R (add_monoid_algebra k G)` whenever we have `algebra R k`.

In particular this provides the instance `algebra k (add_monoid_algebra k G)`.
-/
instance [comm_semiring R] [semiring k] [algebra R k] [add_monoid G] :
  algebra R (add_monoid_algebra k G) :=
{ smul_def' := λ r a, by { ext, simp [single_zero_mul_apply, algebra.smul_def, pi.smul_apply], },
  commutes' := λ r f, by { ext, simp [single_zero_mul_apply, mul_single_zero_apply,
                                      algebra.commutes], },
  ..single_zero_ring_hom.comp (algebra_map R k) }

/-- `finsupp.single 0` as a `alg_hom` -/
@[simps] def single_zero_alg_hom [comm_semiring R] [semiring k] [algebra R k] [add_monoid G] :
  k →ₐ[R] add_monoid_algebra k G :=
{ commutes' := λ r, by { ext, simp, refl, }, ..single_zero_ring_hom}

@[simp] lemma coe_algebra_map [comm_semiring R] [semiring k] [algebra R k] [add_monoid G] :
  (algebra_map R (add_monoid_algebra k G) : R → add_monoid_algebra k G) =
    single 0 ∘ (algebra_map R k) :=
rfl

end algebra

section lift

variables {k G} [comm_semiring k] [add_monoid G]
variables {A : Type u₃} [semiring A] [algebra k A] {B : Type*} [semiring B] [algebra k B]

/-- `lift_nc_ring_hom` as a `alg_hom`, for when `f` is an `alg_hom` -/
def lift_nc_alg_hom (f : A →ₐ[k] B) (g : multiplicative G →* B)
  (h_comm : ∀ x y, commute (f x) (g y)) :
  add_monoid_algebra A G →ₐ[k] B :=
{ to_fun := lift_nc_ring_hom (f : A →+* B) g h_comm,
  commutes' := by simp [lift_nc_ring_hom],
  ..(lift_nc_ring_hom (f : A →+* B) g h_comm)}

/-- A `k`-algebra homomorphism from `monoid_algebra k G` is uniquely defined by its
values on the functions `single a 1`. -/
lemma alg_hom_ext ⦃φ₁ φ₂ : add_monoid_algebra k G →ₐ[k] A⦄
  (h : ∀ x, φ₁ (single x 1) = φ₂ (single x 1)) : φ₁ = φ₂ :=
@monoid_algebra.alg_hom_ext k (multiplicative G) _ _ _ _ _ _ _ h

/-- See note [partially-applied ext lemmas]. -/
@[ext] lemma alg_hom_ext' ⦃φ₁ φ₂ : add_monoid_algebra k G →ₐ[k] A⦄
  (h : (φ₁ : add_monoid_algebra k G →* A).comp (of k G) =
    (φ₂ : add_monoid_algebra k G →* A).comp (of k G)) : φ₁ = φ₂ :=
alg_hom_ext $ monoid_hom.congr_fun h

variables (k G A)

/-- Any monoid homomorphism `G →* A` can be lifted to an algebra homomorphism
`monoid_algebra k G →ₐ[k] A`. -/
def lift : (multiplicative G →* A) ≃ (add_monoid_algebra k G →ₐ[k] A) :=
{ inv_fun := λ f, (f : add_monoid_algebra k G →* A).comp (of k G),
  to_fun := λ F,
  { to_fun := lift_nc_alg_hom (algebra.of_id k A) F $ λ _ _, algebra.commutes _ _,
    .. @monoid_algebra.lift k (multiplicative G) _ _ A _ _ F},
  .. @monoid_algebra.lift k (multiplicative G) _ _ A _ _ }

variables {k G A}

lemma lift_apply' (F : multiplicative G →* A) (f : monoid_algebra k G) :
  lift k G A F f = f.sum (λ a b, (algebra_map k A b) * F (multiplicative.of_add a)) := rfl

lemma lift_apply (F : multiplicative G →* A) (f : monoid_algebra k G) :
  lift k G A F f = f.sum (λ a b, b • F (multiplicative.of_add a)) :=
by simp only [lift_apply', algebra.smul_def]

lemma lift_def (F : multiplicative G →* A) :
  ⇑(lift k G A F) = lift_nc ((algebra_map k A : k →+* A) : k →+ A) F :=
rfl

@[simp] lemma lift_symm_apply (F : add_monoid_algebra k G →ₐ[k] A) (x : multiplicative G) :
  (lift k G A).symm F x = F (single x.to_add 1) := rfl

lemma lift_of (F : multiplicative G →* A) (x : multiplicative G) :
  lift k G A F (of k G x) = F x :=
by rw [of_apply, ← lift_symm_apply, equiv.symm_apply_apply]

@[simp] lemma lift_single (F : multiplicative G →* A) (a b) :
  lift k G A F (single a b) = b • F (multiplicative.of_add a) :=
by rw [lift_def, lift_nc_single, algebra.smul_def, ring_hom.coe_add_monoid_hom]

lemma lift_unique' (F : add_monoid_algebra k G →ₐ[k] A) :
  F = lift k G A ((F : add_monoid_algebra k G →* A).comp (of k G)) :=
((lift k G A).apply_symm_apply F).symm

/-- Decomposition of a `k`-algebra homomorphism from `monoid_algebra k G` by
its values on `F (single a 1)`. -/
lemma lift_unique (F : add_monoid_algebra k G →ₐ[k] A) (f : monoid_algebra k G) :
  F f = f.sum (λ a b, b • F (single a 1)) :=
by conv_lhs { rw lift_unique' F, simp [lift_apply] }

lemma alg_hom_ext_iff {φ₁ φ₂ : add_monoid_algebra k G →ₐ[k] A} :
  (∀ x, φ₁ (finsupp.single x 1) = φ₂ (finsupp.single x 1)) ↔ φ₁ = φ₂ :=
⟨λ h, alg_hom_ext h, by rintro rfl _; refl⟩

end lift

section
local attribute [reducible] add_monoid_algebra

universe ui
variable {ι : Type ui}

lemma prod_single [comm_semiring k] [add_comm_monoid G]
  {s : finset ι} {a : ι → G} {b : ι → k} :
  (∏ i in s, single (a i) (b i)) = single (∑ i in s, a i) (∏ i in s, b i) :=
finset.cons_induction_on s rfl $ λ a s has ih, by rw [prod_cons has, ih,
  single_mul_single, sum_cons has, prod_cons has]

end

lemma map_domain_algebra_map {A H F : Type*} [comm_semiring k] [semiring A]
  [algebra k A] [add_monoid G] [add_monoid H] [add_monoid_hom_class F G H] (f : F) (r : k) :
  map_domain f (algebra_map k (add_monoid_algebra A G) r) =
    algebra_map k (add_monoid_algebra A H) r :=
by simp only [function.comp_app, map_domain_single, add_monoid_algebra.coe_algebra_map, map_zero]

/-- If `f : G → H` is a homomorphism between two additive magmas, then `finsupp.map_domain f` is a
non-unital algebra homomorphism between their additive magma algebras. -/
@[simps]
def map_domain_non_unital_alg_hom (k A : Type*) [comm_semiring k] [semiring A] [algebra k A]
  {G H F : Type*} [has_add G] [has_add H] [add_hom_class F G H] (f : F) :
  add_monoid_algebra A G →ₙₐ[k] add_monoid_algebra A H :=
{ map_mul' := λ x y, map_domain_mul f x y,
  map_smul' := λ r x, map_domain_smul r x,
  ..(finsupp.map_domain.add_monoid_hom f : monoid_algebra A G →+ monoid_algebra A H) }

/-- If `f : G → H` is an additive homomorphism between two additive monoids, then
`finsupp.map_domain f` is an algebra homomorphism between their add monoid algebras. -/
@[simps] def map_domain_alg_hom (k A : Type*) [comm_semiring k] [semiring A] [algebra k A]
  [add_monoid G] {H F : Type*} [add_monoid H] [add_monoid_hom_class F G H] (f : F) :
  add_monoid_algebra A G →ₐ[k] add_monoid_algebra A H :=
{ commutes' := map_domain_algebra_map f,
  ..map_domain_ring_hom A f}

end add_monoid_algebra

variables [comm_semiring R] (k G)

/-- The algebra equivalence between `add_monoid_algebra` and `monoid_algebra` in terms of
`multiplicative`. -/
def add_monoid_algebra.to_multiplicative_alg_equiv [semiring k] [algebra R k] [add_monoid G] :
  add_monoid_algebra k G ≃ₐ[R] monoid_algebra k (multiplicative G) :=
{ commutes' := λ r, by simp [add_monoid_algebra.to_multiplicative],
  ..add_monoid_algebra.to_multiplicative k G }

/-- The algebra equivalence between `monoid_algebra` and `add_monoid_algebra` in terms of
`additive`. -/
def monoid_algebra.to_additive_alg_equiv [semiring k] [algebra R k] [monoid G] :
  monoid_algebra k G ≃ₐ[R] add_monoid_algebra k (additive G) :=
{ commutes' := λ r, by simp [monoid_algebra.to_additive],
  ..monoid_algebra.to_additive k G }


/-
Copyright (c) 2022 Jujian Zhang. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Jujian Zhang, Kevin Buzzard

! This file was ported from Lean 3 source module category_theory.preadditive.injective
! leanprover-community/mathlib commit f8d8465c3c392a93b9ed226956e26dee00975946
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.CategoryTheory.Preadditive.Projective

/-!
# Injective objects and categories with enough injectives

An object `J` is injective iff every morphism into `J` can be obtained by extending a monomorphism.
-/

noncomputable section

open CategoryTheory

open CategoryTheory.Limits

open Opposite

universe v v₁ v₂ u₁ u₂

namespace CategoryTheory

variable {C : Type u₁} [Category.{v₁} C]

/--
An object `J` is injective iff every morphism into `J` can be obtained by extending a monomorphism.
-/
class Injective (J : C) : Prop where
  Factors : ∀ {X Y : C} (g : X ⟶ J) (f : X ⟶ Y) [Mono f], ∃ h : Y ⟶ J, f ≫ h = g
#align category_theory.injective CategoryTheory.Injective

section

/-- An injective presentation of an object `X` consists of a monomorphism `f : X ⟶ J`
to some injective object `J`.
-/
@[nolint has_nonempty_instance]
structure InjectivePresentation (X : C) where
  j : C
  Injective : Injective J := by infer_instance
  f : X ⟶ J
  Mono : Mono f := by infer_instance
#align category_theory.injective_presentation CategoryTheory.InjectivePresentation

attribute [instance] injective_presentation.injective injective_presentation.mono

variable (C)

/-- A category "has enough injectives" if every object has an injective presentation,
i.e. if for every object `X` there is an injective object `J` and a monomorphism `X ↪ J`. -/
class EnoughInjectives : Prop where
  presentation : ∀ X : C, Nonempty (InjectivePresentation X)
#align category_theory.enough_injectives CategoryTheory.EnoughInjectives

end

namespace Injective

/--
Let `J` be injective and `g` a morphism into `J`, then `g` can be factored through any monomorphism.
-/
def factorThru {J X Y : C} [Injective J] (g : X ⟶ J) (f : X ⟶ Y) [Mono f] : Y ⟶ J :=
  (Injective.factors g f).some
#align category_theory.injective.factor_thru CategoryTheory.Injective.factorThru

@[simp]
theorem comp_factorThru {J X Y : C} [Injective J] (g : X ⟶ J) (f : X ⟶ Y) [Mono f] :
    f ≫ factorThru g f = g :=
  (Injective.factors g f).choose_spec
#align category_theory.injective.comp_factor_thru CategoryTheory.Injective.comp_factorThru

section

open ZeroObject

instance zero_injective [HasZeroObject C] [HasZeroMorphisms C] : Injective (0 : C)
    where Factors X Y g f mono := ⟨0, by ext⟩
#align category_theory.injective.zero_injective CategoryTheory.Injective.zero_injective

end

theorem of_iso {P Q : C} (i : P ≅ Q) (hP : Injective P) : Injective Q :=
  {
    Factors := fun X Y g f mono =>
      by
      obtain ⟨h, h_eq⟩ := @injective.factors C _ P _ _ _ (g ≫ i.inv) f mono
      refine' ⟨h ≫ i.hom, _⟩
      rw [← category.assoc, h_eq, category.assoc, iso.inv_hom_id, category.comp_id] }
#align category_theory.injective.of_iso CategoryTheory.Injective.of_iso

theorem iso_iff {P Q : C} (i : P ≅ Q) : Injective P ↔ Injective Q :=
  ⟨of_iso i, of_iso i.symm⟩
#align category_theory.injective.iso_iff CategoryTheory.Injective.iso_iff

/-- The axiom of choice says that every nonempty type is an injective object in `Type`. -/
instance (X : Type u₁) [Nonempty X] : Injective X
    where Factors Y Z g f mono :=
    ⟨fun z => by
      classical exact
          if h : z ∈ Set.range f then g (Classical.choose h) else Nonempty.some inferInstance,
      by
      ext y
      change dite _ _ _ = _
      split_ifs
      · rw [mono_iff_injective] at mono
        rw [mono (Classical.choose_spec h)]
      · exact False.elim (h ⟨y, rfl⟩)⟩

instance Type.enoughInjectives : EnoughInjectives (Type u₁)
    where presentation X :=
    Nonempty.intro
      { j := WithBot X
        Injective := inferInstance
        f := Option.some
        Mono := by
          rw [mono_iff_injective]
          exact Option.some_injective X }
#align category_theory.injective.Type.enough_injectives CategoryTheory.Injective.Type.enoughInjectives

instance {P Q : C} [HasBinaryProduct P Q] [Injective P] [Injective Q] : Injective (P ⨯ Q)
    where Factors X Y g f mono := by
    skip
    use limits.prod.lift (factor_thru (g ≫ limits.prod.fst) f) (factor_thru (g ≫ limits.prod.snd) f)
    simp only [prod.comp_lift, comp_factor_thru]
    ext
    · simp only [prod.lift_fst]
    · simp only [prod.lift_snd]

instance {β : Type v} (c : β → C) [HasProduct c] [∀ b, Injective (c b)] : Injective (∏ c)
    where Factors X Y g f mono := by
    skip
    refine' ⟨pi.lift fun b => factor_thru (g ≫ pi.π c _) f, _⟩
    ext ⟨j⟩
    simp only [category.assoc, limit.lift_π, fan.mk_π_app, comp_factor_thru]

instance {P Q : C} [HasZeroMorphisms C] [HasBinaryBiproduct P Q] [Injective P] [Injective Q] :
    Injective (P ⊞ Q)
    where Factors X Y g f mono := by
    skip
    refine' ⟨biprod.lift (factor_thru (g ≫ biprod.fst) f) (factor_thru (g ≫ biprod.snd) f), _⟩
    ext
    · simp only [category.assoc, biprod.lift_fst, comp_factor_thru]
    · simp only [category.assoc, biprod.lift_snd, comp_factor_thru]

instance {β : Type v} (c : β → C) [HasZeroMorphisms C] [HasBiproduct c] [∀ b, Injective (c b)] :
    Injective (⨁ c)
    where Factors X Y g f mono := by
    skip
    refine' ⟨biproduct.lift fun b => factor_thru (g ≫ biproduct.π _ _) f, _⟩
    ext
    simp only [category.assoc, biproduct.lift_π, comp_factor_thru]

instance {P : Cᵒᵖ} [Projective P] : Injective (unop P)
    where Factors X Y g f mono :=
    ⟨(@projective.factor_thru Cᵒᵖ _ P _ _ _ g.op f.op _).unop, Quiver.Hom.op_inj (by simp)⟩

instance {J : Cᵒᵖ} [Injective J] : Projective (unop J)
    where Factors E X f e he :=
    ⟨(@factor_thru Cᵒᵖ _ J _ _ _ f.op e.op _).unop, Quiver.Hom.op_inj (by simp)⟩

instance {J : C} [Injective J] : Projective (op J)
    where Factors E X f e epi :=
    ⟨(@factor_thru C _ J _ _ _ f.unop e.unop _).op, Quiver.Hom.unop_inj (by simp)⟩

instance {P : C} [Projective P] : Injective (op P)
    where Factors X Y g f mono :=
    ⟨(@projective.factor_thru C _ P _ _ _ g.unop f.unop _).op, Quiver.Hom.unop_inj (by simp)⟩

theorem injective_iff_projective_op {J : C} : Injective J ↔ Projective (op J) :=
  ⟨fun h => inferInstance, fun h => show Injective (unop (op J)) from inferInstance⟩
#align category_theory.injective.injective_iff_projective_op CategoryTheory.Injective.injective_iff_projective_op

theorem projective_iff_injective_op {P : C} : Projective P ↔ Injective (op P) :=
  ⟨fun h => inferInstance, fun h => show Projective (unop (op P)) from inferInstance⟩
#align category_theory.injective.projective_iff_injective_op CategoryTheory.Injective.projective_iff_injective_op

theorem injective_iff_preservesEpimorphisms_yoneda_obj (J : C) :
    Injective J ↔ (yoneda.obj J).PreservesEpimorphisms :=
  by
  rw [injective_iff_projective_op, projective.projective_iff_preserves_epimorphisms_coyoneda_obj]
  exact functor.preserves_epimorphisms.iso_iff (coyoneda.obj_op_op _)
#align category_theory.injective.injective_iff_preserves_epimorphisms_yoneda_obj CategoryTheory.Injective.injective_iff_preservesEpimorphisms_yoneda_obj

section Adjunction

open CategoryTheory.Functor

variable {D : Type u₂} [Category.{v₂} D]

variable {L : C ⥤ D} {R : D ⥤ C} [PreservesMonomorphisms L]

theorem injective_of_adjoint (adj : L ⊣ R) (J : D) [Injective J] : Injective <| R.obj J :=
  ⟨fun A A' g f im =>
    ⟨adj.hom_equiv _ _ (factor_thru ((adj.hom_equiv A J).symm g) (L.map f)),
      (adj.hom_equiv _ _).symm.Injective (by simp)⟩⟩
#align category_theory.injective.injective_of_adjoint CategoryTheory.Injective.injective_of_adjoint

end Adjunction

section EnoughInjectives

variable [EnoughInjectives C]

/-- `injective.under X` provides an arbitrarily chosen injective object equipped with
an monomorphism `injective.ι : X ⟶ injective.under X`.
-/
def under (X : C) : C :=
  (EnoughInjectives.presentation X).some.j
#align category_theory.injective.under CategoryTheory.Injective.under

instance injective_under (X : C) : Injective (under X) :=
  (EnoughInjectives.presentation X).some.Injective
#align category_theory.injective.injective_under CategoryTheory.Injective.injective_under

/-- The monomorphism `injective.ι : X ⟶ injective.under X`
from the arbitrarily chosen injective object under `X`.
-/
def ι (X : C) : X ⟶ under X :=
  (EnoughInjectives.presentation X).some.f
#align category_theory.injective.ι CategoryTheory.Injective.ι

instance ι_mono (X : C) : Mono (ι X) :=
  (EnoughInjectives.presentation X).some.Mono
#align category_theory.injective.ι_mono CategoryTheory.Injective.ι_mono

section

variable [HasZeroMorphisms C] {X Y : C} (f : X ⟶ Y) [HasCokernel f]

/-- When `C` has enough injectives, the object `injective.syzygies f` is
an arbitrarily chosen injective object under `cokernel f`.
-/
def syzygies : C :=
  under (cokernel f)deriving Injective
#align category_theory.injective.syzygies CategoryTheory.Injective.syzygies

/-- When `C` has enough injective,
`injective.d f : Y ⟶ syzygies f` is the composition
`cokernel.π f ≫ ι (cokernel f)`.

(When `C` is abelian, we have `exact f (injective.d f)`.)
-/
abbrev d : Y ⟶ syzygies f :=
  cokernel.π f ≫ ι (cokernel f)
#align category_theory.injective.d CategoryTheory.Injective.d

end

end EnoughInjectives

instance [EnoughInjectives C] : EnoughProjectives Cᵒᵖ :=
  ⟨fun X => ⟨⟨_, inferInstance, (Injective.ι (unop X)).op, inferInstance⟩⟩⟩

instance [EnoughProjectives C] : EnoughInjectives Cᵒᵖ :=
  ⟨fun X => ⟨⟨_, inferInstance, (Projective.π (unop X)).op, inferInstance⟩⟩⟩

theorem enoughProjectives_of_enoughInjectives_op [EnoughInjectives Cᵒᵖ] : EnoughProjectives C :=
  ⟨fun X => ⟨⟨_, inferInstance, (Injective.ι (op X)).unop, inferInstance⟩⟩⟩
#align category_theory.injective.enough_projectives_of_enough_injectives_op CategoryTheory.Injective.enoughProjectives_of_enoughInjectives_op

theorem enoughInjectives_of_enoughProjectives_op [EnoughProjectives Cᵒᵖ] : EnoughInjectives C :=
  ⟨fun X => ⟨⟨_, inferInstance, (Projective.π (op X)).unop, inferInstance⟩⟩⟩
#align category_theory.injective.enough_injectives_of_enough_projectives_op CategoryTheory.Injective.enoughInjectives_of_enoughProjectives_op

open Injective

section

variable [HasZeroMorphisms C] [HasImages Cᵒᵖ] [HasEqualizers Cᵒᵖ]

/-- Given a pair of exact morphism `f : Q ⟶ R` and `g : R ⟶ S` and a map `h : R ⟶ J` to an injective
object `J` such that `f ≫ h = 0`, then `g` descents to a map `S ⟶ J`. See below:

```
Q --- f --> R --- g --> S
            |
            | h
            v
            J
```
-/
def Exact.desc {J Q R S : C} [Injective J] (h : R ⟶ J) (f : Q ⟶ R) (g : R ⟶ S)
    (hgf : Exact g.op f.op) (w : f ≫ h = 0) : S ⟶ J :=
  (Exact.lift h.op g.op f.op hgf (congr_arg Quiver.Hom.op w)).unop
#align category_theory.injective.exact.desc CategoryTheory.Injective.Exact.desc

@[simp]
theorem Exact.comp_desc {J Q R S : C} [Injective J] (h : R ⟶ J) (f : Q ⟶ R) (g : R ⟶ S)
    (hgf : Exact g.op f.op) (w : f ≫ h = 0) : g ≫ Exact.desc h f g hgf w = h := by
  convert congr_arg Quiver.Hom.unop (exact.lift_comp h.op g.op f.op hgf (congr_arg Quiver.Hom.op w))
#align category_theory.injective.exact.comp_desc CategoryTheory.Injective.Exact.comp_desc

end

end Injective

namespace Adjunction

variable {D : Type _} [Category D] {F : C ⥤ D} {G : D ⥤ C}

theorem map_injective (adj : F ⊣ G) [F.PreservesMonomorphisms] (I : D) (hI : Injective I) :
    Injective (G.obj I) :=
  ⟨fun X Y f g => by
    intro
    rcases hI.factors (F.map f ≫ adj.counit.app _) (F.map g) with ⟨⟩
    use adj.unit.app Y ≫ G.map w
    rw [← unit_naturality_assoc, ← G.map_comp, h]
    simp⟩
#align category_theory.adjunction.map_injective CategoryTheory.Adjunction.map_injective

theorem injective_of_map_injective (adj : F ⊣ G) [Full G] [Faithful G] (I : D)
    (hI : Injective (G.obj I)) : Injective I :=
  ⟨fun X Y f g => by
    intro
    haveI := adj.right_adjoint_preserves_limits
    rcases hI.factors (G.map f) (G.map g) with ⟨⟩
    use inv (adj.counit.app _) ≫ F.map w ≫ adj.counit.app _
    refine' faithful.map_injective G _
    simpa⟩
#align category_theory.adjunction.injective_of_map_injective CategoryTheory.Adjunction.injective_of_map_injective

/-- Given an adjunction `F ⊣ G` such that `F` preserves monos, `G` maps an injective presentation
of `X` to an injective presentation of `G(X)`. -/
def mapInjectivePresentation (adj : F ⊣ G) [F.PreservesMonomorphisms] (X : D)
    (I : InjectivePresentation X) : InjectivePresentation (G.obj X)
    where
  j := G.obj I.j
  Injective := adj.map_injective _ I.Injective
  f := G.map I.f
  Mono := by haveI := adj.right_adjoint_preserves_limits <;> infer_instance
#align category_theory.adjunction.map_injective_presentation CategoryTheory.Adjunction.mapInjectivePresentation

end Adjunction

namespace Equivalence

variable {D : Type _} [Category D] (F : C ≌ D)

/-- Given an equivalence of categories `F`, an injective presentation of `F(X)` induces an
injective presentation of `X.` -/
def injectivePresentationOfMapInjectivePresentation (X : C)
    (I : InjectivePresentation (F.Functor.obj X)) : InjectivePresentation X
    where
  j := F.inverse.obj I.j
  Injective := Adjunction.map_injective F.toAdjunction I.j I.Injective
  f := F.Unit.app _ ≫ F.inverse.map I.f
  Mono := mono_comp _ _
#align category_theory.equivalence.injective_presentation_of_map_injective_presentation CategoryTheory.Equivalence.injectivePresentationOfMapInjectivePresentation

theorem enoughInjectives_iff (F : C ≌ D) : EnoughInjectives C ↔ EnoughInjectives D :=
  by
  constructor
  all_goals intro H; constructor; intro X; constructor
  ·
    exact
      F.symm.injective_presentation_of_map_injective_presentation _
        (Nonempty.some (H.presentation (F.inverse.obj X)))
  ·
    exact
      F.injective_presentation_of_map_injective_presentation X
        (Nonempty.some (H.presentation (F.functor.obj X)))
#align category_theory.equivalence.enough_injectives_iff CategoryTheory.Equivalence.enoughInjectives_iff

end Equivalence

end CategoryTheory


/-
Copyright (c) 2021 Apurva Nakade. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Apurva Nakade
-/
import algebra.algebra.basic
import ring_theory.localization.away
import set_theory.game.birthday
import set_theory.surreal.basic

/-!
# Dyadic numbers
Dyadic numbers are obtained by localizing ℤ away from 2. They are the initial object in the category
of rings with no 2-torsion.

## Dyadic surreal numbers
We construct dyadic surreal numbers using the canonical map from ℤ[2 ^ {-1}] to surreals.
As we currently do not have a ring structure on `surreal` we construct this map explicitly. Once we
have the ring structure, this map can be constructed directly by sending `2 ^ {-1}` to `half`.

## Embeddings
The above construction gives us an abelian group embedding of ℤ into `surreal`. The goal is to
extend this to an embedding of dyadic rationals into `surreal` and use Cauchy sequences of dyadic
rational numbers to construct an ordered field embedding of ℝ into `surreal`.
-/

universes u

local infix ` ≈ ` := pgame.equiv

namespace pgame

/-- For a natural number `n`, the pre-game `pow_half (n + 1)` is recursively defined as
`{0 | pow_half n}`. These are the explicit expressions of powers of `1 / 2`. By definition, we have
`pow_half 0 = 1` and `pow_half 1 ≈ 1 / 2` and we prove later on that
`pow_half (n + 1) + pow_half (n + 1) ≈ pow_half n`. -/
def pow_half : ℕ → pgame
| 0       := 1
| (n + 1) := ⟨punit, punit, 0, λ _, pow_half n⟩

@[simp] lemma pow_half_zero : pow_half 0 = 1 := rfl

lemma pow_half_left_moves (n) : (pow_half n).left_moves = punit := by cases n; refl
lemma pow_half_zero_right_moves : (pow_half 0).right_moves = pempty := rfl
lemma pow_half_succ_right_moves (n) : (pow_half (n + 1)).right_moves = punit := rfl

@[simp] lemma pow_half_move_left (n i) : (pow_half n).move_left i = 0 :=
by cases n; cases i; refl
@[simp] lemma pow_half_succ_move_right (n i) : (pow_half (n + 1)).move_right i = pow_half n :=
rfl

instance unique_pow_half_left_moves (n) : unique (pow_half n).left_moves :=
by cases n; exact punit.unique
instance is_empty_pow_half_zero_right_moves : is_empty (pow_half 0).right_moves :=
pempty.is_empty
instance unique_pow_half_succ_right_moves (n) : unique (pow_half (n + 1)).right_moves :=
punit.unique

@[simp]

/-- For all natural numbers `n`, the pre-games `pow_half n` are numeric. -/
theorem numeric_pow_half (n) : (pow_half n).numeric :=
begin
  induction n with n hn,
  { exact numeric_one },
  { split,
    { simpa using hn.move_left_lt default },
    { exact ⟨λ _, numeric_zero, λ _, hn⟩ } }
end

theorem pow_half_succ_lt_pow_half (n : ℕ) : pow_half (n + 1) < pow_half n :=
(numeric_pow_half (n + 1)).lt_move_right default

theorem pow_half_succ_le_pow_half (n : ℕ) : pow_half (n + 1) ≤ pow_half n :=
(pow_half_succ_lt_pow_half n).le

theorem pow_half_le_one (n : ℕ) : pow_half n ≤ 1 :=
begin
  induction n with n hn,
  { exact le_rfl },
  { exact (pow_half_succ_le_pow_half n).trans hn }
end

theorem pow_half_succ_lt_one (n : ℕ) : pow_half (n + 1) < 1 :=
(pow_half_succ_lt_pow_half n).trans_le $ pow_half_le_one n

theorem pow_half_pos (n : ℕ) : 0 < pow_half n :=
by { rw [←lf_iff_lt numeric_zero (numeric_pow_half n), zero_lf_le], simp }

theorem zero_le_pow_half (n : ℕ) : 0 ≤ pow_half n :=
(pow_half_pos n).le

theorem add_pow_half_succ_self_eq_pow_half (n) : pow_half (n + 1) + pow_half (n + 1) ≈ pow_half n :=
begin
  induction n using nat.strong_induction_on with n hn,
  { split; rw le_iff_forall_lf; split,
    { rintro (⟨⟨ ⟩⟩ | ⟨⟨ ⟩⟩); apply lf_of_lt,
      { calc 0 + pow_half n.succ ≈ pow_half n.succ : zero_add_equiv _
                             ... < pow_half n      : pow_half_succ_lt_pow_half n },
      { calc pow_half n.succ + 0 ≈ pow_half n.succ : add_zero_equiv _
                             ... < pow_half n      : pow_half_succ_lt_pow_half n } },
    { cases n, { rintro ⟨ ⟩ },
      rintro ⟨ ⟩,
      apply lf_of_move_right_le,
      swap, exact sum.inl default,
      calc  pow_half n.succ + pow_half (n.succ + 1)
          ≤ pow_half n.succ + pow_half n.succ : add_le_add_left (pow_half_succ_le_pow_half _) _
      ... ≈ pow_half n                        : hn _ (nat.lt_succ_self n) },
    { simp only [pow_half_move_left, forall_const],
      apply lf_of_lt,
      calc 0 ≈ 0 + 0                            : (add_zero_equiv 0).symm
        ... ≤ pow_half n.succ + 0               : add_le_add_right (zero_le_pow_half _) _
        ... < pow_half n.succ + pow_half n.succ : add_lt_add_left (pow_half_pos _) _ },
    { rintro (⟨⟨ ⟩⟩ | ⟨⟨ ⟩⟩); apply lf_of_lt,
      { calc pow_half n
            ≈ pow_half n + 0               : (add_zero_equiv _).symm
        ... < pow_half n + pow_half n.succ : add_lt_add_left (pow_half_pos _) _ },
      { calc pow_half n
            ≈ 0 + pow_half n               : (zero_add_equiv _).symm
        ... < pow_half n.succ + pow_half n : add_lt_add_right (pow_half_pos _) _  } } }
end

theorem half_add_half_equiv_one : pow_half 1 + pow_half 1 ≈ 1 :=
add_pow_half_succ_self_eq_pow_half 0

end pgame

namespace surreal
open pgame

/-- Powers of the surreal number `half`. -/
def pow_half (n : ℕ) : surreal := ⟦⟨pgame.pow_half n, pgame.numeric_pow_half n⟩⟧

@[simp] lemma pow_half_zero : pow_half 0 = 1 := rfl

@[simp] lemma double_pow_half_succ_eq_pow_half (n : ℕ) : 2 • pow_half n.succ = pow_half n :=
by { rw two_nsmul, exact quotient.sound (pgame.add_pow_half_succ_self_eq_pow_half n) }

@[simp] lemma nsmul_pow_two_pow_half (n : ℕ) : 2 ^ n • pow_half n = 1 :=
begin
  induction n with n hn,
  { simp only [nsmul_one, pow_half_zero, nat.cast_one, pow_zero] },
  { rw [← hn, ← double_pow_half_succ_eq_pow_half n, smul_smul (2^n) 2 (pow_half n.succ),
        mul_comm, pow_succ] }
end

@[simp] lemma nsmul_pow_two_pow_half' (n k : ℕ) : 2 ^ n • pow_half (n + k) = pow_half k :=
begin
  induction k with k hk,
  { simp only [add_zero, surreal.nsmul_pow_two_pow_half, nat.nat_zero_eq_zero, eq_self_iff_true,
               surreal.pow_half_zero] },
  { rw [← double_pow_half_succ_eq_pow_half (n + k), ← double_pow_half_succ_eq_pow_half k,
        smul_algebra_smul_comm] at hk,
    rwa ← zsmul_eq_zsmul_iff' two_ne_zero }
end

lemma zsmul_pow_two_pow_half (m : ℤ) (n k : ℕ) :
  (m * 2 ^ n) • pow_half (n + k) = m • pow_half k :=
begin
  rw mul_zsmul,
  congr,
  norm_cast,
  exact nsmul_pow_two_pow_half' n k
end

lemma dyadic_aux {m₁ m₂ : ℤ} {y₁ y₂ : ℕ} (h₂ : m₁ * (2 ^ y₁) = m₂ * (2 ^ y₂)) :
  m₁ • pow_half y₂ = m₂ • pow_half y₁ :=
begin
  revert m₁ m₂,
  wlog h : y₁ ≤ y₂,
  intros m₁ m₂ h₂,
  obtain ⟨c, rfl⟩ := le_iff_exists_add.mp h,
  rw [add_comm, pow_add, ← mul_assoc, mul_eq_mul_right_iff] at h₂,
  cases h₂,
  { rw [h₂, add_comm, zsmul_pow_two_pow_half m₂ c y₁] },
  { have := nat.one_le_pow y₁ 2 nat.succ_pos',
    norm_cast at h₂, linarith },
end

/-- The additive monoid morphism `dyadic_map` sends ⟦⟨m, 2^n⟩⟧ to m • half ^ n. -/
def dyadic_map : localization.away (2 : ℤ) →+ surreal :=
{ to_fun :=
  λ x, localization.lift_on x (λ x y, x • pow_half (submonoid.log y)) $
  begin
    intros m₁ m₂ n₁ n₂ h₁,
    obtain ⟨⟨n₃, y₃, hn₃⟩, h₂⟩ := localization.r_iff_exists.mp h₁,
    simp only [subtype.coe_mk, mul_eq_mul_right_iff] at h₂,
    cases h₂,
    { simp only,
      obtain ⟨a₁, ha₁⟩ := n₁.prop,
      obtain ⟨a₂, ha₂⟩ := n₂.prop,
      have hn₁ : n₁ = submonoid.pow 2 a₁ := subtype.ext ha₁.symm,
      have hn₂ : n₂ = submonoid.pow 2 a₂ := subtype.ext ha₂.symm,
      have h₂ : 1 < (2 : ℤ).nat_abs, from one_lt_two,
      rw [hn₁, hn₂, submonoid.log_pow_int_eq_self h₂, submonoid.log_pow_int_eq_self h₂],
      apply dyadic_aux,
      rwa [ha₁, ha₂] },
    { have : (1 : ℤ) ≤ 2 ^ y₃ := by exact_mod_cast nat.one_le_pow y₃ 2 nat.succ_pos',
      linarith }
    end,
  map_zero' := localization.lift_on_zero _ _,
  map_add' := λ x y, localization.induction_on₂ x y $
  begin
    rintro ⟨a, ⟨b, ⟨b', rfl⟩⟩⟩ ⟨c, ⟨d, ⟨d', rfl⟩⟩⟩,
    have h₂ : 1 < (2 : ℤ).nat_abs, from one_lt_two,
    have hpow₂ := submonoid.log_pow_int_eq_self h₂,
    simp_rw submonoid.pow_apply at hpow₂,
    simp_rw [localization.add_mk, localization.lift_on_mk, subtype.coe_mk,
      submonoid.log_mul (int.pow_right_injective h₂), hpow₂],
    calc (2 ^ b' * c + 2 ^ d' * a) • pow_half (b' + d')
        = (c * 2 ^ b') • pow_half (b' + d') + (a * 2 ^ d') • pow_half (d' + b')
        : by simp only [add_smul, mul_comm,add_comm]
    ... = c • pow_half d' + a • pow_half b' : by simp only [zsmul_pow_two_pow_half]
    ... = a • pow_half b' + c • pow_half d' : add_comm _ _,
  end }

@[simp] lemma dyadic_map_apply (m : ℤ) (p : submonoid.powers (2 : ℤ)) :
  dyadic_map (is_localization.mk' (localization (submonoid.powers 2)) m p) =
  m • pow_half (submonoid.log p) :=
by { rw ← localization.mk_eq_mk', refl }

@[simp] lemma dyadic_map_apply_pow (m : ℤ) (n : ℕ) :
  dyadic_map (is_localization.mk' (localization (submonoid.powers 2)) m (submonoid.pow 2 n)) =
  m • pow_half n :=
by rw [dyadic_map_apply, @submonoid.log_pow_int_eq_self 2 one_lt_two]

/-- We define dyadic surreals as the range of the map `dyadic_map`. -/
def dyadic : set surreal := set.range dyadic_map

-- We conclude with some ideas for further work on surreals; these would make fun projects.

-- TODO show that the map from dyadic rationals to surreals is injective

-- TODO map the reals into the surreals, using dyadic Dedekind cuts
-- TODO show this is a group homomorphism, and injective

-- TODO show the maps from the dyadic rationals and from the reals
-- into the surreals are multiplicative

end surreal


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

! This file was ported from Lean 3 source module logic.lemmas
! leanprover-community/mathlib commit 2ed7e4aec72395b6a7c3ac4ac7873a7a43ead17c
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathlib.Logic.Basic
import Mathlib.Tactic.Convert
import Mathlib.Tactic.SplitIfs

/-!
# More basic logic properties
A few more logic lemmas. These are in their own file, rather than `Logic.Basic`, because it is
convenient to be able to use the `split_ifs` tactic.
## Implementation notes
We spell those lemmas out with `dite` and `ite` rather than the `if then else` notation because this
would result in less delta-reduced statements.
-/

alias heq_iff_eq ↔ HEq.eq Eq.heq
#align heq.eq HEq.eq
#align eq.heq Eq.heq

-- Porting note: we may need to modify `alias` so we can make aliases protected at creation.
-- attribute [protected] HEq.eq Eq.heq

variable {α : Sort _} {p q r : Prop} [Decidable p] [Decidable q] {a b c : α}

theorem dite_dite_distrib_left {a : p → α} {b : ¬p → q → α} {c : ¬p → ¬q → α} :
    (dite p a fun hp ↦ dite q (b hp) (c hp)) =
      dite q (fun hq ↦ (dite p a) fun hp ↦ b hp hq) fun hq ↦ (dite p a) fun hp ↦ c hp hq := by
  split_ifs <;> rfl
#align dite_dite_distrib_left dite_dite_distrib_left

theorem dite_dite_distrib_right {a : p → q → α} {b : p → ¬q → α} {c : ¬p → α} :
    dite p (fun hp ↦ dite q (a hp) (b hp)) c =
      dite q (fun hq ↦ dite p (fun hp ↦ a hp hq) c) fun hq ↦ dite p (fun hp ↦ b hp hq) c := by
  split_ifs <;> rfl
#align dite_dite_distrib_right dite_dite_distrib_right

theorem ite_dite_distrib_left {a : α} {b : q → α} {c : ¬q → α} :
    ite p a (dite q b c) = dite q (fun hq ↦ ite p a <| b hq) fun hq ↦ ite p a <| c hq :=
  dite_dite_distrib_left
#align ite_dite_distrib_left ite_dite_distrib_left

theorem ite_dite_distrib_right {a : q → α} {b : ¬q → α} {c : α} :
    ite p (dite q a b) c = dite q (fun hq ↦ ite p (a hq) c) fun hq ↦ ite p (b hq) c :=
  dite_dite_distrib_right
#align ite_dite_distrib_right ite_dite_distrib_right

theorem dite_ite_distrib_left {a : p → α} {b : ¬p → α} {c : ¬p → α} :
    (dite p a fun hp ↦ ite q (b hp) (c hp)) = ite q (dite p a b) (dite p a c) :=
  dite_dite_distrib_left
#align dite_ite_distrib_left dite_ite_distrib_left

theorem dite_ite_distrib_right {a : p → α} {b : p → α} {c : ¬p → α} :
    dite p (fun hp ↦ ite q (a hp) (b hp)) c = ite q (dite p a c) (dite p b c) :=
  dite_dite_distrib_right
#align dite_ite_distrib_right dite_ite_distrib_right

theorem ite_ite_distrib_left : ite p a (ite q b c) = ite q (ite p a b) (ite p a c) :=
  dite_dite_distrib_left
#align ite_ite_distrib_left ite_ite_distrib_left

theorem ite_ite_distrib_right : ite p (ite q a b) c = ite q (ite p a c) (ite p b c) :=
  dite_dite_distrib_right
#align ite_ite_distrib_right ite_ite_distrib_right

lemma Prop.forall {f : Prop → Prop} : (∀ p, f p) ↔ f True ∧ f False :=
⟨fun h ↦ ⟨h _, h _⟩, by rintro ⟨h₁, h₀⟩ p; by_cases hp : p <;> simp only [hp] <;> assumption⟩
#align Prop.forall Prop.forall

lemma Prop.exists {f : Prop → Prop} : (∃ p, f p) ↔ f True ∨ f False :=
⟨fun ⟨p, h⟩ ↦ by refine' (em p).imp _ _ <;> intro H <;> convert h <;> simp [H],
  by rintro (h | h) <;> exact ⟨_, h⟩⟩
#align Prop.exists Prop.exists


import GMLInit.Data.Index.Basic
import GMLInit.Data.Index.Bind
import GMLInit.Data.Index.Map

namespace List
variable {α} (p : α → Prop) [DecidablePred p]

protected def sublist : List α → List { x // p x}
| [] => []
| x :: xs => if h: p x then ⟨x,h⟩ :: List.sublist xs else List.sublist xs

theorem sublist_pos {α} {p : α → Prop} [DecidablePred p] {x : α} {xs : List α} (h : p x) : (x :: xs).sublist p = ⟨x,h⟩ :: xs.sublist p := dif_pos h

theorem sublist_neg {α} {p : α → Prop} [DecidablePred p] {x : α} {xs : List α} (h : ¬ p x) : (x :: xs).sublist p = xs.sublist p := dif_neg h

end List

namespace Index
variable {α} (p : α → Prop) [DecidablePred p]

def sublist : {xs : List α} → (i : Index xs) → p i.val → Index (xs.sublist p)
| x :: xs, i, hi =>
  if hh : p x then
    have : (x :: xs).sublist p = ⟨x,hh⟩ :: xs.sublist p := dif_pos hh
    match i with
    | head => this ▸ head
    | tail i => this ▸ tail (sublist i hi)
  else
    have : (x :: xs).sublist p = xs.sublist p := dif_neg hh
    match i with
    | head => absurd hi hh
    | tail i => this ▸ sublist i hi

section
variable {p}

theorem sublist_pos_head {x : α} {xs : List α} (h : p x) : (head:Index (x::xs)).sublist p h = ((List.sublist_pos h).symm ▸ head) := dif_pos h

theorem sublist_pos_tail {x : α} {xs : List α} (h : p x) (i : Index xs) (hi : p i.val) : (tail i:Index (x::xs)).sublist p hi = ((List.sublist_pos h).symm ▸ tail (i.sublist p hi)) := dif_pos h

theorem sublist_neg_tail {x : α} {xs : List α} (h : ¬ p x) (i : Index xs) (hi : p i.val) : (tail i:Index (x::xs)).sublist p hi = ((List.sublist_neg h).symm ▸ i.sublist p hi) := dif_neg h

end

def unsublist : {xs : List α} → (i : Index (xs.sublist p)) → Index xs
| x :: xs, i =>
  if hh : p x then
    have : (x :: xs).sublist p = ⟨x,hh⟩ :: xs.sublist p := dif_pos hh
    match ((List.sublist_pos hh).symm ▸ i : Index (⟨x,hh⟩ :: xs.sublist p)) with
    | head => head
    | tail i => tail (unsublist i)
  else
    have : (x :: xs).sublist p = xs.sublist p := dif_neg hh
    tail (unsublist (this ▸ i))

section
variable {p}

theorem unsublist_pos_head {x : α} {xs : List α} (h : p x) : ((List.sublist_pos h) ▸ (head : Index (⟨x,h⟩ :: xs.sublist p)) : Index ((x :: xs).sublist p)).unsublist p = head := by
  clean unfold unsublist
  rw [dif_pos h]
  split
  next => rfl
  next i hh => elim_casts at hh; contradiction

theorem unsublist_pos_tail {x : α} {xs : List α} (h : p x) (i : Index (xs.sublist p)) : ((List.sublist_pos h) ▸ (tail i : Index (⟨x,h⟩ :: xs.sublist p)) : Index ((x :: xs).sublist p)).unsublist p = tail (i.unsublist p) := by
  simp only [unsublist]
  rw [dif_pos h]
  split
  next i hh => elim_casts at hh; cases hh
  next i hh => elim_casts at hh; cases hh; rfl

theorem unsublist_neg_tail {x : α} {xs : List α} (h : ¬ p x) (i : Index (xs.sublist p)) : ((List.sublist_neg h).symm ▸ i : Index ((x :: xs).sublist p)).unsublist p = tail (i.unsublist p) := by
  simp only [unsublist]
  rw [dif_neg h]
  congr
  elim_casts

end

theorem sublist_eq_iff_eq_unsublist {xs : List α} (i : Index xs) (hi : p i.val) (j : Index (xs.sublist p)) :
  i.sublist p hi = j ↔ i = j.unsublist := by
  induction xs with
  | nil => contradiction
  | cons x xs ih =>
    by_cases p x with
    | isTrue hx =>
      cases i with
      | head =>
        rw [sublist_pos_head hx]
        constr
        · intro h
          rw [←h, unsublist_pos_head]
        · intro h
          rw [unsublist, dif_pos hx] at h
          split at h
          next hh => rw [←hh, eqNdrec_symm]
          next => contradiction
      | tail i =>
        rw [sublist_pos_tail hx]
        constr
        · intro h
          rw [←h, unsublist_pos_tail]
          apply congrArg
          rw [←ih]
        · intro h
          simp [unsublist, hx] at h
          split at h
          next => contradiction
          next j ht =>
            cases h
            rw [eqNdrec_symm] at ht
            cases ht
            elim_casts
            apply congrArg
            rw [ih]
    | isFalse hx =>
      cases i with
      | head => absurd hx; exact hi
      | tail i =>
        rw [sublist_neg_tail hx]
        constr
        · intro heq
          cases heq
          rw [unsublist_neg_tail hx]
          apply congrArg
          rw [←ih]
        · intro heq
          simp [unsublist, hx] at heq
          cases heq
          rw [eqNdrec_symm]
          rw [ih]

theorem unsublist_sublist {xs : List α} (i : Index xs) (hi : p i.val) : (i.sublist p hi).unsublist p = i := by
  induction i with
  | head =>
    rw [sublist_pos_head]
    rw [unsublist_pos_head]
  | @tail x xs i ih =>
    by_cases p x with
    | isTrue hh =>
      rw [sublist_pos_tail hh]
      rw [unsublist_pos_tail hh]
      rw [ih]
    | isFalse hh =>
      rw [sublist_neg_tail hh]
      rw [unsublist_neg_tail hh]
      rw [ih]

theorem sublist_unsublist {xs : List α} (i : Index (xs.sublist p)) (hi : p (i.unsublist p).val) : (i.unsublist p).sublist p hi = i := by
  rw [sublist_eq_iff_eq_unsublist]

theorem val_unsublist_eq_val_val {xs : List α} (i : Index (xs.sublist p)) : (i.unsublist p).val = i.val.val := by
  induction xs with
  | nil => contradiction
  | cons x xs ih =>
    by_cases p x with
    | isTrue hx =>
      clean unfold unsublist
      rw [dif_pos hx]
      split
      next h =>
        rw [eqNdrec_symm] at h
        cases h
        rw [val_ndrec _ (List.sublist_pos hx).symm.symm.symm]
      next h =>
        rw [eqNdrec_symm] at h
        cases h
        rw [val_ndrec _ (List.sublist_pos hx).symm.symm.symm]
        rw [val_tail, val_tail]
        apply ih
    | isFalse hx =>
      clean unfold unsublist
      rw [dif_neg hx]
      rw [val_tail]
      rw [ih]
      apply congrArg
      rw [val_ndrec]

def sublistEquiv (xs : List α) : Equiv { i : Index xs // p i.val } (Index (xs.sublist p)) where
  fwd | ⟨i,hi⟩ => sublist p i hi
  rev i := ⟨unsublist p i, val_unsublist_eq_val_val p i ▸ i.val.property⟩
  spec := by
    intros i j
    clean
    rw [sublist_eq_iff_eq_unsublist]
    constr
    · intro h
      apply Subtype.eq
      rw [h]
    · intro h
      rw [←h]

end Index