/-
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.algebra.equiv
import algebra.big_operators.finsupp
import algebra.hom.non_unital_alg
import algebra.module.big_operators
import linear_algebra.finsupp

/-!
# Monoid algebras

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

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 haveI := classical.dec_eq G;
    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 haveI := classical.dec_eq G;
    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 }

lemma nat_cast_def (n : ℕ) : (n : monoid_algebra k G) = single 1 n := rfl

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) :=
{ int_cast                    := λ z, single 1 (z : k),
  int_cast_of_nat             := λ n, by simpa,
  int_cast_neg_succ_of_nat    := λ n, by simpa,
  .. monoid_algebra.add_comm_group,
  .. monoid_algebra.non_assoc_semiring }

lemma int_cast_def [ring k] [mul_one_class G] (z : ℤ) : (z : monoid_algebra k G) = single 1 z := rfl

instance [ring k] [monoid G] : ring (monoid_algebra k G) :=
{ .. monoid_algebra.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 [semiring k] [smul_zero_class R k] :
  smul_zero_class R (monoid_algebra k G) :=
finsupp.smul_zero_class

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

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_smul 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) :=
by classical; exact
let F : G × G → k := λ p, 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 ×ˢ g.support, F p : finset.sum_product.symm
... = ∑ p in (f.support ×ˢ 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

@[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 mul_single_apply_of_not_exists_mul [has_mul G] (r : k) {g g' : G} (x : monoid_algebra k G)
  (h : ¬∃ d, g' = d * g):
  (x * finsupp.single g r : monoid_algebra k G) g' = 0 :=
begin
  classical,
  rw [mul_apply, finsupp.sum_comm, finsupp.sum_single_index],
  swap,
  { simp_rw [finsupp.sum, mul_zero, if_t_t, finset.sum_const_zero] },
  { apply finset.sum_eq_zero,
    simp_rw ite_eq_right_iff,
    rintros g'' hg'' rfl,
    exfalso,
    exact h ⟨_, rfl⟩ }
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 single_mul_apply_of_not_exists_mul [has_mul G] (r : k) {g g' : G} (x : monoid_algebra k G)
  (h : ¬∃ d, g' = g * d):
  (finsupp.single g r * x : monoid_algebra k G) g' = 0 :=
begin
  classical,
  rw [mul_apply, finsupp.sum_single_index],
  swap,
  { simp_rw [finsupp.sum, zero_mul, if_t_t, finset.sum_const_zero] },
  { apply finset.sum_eq_zero,
    simp_rw ite_eq_right_iff,
    rintros g'' hg'' rfl,
    exfalso,
    exact h ⟨_, rfl⟩ },
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) [semiring k] [distrib_smul 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
  classical,
  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 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 haveI := classical.dec_eq G;
    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 haveI := classical.dec_eq G;
    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 }

lemma nat_cast_def (n : ℕ) : (n : add_monoid_algebra k G) = single 0 n := rfl

end mul_one_class

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

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

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) :=
{ int_cast                    := λ z, single 0 (z : k),
  int_cast_of_nat             := λ n, by simpa,
  int_cast_neg_succ_of_nat    := λ n, by simpa,
  .. add_monoid_algebra.add_comm_group,
  .. add_monoid_algebra.non_assoc_semiring }

lemma int_cast_def [ring k] [add_zero_class G] (z : ℤ) :
  (z : add_monoid_algebra k G) = single 0 z := rfl

instance [ring k] [add_monoid G] : ring (add_monoid_algebra k G) :=
{ .. add_monoid_algebra.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_smul 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 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 mul_single_apply_of_not_exists_add [has_add G] (r : k) {g g' : G} (x : add_monoid_algebra k G)
  (h : ¬∃ d, g' = d + g):
  (x * finsupp.single g r : add_monoid_algebra k G) g' = 0 :=
@monoid_algebra.mul_single_apply_of_not_exists_mul k (multiplicative G) _ _ _ _ _ _ h

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 single_mul_apply_of_not_exists_add [has_add G] (r : k) {g g' : G} (x : add_monoid_algebra k G)
  (h : ¬∃ d, g' = g + d):
  (finsupp.single g r * x : add_monoid_algebra k G) g' = 0 :=
@monoid_algebra.single_mul_apply_of_not_exists_mul k (multiplicative G) _ _ _ _ _ _ h

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

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) [semiring k] [distrib_smul 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 }


import data.nat.basic
open nat
def island_rules : ℕ → ℕ → (ℕ → Prop)
| 0        b :=  λ bb, (bb = b ∨ bb = b - 1) ∧ bb > 0
| (succ d) b := (λ bb, (island_rules d b) bb ∧
                ((∀ c, (island_rules d b) c → c = b) ↔ (∀ c, (island_rules d bb) c → c = bb)))
theorem init_island {d b bb} : (island_rules d b) bb → (bb = b ∨ bb = b - 1) ∧ bb > 0 := begin
    induction d with d hi,unfold island_rules,assume h,exact h,
    unfold island_rules,assume h,exact hi h.left
end
theorem blue_eyed_islander : ∀ d b : ℕ, b > 0 → (d + 1 ≥ b ↔ (∀ bb:ℕ, (island_rules d b) bb → bb = b)):=begin
    assume d,induction d with d hi,assume b,
    simp[island_rules],
    cases b,simp[(dec_trivial:¬0>0)],
    cases b,assume h,simp[(dec_trivial:1≥1)],assume bb hbb,cases hbb,assume hbb1,rw hbb,
    rw hbb,simp[(dec_trivial:¬0>0)],
    assume h,simp[(dec_trivial:¬ 1 ≥ succ (succ b))],assume hbb,
    have h1:=hbb (succ b),simp[(dec_trivial:succ b>0),succ_ne_self (succ b)] at h1,
    exact (succ_ne_self b).symm h1,

    assume b hb,apply iff.intro,
    assume hd,cases lt_or_eq_of_le hd,unfold island_rules,assume bb hbb,
    have hd1 : succ d ≥ b:=le_of_succ_le_succ (succ_le_of_lt h),rw add_one at hi,
    exact iff.elim_left (hi b hb) hd1 bb hbb.left,

    have hi1:= hi b hb,rw succ_add at h,rw h at hi1,
    have hd1:¬d+1 ≥ succ(d+1) :=not_le_of_gt (lt_succ_self (d+1)),
    simp[hd1] at hi1,unfold island_rules,assume bb hbb,
    have hbb1:=init_island hbb.left,
    cases hbb1.left with hbb2 hbb2,assumption,
    have hbbd:d + 1 ≥ bb,rw[eq_comm,nat.sub_eq_iff_eq_add (succ_le_of_lt hb)] at hbb2,
    rw [hbb2,succ_add,add_one bb] at hd,exact le_of_succ_le_succ hd,
    exact iff.elim_right hbb.right (iff.elim_left (hi bb hbb1.right) hbbd) bb hbb.left,

    assume hbb,apply by_contradiction,assume hd,have hd1:=lt_of_not_ge hd,
    rw succ_add at hd1,have hd2:¬d + 1 ≥ b:=not_le_of_gt (lt_of_succ_lt hd1),
    have hi1:= hi b hb,simp [hd2] at hi1,unfold island_rules at hbb,
    rw classical.not_forall at hi1,cases hi1 with bb hbb1,
    rw @not_imp _ _ (classical.prop_decidable _)at hbb1,
    have hbb2:=hbb bb,
    have hbb3:= init_island hbb1.left,simp[hbb1.right] at hbb3,
    have hbb4:=hi bb hbb3.right,
    rw [eq_comm,nat.sub_eq_iff_eq_add (succ_le_of_lt hb)] at hbb3,
    rw [hbb3.left,add_one bb] at hd1,have hbbd:¬d + 1 ≥ bb:= not_le_of_gt (lt_of_succ_lt_succ hd1),
    simp[hbbd] at hbb4,
    have:¬∀ (c : ℕ), island_rules d b c → c = b,assume hbb4,have:=hbb4 bb hbb1.left,
    rw [hbb3.left,add_one,eq_comm] at this,exact succ_ne_self bb this,
    simp[hbb4,hbb1.left,this] at hbb2,
    rw [hbb3.left,add_one,eq_comm] at hbb2,exact succ_ne_self bb hbb2,
end
#print blue_eyed_islander


import tools.super

constant heap   : Type
constant ptr    : Type
constant val    : Type
constant pt     : ptr → val → heap
constant hunion : heap → heap → heap
constant is_def : heap → Prop

infix `∙`:60 := hunion
infix `↣`:70 := pt

axiom hcomm    : ∀ x y, x ∙ y = y ∙ x
axiom hassoc   : ∀ x y z, (x ∙ y) ∙ z = x ∙ (y ∙ z)
axiom hnoalias : ∀ h y w₁ w₂, ¬is_def (h ∙ y ↣ w₁ ∙ y ↣ w₂)

set_option trace.super true
lemma ex (h₁ h₂ : heap) (x₁ x₂ x₃ x₄ : ptr) (v₁ v₂ v₃ : val)
: is_def (h₁ ∙ (x₁ ↣ v₁ ∙ x₂ ↣ v₂) ∙ h₂ ∙ (x₃ ↣ v₃)) → x₁ ≠ x₃ ∧ x₁ ≠ x₂ ∧ x₂ ≠ x₃ :=
by super hnoalias with hcomm hassoc


import .set .galois .lattice
universes u

variables {E : Type u}

def seq : Type u → Type u := λ α, ℕ → α

class σ_algebra {E : Type u} (ℰ : set (set E)) : Prop :=
(empty : ∅ ∈ ℰ)
(compl : ∀ A ∈ ℰ, -A ∈ ℰ)
(union : ∀ (As : ℕ → set E) (p : ∀ n, As n ∈ ℰ), (⋃ n, As n) ∈ ℰ)

namespace σ_algebra
    variables {ℰ : set (set E)} [σ_algebra ℰ]
    lemma inter : ∀ (As : ℕ → set E) (p : ∀ n, As n ∈ ℰ), (⋂ n, As n) ∈ ℰ :=
    begin
        intros As p,simp [set.Inter_compl], apply σ_algebra.compl, apply σ_algebra.union,
        intro n, apply σ_algebra.compl, apply p,
    end

    def algebra_on (E : Type u) : Type* := {ℰ:set(set E) // σ_algebra ℰ}
    instance : has_mem (set E) (algebra_on E) := ⟨λ a b, a ∈ b.val⟩
    lemma ext : Π {ℰ₁ ℰ₂ : algebra_on E}, ℰ₁.val =  ℰ₂.val → ℰ₁ = ℰ₂
    |⟨_,_⟩ ⟨_,_⟩ rfl := rfl

    instance : partial_order (algebra_on E) :=
    { le := λ ℰ₁ ℰ₂, ℰ₁.1 ⊆ ℰ₂.1
    , le_refl := λ ℰ A, id
    , le_trans := λ A B C, set.subset.trans
    , le_antisymm := λ A B l r, ext $ set.subset.antisymm l r
    }

    def forget : (algebra_on E) → set (set E) := λ x, x.val

    inductive gen_free (𝒜 : set (set E)) : set E → Prop
    |basic : ∀ A ∈ 𝒜, gen_free A
    |empty : gen_free ∅
    |compl : ∀ A, gen_free A → gen_free (-A)
    |union : ∀ (As : seq (set E)), (∀ n, gen_free (As n)) → gen_free (⋃ n, As n)

    def free (𝒜 : set (set E)) : algebra_on E := ⟨set_of $ gen_free 𝒜, {empty := gen_free.empty _,compl := gen_free.compl,union := gen_free.union}⟩

    def gc : @galois_connection (set (set E)) (algebra_on E) _ _ free forget :=
    λ 𝒜 ℰ,
    ⟨λ (h₁ : (free 𝒜).val ⊆ ℰ.val) A AA, h₁ (gen_free.basic A AA)
    ,λ (h₁ : 𝒜 ⊆ ℰ.val) A h₂,
        have ecu : σ_algebra ℰ.val, from ℰ.2,
        gen_free.rec_on h₂ (λ B BE, h₁ BE) (ecu.empty) (λ B _ BE, @σ_algebra.compl _ _ ecu B BE) (λ As _ q, @σ_algebra.union _ _ ecu As q)
    ⟩

    def gi : @galois_insertion (set (set E)) (algebra_on E) _ _ free forget :=
    { gc := gc
    , le_l_u := λ ℰ A mA, gen_free.basic A mA
    }
    instance : complete_lattice (algebra_on E) := complete_lattice_of_gi gi

    structure π_system (𝒜 : set (set E)) :=
    (empty : ∅ ∈ 𝒜)
    (inter : ∀ (A B ∈ 𝒜), A ∩ B ∈ 𝒜)

    structure d_system (𝒜 : set (set E)) :=
    (univ : set.univ ∈ 𝒜)
    (subs : ∀ (A B ∈ 𝒜), A ⊆ B → (B ∩ -A) ∈ 𝒜)
    (union : ∀ (f : seq (set E)), (∀ n, f n ∈ 𝒜) → (monotone f) → (⋃ n, f n) ∈ 𝒜)

    lemma dynkin {𝒜 𝒟 : set (set E)} (p: π_system 𝒜) (d : d_system 𝒟) (ss : 𝒜 ⊆ 𝒟) : (forget (free 𝒜) ⊆ 𝒟) :=
        let 𝒟' := { B ∈ 𝒟 |∀ A ∈ 𝒜, B ∩ A ∈ 𝒟} in
        have h₁ : 𝒜 ⊆ 𝒟', from λ A mA, ⟨ss mA,λ X mX, ss (p.inter _ _ mA mX)⟩,
        have h₂ : set.univ ∈ 𝒟', from ⟨d.univ, λ A mA, begin apply ss, rw set.inter.univ, apply mA end⟩,
        have h₃ : ∀ (B₁ B₂ ∈ 𝒟'), B₁ ⊆ B₂ → B₂ ∩ -B₁ ∈ 𝒟', from λ B₁ B₂ ⟨m1,h1⟩ ⟨m2,h2⟩ sb,
            ⟨d.subs _ _ m1 m2 sb
            , λ A mA,
                have h₄ : (B₂ ∩ -B₁) ∩ A = (B₂ ∩ A) ∩ -(B₁ ∩ A), from set.ext $ λ x, ⟨λ ⟨⟨i,j⟩,k⟩, ⟨⟨i,k⟩,λ ⟨l,m⟩, j l⟩,λ ⟨⟨i,j⟩,f⟩, ⟨⟨i,λ k, f⟨k,j⟩⟩,j⟩⟩ ,
                have h₅ : (B₂ ∩ A) ∈ 𝒟, from h2 A mA,
                have h₆ : (B₁ ∩ A) ∈ 𝒟, from h1 A mA,
                suffices (B₂ ∩ A) ∩ -(B₁ ∩ A) ∈ 𝒟, by simp [h₄, this],
                d.subs _ _ h₆ h₅ (λ x ⟨m2,ma⟩, ⟨sb m2, ma⟩)
            ⟩,
        have h₄: ∀ (f : seq (set E)), (∀ n, f n ∈ 𝒟') →(monotone f) → (⋃ n, f n) ∈ 𝒟', from
            λ f p m, ⟨d.union (f) (λ n, (p n).1) m, λ A mA,
                have h₅ : (⋃ n, f n) ∩ A = (⋃ n, (f n) ∩ A), from set.ext $ λ x, ⟨λ ⟨⟨i,j⟩,k⟩, ⟨i,⟨j,k⟩⟩,λ ⟨i,⟨j,k⟩⟩, ⟨⟨i,j⟩,k⟩⟩,
                suffices (⋃ n, (f n) ∩ A) ∈ 𝒟, by simp [h₅, this],
                d.union _ (λ n, (p n).2 A mA) (λ i j ij x ⟨p,q⟩, ⟨m ij p,q⟩)
            ⟩,
        λ A mA, gen_free.rec_on mA
            (λ A mA, ss mA)
            (ss p.empty)
            (λ B _ mB,
                suffices set.univ ∩ -B ∈ 𝒟, by simp [set.inter.univ] at this; assumption,
                d.subs B set.univ mB (d.univ) (λ _ _, ⟨⟩)
            )
            (λ f _ q, _)

end σ_algebra

--def disjoint_sequence (ℰ : set (set E)) := {As:ℕ→set E//(∀ n, As n ∈ ℰ) ∧ (∀ n m, As n ∩ As m = ∅)}


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

/-!
# Heyting regular elements

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

This file defines Heyting regular elements, elements of an Heyting algebra that are their own double
complement, and proves that they form a boolean algebra.

From a logic standpoint, this means that we can perform classical logic within intuitionistic logic
by simply double-negating all propositions. This is practical for synthetic computability theory.

## Main declarations

* `is_regular`: `a` is Heyting-regular if `aᶜᶜ = a`.
* `regular`: The subtype of Heyting-regular elements.
* `regular.boolean_algebra`: Heyting-regular elements form a boolean algebra.

## References

* [Francis Borceux, *Handbook of Categorical Algebra III*][borceux-vol3]
-/

open function

variables {α : Type*}

namespace heyting
section has_compl
variables [has_compl α] {a : α}

/-- An element of an Heyting algebra is regular if its double complement is itself. -/
def is_regular (a : α) : Prop := aᶜᶜ = a

protected lemma is_regular.eq : is_regular a → aᶜᶜ = a := id

instance is_regular.decidable_pred [decidable_eq α] : @decidable_pred α is_regular :=
λ _, ‹decidable_eq α› _ _

end has_compl

section heyting_algebra
variables [heyting_algebra α] {a b : α}

lemma is_regular_bot : is_regular (⊥ : α) := by rw [is_regular, compl_bot, compl_top]
lemma is_regular_top : is_regular (⊤ : α) := by rw [is_regular, compl_top, compl_bot]

lemma is_regular.inf (ha : is_regular a) (hb : is_regular b) : is_regular (a ⊓ b) :=
by rw [is_regular, compl_compl_inf_distrib, ha.eq, hb.eq]

lemma is_regular.himp (ha : is_regular a) (hb : is_regular b) : is_regular (a ⇨ b) :=
by rw [is_regular, compl_compl_himp_distrib, ha.eq, hb.eq]

lemma is_regular_compl (a : α) : is_regular aᶜ := compl_compl_compl _

protected lemma is_regular.disjoint_compl_left_iff (ha : is_regular a) : disjoint aᶜ b ↔ b ≤ a :=
by rw [←le_compl_iff_disjoint_left, ha.eq]

protected lemma is_regular.disjoint_compl_right_iff (hb : is_regular b) : disjoint a bᶜ ↔ a ≤ b :=
by rw [←le_compl_iff_disjoint_right, hb.eq]

/-- A Heyting algebra with regular excluded middle is a boolean algebra. -/
@[reducible] -- See note [reducible non-instances]
def _root_.boolean_algebra.of_regular (h : ∀ a : α, is_regular (a ⊔ aᶜ)) : boolean_algebra α :=
have ∀ a : α, is_compl a aᶜ := λ a, ⟨disjoint_compl_right, codisjoint_iff.2 $
  by erw [←(h a).eq, compl_sup, inf_compl_eq_bot, compl_bot]⟩,
{ himp_eq := λ a b, eq_of_forall_le_iff $ λ c,
    le_himp_iff.trans ((this _).le_sup_right_iff_inf_left_le).symm,
  inf_compl_le_bot := λ a, (this _).1.le_bot,
  top_le_sup_compl := λ a, (this _).2.top_le,
  ..‹heyting_algebra α›, ..generalized_heyting_algebra.to_distrib_lattice }

variables (α)

/-- The boolean algebra of Heyting regular elements. -/
def regular : Type* := {a : α // is_regular a}

variables {α}

namespace regular

instance : has_coe (regular α) α := coe_subtype

lemma coe_injective : injective (coe : regular α → α) := subtype.coe_injective
@[simp] lemma coe_inj {a b : regular α} : (a : α) = b ↔ a = b := subtype.coe_inj

instance : has_top (regular α) := ⟨⟨⊤, is_regular_top⟩⟩
instance : has_bot (regular α) := ⟨⟨⊥, is_regular_bot⟩⟩
instance : has_inf (regular α) := ⟨λ a b, ⟨a ⊓ b, a.2.inf b.2⟩⟩
instance : has_himp (regular α) := ⟨λ a b, ⟨a ⇨ b, a.2.himp b.2⟩⟩
instance : has_compl (regular α) := ⟨λ a, ⟨aᶜ, is_regular_compl _⟩⟩

@[simp, norm_cast] lemma coe_top : ((⊤ : regular α) : α) = ⊤ := rfl
@[simp, norm_cast] lemma coe_bot : ((⊥ : regular α) : α) = ⊥ := rfl
@[simp, norm_cast] lemma coe_inf (a b : regular α) : (↑(a ⊓ b) : α) = a ⊓ b := rfl
@[simp, norm_cast] lemma coe_himp (a b : regular α) : (↑(a ⇨ b) : α) = a ⇨ b := rfl
@[simp, norm_cast] lemma coe_compl (a : regular α) : (↑(aᶜ) : α) = aᶜ := rfl

instance : inhabited (regular α) := ⟨⊥⟩
instance : semilattice_inf (regular α) := coe_injective.semilattice_inf _ coe_inf
instance : bounded_order (regular α) := bounded_order.lift coe (λ _ _, id) coe_top coe_bot

@[simp, norm_cast] lemma coe_le_coe {a b : regular α} : (a : α) ≤ b ↔ a ≤ b := iff.rfl
@[simp, norm_cast] lemma coe_lt_coe {a b : regular α} : (a : α) < b ↔ a < b := iff.rfl

/-- **Regularization** of `a`. The smallest regular element greater than `a`. -/
def to_regular : α →o regular α :=
⟨λ a, ⟨aᶜᶜ, is_regular_compl _⟩, λ a b h, coe_le_coe.1 $ compl_le_compl $ compl_le_compl h⟩

@[simp, norm_cast] lemma coe_to_regular (a : α) : (to_regular a : α) = aᶜᶜ := rfl
@[simp]

/-- The Galois insertion between `regular.to_regular` and `coe`. -/
def gi : galois_insertion to_regular (coe : regular α → α) :=
{ choice := λ a ha, ⟨a, ha.antisymm le_compl_compl⟩,
  gc := λ a b, coe_le_coe.symm.trans $
    ⟨le_compl_compl.trans, λ h, (compl_anti $ compl_anti h).trans_eq b.2⟩,
  le_l_u := λ _, le_compl_compl,
  choice_eq := λ a ha, coe_injective $ le_compl_compl.antisymm ha }

instance : lattice (regular α) := gi.lift_lattice

@[simp, norm_cast] lemma coe_sup (a b : regular α) : (↑(a ⊔ b) : α) = (a ⊔ b)ᶜᶜ := rfl

instance : boolean_algebra (regular α) :=
{ le_sup_inf := λ a b c, coe_le_coe.1 $ by { dsimp, rw [sup_inf_left, compl_compl_inf_distrib] },
  inf_compl_le_bot := λ a, coe_le_coe.1 $ disjoint_iff_inf_le.1 disjoint_compl_right,
  top_le_sup_compl := λ a, coe_le_coe.1 $
    by { dsimp, rw [compl_sup, inf_compl_eq_bot, compl_bot], refl },
  himp_eq := λ a b, coe_injective begin
    dsimp,
    rw [compl_sup, a.prop.eq],
    refine eq_of_forall_le_iff (λ c, le_himp_iff.trans _),
    rw [le_compl_iff_disjoint_right, disjoint_left_comm, b.prop.disjoint_compl_left_iff],
  end,
  ..regular.lattice, ..regular.bounded_order, ..regular.has_himp,
  ..regular.has_compl }

@[simp, norm_cast] lemma coe_sdiff (a b : regular α) : (↑(a \ b) : α) = a ⊓ bᶜ := rfl

end regular
end heyting_algebra

variables [boolean_algebra α]

lemma is_regular_of_boolean : ∀ a : α, is_regular a := compl_compl

/-- A decidable proposition is intuitionistically Heyting-regular. -/
@[nolint decidable_classical]
lemma is_regular_of_decidable (p : Prop) [decidable p] : is_regular p :=
propext $ decidable.not_not_iff _

end heyting


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

! This file was ported from Lean 3 source module category_theory.differential_object
! leanprover-community/mathlib commit 6876fa15e3158ff3e4a4e2af1fb6e1945c6e8803
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.Data.Int.Basic
import Mathbin.CategoryTheory.Shift.Basic
import Mathbin.CategoryTheory.ConcreteCategory.Basic

/-!
# Differential objects in a category.

A differential object in a category with zero morphisms and a shift is
an object `X` equipped with
a morphism `d : X ⟶ X⟦1⟧`, such that `d^2 = 0`.

We build the category of differential objects, and some basic constructions
such as the forgetful functor, zero morphisms and zero objects, and the shift functor
on differential objects.
-/

open CategoryTheory.Limits

universe v u

namespace CategoryTheory

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

-- TODO: generalize to `has_shift C A` for an arbitrary `[add_monoid A]` `[has_one A]`.
variable [HasZeroMorphisms C] [HasShift C ℤ]

/-- A differential object in a category with zero morphisms and a shift is
an object `X` equipped with
a morphism `d : X ⟶ X⟦1⟧`, such that `d^2 = 0`.
-/
@[nolint has_nonempty_instance]
structure DifferentialObject where
  pt : C
  d : X ⟶ X⟦1⟧
  d_squared' : d ≫ d⟦(1 : ℤ)⟧' = 0 := by obviously
#align category_theory.differential_object CategoryTheory.DifferentialObject

restate_axiom differential_object.d_squared'

attribute [simp] differential_object.d_squared

variable {C}

namespace DifferentialObject

/-- A morphism of differential objects is a morphism commuting with the differentials.
-/
@[ext, nolint has_nonempty_instance]
structure Hom (X Y : DifferentialObject C) where
  f : X.pt ⟶ Y.pt
  comm' : X.d ≫ f⟦1⟧' = f ≫ Y.d := by obviously
#align category_theory.differential_object.hom CategoryTheory.DifferentialObject.Hom

restate_axiom hom.comm'

attribute [simp, reassoc.1] hom.comm

namespace Hom

/-- The identity morphism of a differential object. -/
@[simps]
def id (X : DifferentialObject C) : Hom X X where f := 𝟙 X.pt
#align category_theory.differential_object.hom.id CategoryTheory.DifferentialObject.Hom.id

/-- The composition of morphisms of differential objects. -/
@[simps]
def comp {X Y Z : DifferentialObject C} (f : Hom X Y) (g : Hom Y Z) : Hom X Z where f := f.f ≫ g.f
#align category_theory.differential_object.hom.comp CategoryTheory.DifferentialObject.Hom.comp

end Hom

instance categoryOfDifferentialObjects : Category (DifferentialObject C)
    where
  Hom := Hom
  id := Hom.id
  comp X Y Z f g := Hom.comp f g
#align category_theory.differential_object.category_of_differential_objects CategoryTheory.DifferentialObject.categoryOfDifferentialObjects

@[simp]
theorem id_f (X : DifferentialObject C) : (𝟙 X : X ⟶ X).f = 𝟙 X.pt :=
  rfl
#align category_theory.differential_object.id_f CategoryTheory.DifferentialObject.id_f

@[simp]
theorem comp_f {X Y Z : DifferentialObject C} (f : X ⟶ Y) (g : Y ⟶ Z) : (f ≫ g).f = f.f ≫ g.f :=
  rfl
#align category_theory.differential_object.comp_f CategoryTheory.DifferentialObject.comp_f

@[simp]
theorem eqToHom_f {X Y : DifferentialObject C} (h : X = Y) :
    Hom.f (eqToHom h) = eqToHom (congr_arg _ h) :=
  by
  subst h
  rw [eq_to_hom_refl, eq_to_hom_refl]
  rfl
#align category_theory.differential_object.eq_to_hom_f CategoryTheory.DifferentialObject.eqToHom_f

variable (C)

/-- The forgetful functor taking a differential object to its underlying object. -/
def forget : DifferentialObject C ⥤ C where
  obj X := X.pt
  map X Y f := f.f
#align category_theory.differential_object.forget CategoryTheory.DifferentialObject.forget

instance forget_faithful : Faithful (forget C) where
#align category_theory.differential_object.forget_faithful CategoryTheory.DifferentialObject.forget_faithful

instance hasZeroMorphisms : HasZeroMorphisms (DifferentialObject C) where Zero X Y := ⟨{ f := 0 }⟩
#align category_theory.differential_object.has_zero_morphisms CategoryTheory.DifferentialObject.hasZeroMorphisms

variable {C}

@[simp]
theorem zero_f (P Q : DifferentialObject C) : (0 : P ⟶ Q).f = 0 :=
  rfl
#align category_theory.differential_object.zero_f CategoryTheory.DifferentialObject.zero_f

/-- An isomorphism of differential objects gives an isomorphism of the underlying objects.
-/
@[simps]
def isoApp {X Y : DifferentialObject C} (f : X ≅ Y) : X.pt ≅ Y.pt :=
  ⟨f.Hom.f, f.inv.f, by
    dsimp
    rw [← comp_f, iso.hom_inv_id, id_f], by
    dsimp
    rw [← comp_f, iso.inv_hom_id, id_f]⟩
#align category_theory.differential_object.iso_app CategoryTheory.DifferentialObject.isoApp

@[simp]
theorem isoApp_refl (X : DifferentialObject C) : isoApp (Iso.refl X) = Iso.refl X.pt :=
  rfl
#align category_theory.differential_object.iso_app_refl CategoryTheory.DifferentialObject.isoApp_refl

@[simp]
theorem isoApp_symm {X Y : DifferentialObject C} (f : X ≅ Y) : isoApp f.symm = (isoApp f).symm :=
  rfl
#align category_theory.differential_object.iso_app_symm CategoryTheory.DifferentialObject.isoApp_symm

@[simp]
theorem isoApp_trans {X Y Z : DifferentialObject C} (f : X ≅ Y) (g : Y ≅ Z) :
    isoApp (f ≪≫ g) = isoApp f ≪≫ isoApp g :=
  rfl
#align category_theory.differential_object.iso_app_trans CategoryTheory.DifferentialObject.isoApp_trans

/-- An isomorphism of differential objects can be constructed
from an isomorphism of the underlying objects that commutes with the differentials. -/
@[simps]
def mkIso {X Y : DifferentialObject C} (f : X.pt ≅ Y.pt) (hf : X.d ≫ f.Hom⟦1⟧' = f.Hom ≫ Y.d) :
    X ≅ Y where
  Hom := ⟨f.Hom, hf⟩
  inv :=
    ⟨f.inv, by
      dsimp
      rw [← functor.map_iso_inv, iso.comp_inv_eq, category.assoc, iso.eq_inv_comp,
        functor.map_iso_hom, hf]⟩
  hom_inv_id' := by
    ext1
    dsimp
    exact f.hom_inv_id
  inv_hom_id' := by
    ext1
    dsimp
    exact f.inv_hom_id
#align category_theory.differential_object.mk_iso CategoryTheory.DifferentialObject.mkIso

end DifferentialObject

namespace Functor

universe v' u'

variable (D : Type u') [Category.{v'} D]

variable [HasZeroMorphisms D] [HasShift D ℤ]

/--
A functor `F : C ⥤ D` which commutes with shift functors on `C` and `D` and preserves zero morphisms
can be lifted to a functor `differential_object C ⥤ differential_object D`.
-/
@[simps]
def mapDifferentialObject (F : C ⥤ D)
    (η : (shiftFunctor C (1 : ℤ)).comp F ⟶ F.comp (shiftFunctor D (1 : ℤ)))
    (hF : ∀ c c', F.map (0 : c ⟶ c') = 0) : DifferentialObject C ⥤ DifferentialObject D
    where
  obj X :=
    { pt := F.obj X.pt
      d := F.map X.d ≫ η.app X.pt
      d_squared' :=
        by
        rw [functor.map_comp, ← functor.comp_map F (shift_functor D (1 : ℤ))]
        slice_lhs 2 3 => rw [← η.naturality X.d]
        rw [functor.comp_map]
        slice_lhs 1 2 => rw [← F.map_comp, X.d_squared, hF]
        rw [zero_comp, zero_comp] }
  map X Y f :=
    { f := F.map f.f
      comm' := by
        dsimp
        slice_lhs 2 3 => rw [← functor.comp_map F (shift_functor D (1 : ℤ)), ← η.naturality f.f]
        slice_lhs 1 2 => rw [functor.comp_map, ← F.map_comp, f.comm, F.map_comp]
        rw [category.assoc] }
  map_id' := by
    intros
    ext
    simp
  map_comp' := by
    intros
    ext
    simp
#align category_theory.functor.map_differential_object CategoryTheory.Functor.mapDifferentialObject

end Functor

end CategoryTheory

namespace CategoryTheory

namespace DifferentialObject

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

variable [HasZeroObject C] [HasZeroMorphisms C] [HasShift C ℤ]

open ZeroObject

instance hasZeroObject : HasZeroObject (DifferentialObject C) := by
  refine' ⟨⟨⟨0, 0⟩, fun X => ⟨⟨⟨⟨0⟩⟩, fun f => _⟩⟩, fun X => ⟨⟨⟨⟨0⟩⟩, fun f => _⟩⟩⟩⟩ <;> ext
#align category_theory.differential_object.has_zero_object CategoryTheory.DifferentialObject.hasZeroObject

end DifferentialObject

namespace DifferentialObject

variable (C : Type (u + 1)) [LargeCategory C] [ConcreteCategory C] [HasZeroMorphisms C]
  [HasShift C ℤ]

instance concreteCategoryOfDifferentialObjects : ConcreteCategory (DifferentialObject C)
    where forget := forget C ⋙ CategoryTheory.forget C
#align category_theory.differential_object.concrete_category_of_differential_objects CategoryTheory.DifferentialObject.concreteCategoryOfDifferentialObjects

instance : HasForget₂ (DifferentialObject C) C where forget₂ := forget C

end DifferentialObject

/-! The category of differential objects itself has a shift functor. -/

namespace DifferentialObject

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

variable [HasZeroMorphisms C] [HasShift C ℤ]

noncomputable section

/-- The shift functor on `differential_object C`. -/
@[simps]
def shiftFunctor (n : ℤ) : DifferentialObject C ⥤ DifferentialObject C
    where
  obj X :=
    { pt := X.pt⟦n⟧
      d := X.d⟦n⟧' ≫ (shiftComm _ _ _).Hom
      d_squared' := by
        rw [functor.map_comp, category.assoc, shift_comm_hom_comp_assoc, ← functor.map_comp_assoc,
          X.d_squared, functor.map_zero, zero_comp] }
  map X Y f :=
    { f := f.f⟦n⟧'
      comm' := by
        dsimp
        erw [category.assoc, shift_comm_hom_comp, ← functor.map_comp_assoc, f.comm,
          functor.map_comp_assoc]
        rfl }
  map_id' := by
    intro X
    ext1
    dsimp
    rw [Functor.map_id]
  map_comp' := by
    intro X Y Z f g
    ext1
    dsimp
    rw [functor.map_comp]
#align category_theory.differential_object.shift_functor CategoryTheory.DifferentialObject.shiftFunctor

/-- The shift functor on `differential_object C` is additive. -/
@[simps]
def shiftFunctorAdd (m n : ℤ) : shiftFunctor C (m + n) ≅ shiftFunctor C m ⋙ shiftFunctor C n :=
  by
  refine' nat_iso.of_components (fun X => mk_iso (shift_add X.pt _ _) _) _
  · dsimp
    rw [← cancel_epi ((shift_functor_add C m n).inv.app X.X)]
    simp only [category.assoc, iso.inv_hom_id_app_assoc]
    erw [← nat_trans.naturality_assoc]
    dsimp
    simp only [functor.map_comp, category.assoc,
      shift_functor_comm_hom_app_comp_shift_shift_functor_add_hom_app 1 m n X.X,
      iso.inv_hom_id_app_assoc]
  · intro X Y f
    ext
    dsimp
    exact nat_trans.naturality _ _
#align category_theory.differential_object.shift_functor_add CategoryTheory.DifferentialObject.shiftFunctorAdd

section

/-- The shift by zero is naturally isomorphic to the identity. -/
@[simps]
def shiftZero : shiftFunctor C 0 ≅ 𝟭 (DifferentialObject C) :=
  by
  refine' nat_iso.of_components (fun X => mk_iso ((shift_functor_zero C ℤ).app X.pt) _) _
  · erw [← nat_trans.naturality]
    dsimp
    simp only [shift_functor_zero_hom_app_shift, category.assoc]
  · tidy
#align category_theory.differential_object.shift_zero CategoryTheory.DifferentialObject.shiftZero

end

instance : HasShift (DifferentialObject C) ℤ :=
  hasShiftMk _ _
    { f := shiftFunctor C
      zero := shiftZero C
      add := shiftFunctorAdd C
      assoc_hom_app := fun m₁ m₂ m₃ X => by
        ext1
        convert shift_functor_add_assoc_hom_app m₁ m₂ m₃ X.X
        dsimp [shift_functor_add']
        simpa
      zero_add_hom_app := fun n X => by
        ext1
        convert shift_functor_add_zero_add_hom_app n X.X
        simpa
      add_zero_hom_app := fun n X => by
        ext1
        convert shift_functor_add_add_zero_hom_app n X.X
        simpa }

end DifferentialObject

end CategoryTheory


/-
Copyright (c) 2020 Aaron Anderson. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Aaron Anderson
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.ring_theory.unique_factorization_domain
import Mathlib.ring_theory.int.basic
import Mathlib.number_theory.divisors
import Mathlib.PostPort

universes u_1

namespace Mathlib

/-!
# Squarefree elements of monoids
An element of a monoid is squarefree when it is not divisible by any squares
except the squares of units.

## Main Definitions
 - `squarefree r` indicates that `r` is only divisible by `x * x` if `x` is a unit.

## Main Results
 - `multiplicity.squarefree_iff_multiplicity_le_one`: `x` is `squarefree` iff for every `y`, either
  `multiplicity y x ≤ 1` or `is_unit y`.
 - `unique_factorization_monoid.squarefree_iff_nodup_factors`: A nonzero element `x` of a unique
 factorization monoid is squarefree iff `factors x` has no duplicate factors.
 - `nat.squarefree_iff_nodup_factors`: A positive natural number `x` is squarefree iff
  the list `factors x` has no duplicate factors.
## Tags
squarefree, multiplicity

-/

/-- An element of a monoid is squarefree if the only squares that
  divide it are the squares of units. -/
def squarefree {R : Type u_1} [monoid R] (r : R) := ∀ (x : R), x * x ∣ r → is_unit x

@[simp] theorem is_unit.squarefree {R : Type u_1} [comm_monoid R] {x : R} (h : is_unit x) :
    squarefree x :=
  fun (y : R) (hdvd : y * y ∣ x) => is_unit_of_mul_is_unit_left (is_unit_of_dvd_unit hdvd h)

@[simp] theorem squarefree_one {R : Type u_1} [comm_monoid R] : squarefree 1 :=
  is_unit.squarefree is_unit_one

@[simp] theorem not_squarefree_zero {R : Type u_1} [monoid_with_zero R] [nontrivial R] :
    ¬squarefree 0 :=
  sorry

@[simp] theorem irreducible.squarefree {R : Type u_1} [comm_monoid R] {x : R} (h : irreducible x) :
    squarefree x :=
  sorry

@[simp] theorem prime.squarefree {R : Type u_1} [comm_cancel_monoid_with_zero R] {x : R}
    (h : prime x) : squarefree x :=
  irreducible.squarefree (irreducible_of_prime h)

theorem squarefree_of_dvd_of_squarefree {R : Type u_1} [comm_monoid R] {x : R} {y : R}
    (hdvd : x ∣ y) (hsq : squarefree y) : squarefree x :=
  fun (a : R) (h : a * a ∣ x) => hsq a (dvd.trans h hdvd)

namespace multiplicity

theorem squarefree_iff_multiplicity_le_one {R : Type u_1} [comm_monoid R] [DecidableRel has_dvd.dvd]
    (r : R) : squarefree r ↔ ∀ (x : R), multiplicity x r ≤ 1 ∨ is_unit x :=
  sorry

end multiplicity

namespace unique_factorization_monoid

theorem squarefree_iff_nodup_factors {R : Type u_1} [comm_cancel_monoid_with_zero R] [nontrivial R]
    [unique_factorization_monoid R] [normalization_monoid R] [DecidableEq R] {x : R} (x0 : x ≠ 0) :
    squarefree x ↔ multiset.nodup (factors x) :=
  sorry

theorem dvd_pow_iff_dvd_of_squarefree {R : Type u_1} [comm_cancel_monoid_with_zero R] [nontrivial R]
    [unique_factorization_monoid R] [normalization_monoid R] {x : R} {y : R} {n : ℕ}
    (hsq : squarefree x) (h0 : n ≠ 0) : x ∣ y ^ n ↔ x ∣ y :=
  sorry

end unique_factorization_monoid

namespace nat

theorem squarefree_iff_nodup_factors {n : ℕ} (h0 : n ≠ 0) : squarefree n ↔ list.nodup (factors n) :=
  sorry

protected instance squarefree.decidable_pred : decidable_pred squarefree := sorry

theorem divisors_filter_squarefree {n : ℕ} (h0 : n ≠ 0) :
    finset.val (finset.filter squarefree (divisors n)) =
        multiset.map (fun (x : finset ℕ) => multiset.prod (finset.val x))
          (finset.val
            (finset.powerset (multiset.to_finset (unique_factorization_monoid.factors n)))) :=
  sorry

theorem sum_divisors_filter_squarefree {n : ℕ} (h0 : n ≠ 0) {α : Type u_1} [add_comm_monoid α]
    {f : ℕ → α} :
    (finset.sum (finset.filter squarefree (divisors n)) fun (i : ℕ) => f i) =
        finset.sum (finset.powerset (multiset.to_finset (unique_factorization_monoid.factors n)))
          fun (i : finset ℕ) => f (multiset.prod (finset.val i)) :=
  sorry

end Mathlib