/-
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 data.finsupp
import ring_theory.algebra
import linear_algebra.star_algebra
import topology.algebra.infinite_sum
import data.monoid_algebra

/-!
# Monoid star algebras

This is formally parallel to monoid_star_algebra, but instead of taking finite formal
combinations of the generators, we take L^1 combinations.

We take the measure to be the sum over all elements.  This makes the convolution product
definable by restricting the sum ∑_x,y f(x) g(y) to x*y = a.

Ideally we would take the definitions from monoid_algebra, interpreted formally, and
check the summability conditions.  This requires generalizing finsupp to summable or some
stronger norm condition (we could also use ℓ_2).

NOTE: we are trying to use summable as defined in topology.algebra.infinite_sum but this is
NOT the same as ℓ_1 whose definition involves the sum of the norm of the elements.
So we would rather use l1_space but using the discreteness to define the convolution.

## 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_star_algebra k G := monoid_star_algebra k (multiplicative G)`,
but the definitional equality `multiplicative G = G` leaks through everywhere, and
seems impossible to use.
-/

noncomputable theory
open_locale classical

open finset finsupp

universes u₁ u₂ u₃
variables (k : Type u₁) (G : Type u₂)

section
variables [add_comm_monoid k] [topological_space k] [monoid G]

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

-- this is not right but we want a similar class of summable functions.
@[derive [inhabited, add_comm_monoid]]
def monoid_star_algebra : Type (max u₁ u₂) := G →₀ k

end

namespace monoid_star_algebra

variables {k G}
local attribute [reducible] monoid_star_algebra

section
variables [add_comm_monoid k] [topological_space k] [monoid G]

/-- The product of `f g : monoid_star_algebra k G` is the summable 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.) -/

def mul_def1 (f g : monoid_star_algebra k G) := (f.sum $ λa₁ b₁, g.sum $ λa₂ b₂, single (a₁ * a₂) (b₁ * b₂))

#check mul_def1

lemma mul_convergence (f g : monoid_star_algebra k G) (hf : summable f) (hg : summable g) : summable (mul_def1 f g) :=
begin unfold summable at *, unfold mul_def1, rcases hf, rcases hg,
end

instance : has_mul (monoid_star_algebra k G) :=
⟨λf g, f.sum $ λa₁ b₁, g.sum $ λa₂ b₂, single (a₁ * a₂) (b₁ * b₂)⟩

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

lemma mul_apply (f g : monoid_star_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 (f g : monoid_star_algebra k G) (x : G) (s : finset (G × G))
  (hs : ∀ {p : G × G}, p ∈ s ↔ p.1 * p.2 = x) :
  (f * g) x = s.sum (λ p, f p.1 * g p.2) :=
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 = (f.support.sum $ λ a₁, g.support.sum $ λ a₂, F (a₁, a₂)) :
  mul_apply f g x
... = (f.support.product g.support).sum F : finset.sum_product.symm
... = ((f.support.product g.support).filter (λ p : G × G, p.1 * p.2 = x)).sum (λ p, f p.1 * g p.2) :
  (finset.sum_filter _ _).symm
... = (s.filter (λ p : G × G, p.1 ∈ f.support ∧ p.2 ∈ g.support)).sum (λ p, f p.1 * g p.2) :
  sum_congr (by { ext, simp [hs, and_comm] }) (λ _ _, rfl)
... = s.sum (λ p, 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

end

section
variables [semiring k] [monoid G]

lemma support_mul (a b : monoid_star_algebra k G) :
  (a * b).support ⊆ a.support.bind (λa₁, b.support.bind $ λa₂, {a₁ * a₂}) :=
subset.trans support_sum $ bind_mono $ assume a₁ _,
  subset.trans support_sum $ bind_mono $ assume a₂ _, support_single_subset

/-- 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_star_algebra k G) :=
⟨single 1 1⟩

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

-- TODO: the simplifier unfolds 0 in the instance proof!
protected lemma zero_mul (f : monoid_star_algebra k G) : 0 * f = 0 :=
by simp only [mul_def, sum_zero_index]

protected lemma mul_zero (f : monoid_star_algebra k G) : f * 0 = 0 :=
by simp only [mul_def, sum_zero_index, sum_zero]

private lemma left_distrib (a b c : monoid_star_algebra k G) : a * (b + c) = a * b + a * c :=
by simp only [mul_def, sum_add_index, mul_add, mul_zero, single_zero, single_add,
  eq_self_iff_true, forall_true_iff, forall_3_true_iff, sum_add]

private lemma right_distrib (a b c : monoid_star_algebra k G) : (a + b) * c = a * c + b * c :=
by simp only [mul_def, sum_add_index, add_mul, mul_zero, zero_mul, single_zero,
  single_add, eq_self_iff_true, forall_true_iff, forall_3_true_iff, sum_zero, sum_add]

instance : semiring (monoid_star_algebra k G) :=
{ one       := 1,
  mul       := (*),
  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],
  zero_mul  := monoid_star_algebra.zero_mul,
  mul_zero  := monoid_star_algebra.mul_zero,
  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],
  left_distrib  := left_distrib,
  right_distrib := right_distrib,
  .. finsupp.add_comm_monoid }

@[simp] lemma single_mul_single {a₁ a₂ : G} {b₁ b₂ : k} :
  (single a₁ b₁ : monoid_star_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 {a : G} {b : k} :
  ∀ n : ℕ, (single a b : monoid_star_algebra k G)^n = single (a^n) (b ^ n)
| 0 := rfl
| (n+1) := by simp only [pow_succ, single_pow n, single_mul_single]

section

variables (k G)

/-- Embedding of a monoid into its monoid algebra. -/
def of : G →* monoid_star_algebra k G :=
{ to_fun := λ a, single a 1,
  map_one' := rfl,
  map_mul' := λ a b, by rw [single_mul_single, one_mul] }

end

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

lemma mul_single_apply_aux (f : monoid_star_algebra k G) {r : k}
  {x y z : G} (H : ∀ a, a * x = z ↔ a = y) :
  (f * single x r) z = f y * r :=
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) :
  -- different `decidable` instances make it not trivial
  by { simp only [mul_apply, A, H], congr, funext, split_ifs; refl }
... = 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 (f : monoid_star_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 single_mul_apply_aux (f : monoid_star_algebra k G) {r : k} {x y z : G}
  (H : ∀ a, x * a = y ↔ a = z) :
  (single x r * f) y = r * f z :=
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 this
... = f.sum (λ a b, ite (a = z) (r * b) 0) :
  by { simp only [H], congr, ext; split_ifs; refl  }
... = 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 (f : monoid_star_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]

end

instance [comm_semiring k] [comm_monoid G] : comm_semiring (monoid_star_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_star_algebra.semiring }

instance [ring k] : has_neg (monoid_star_algebra k G) :=
by apply_instance

instance [ring k] [monoid G] : ring (monoid_star_algebra k G) :=
{ neg := has_neg.neg,
  add_left_neg := add_left_neg,
  .. monoid_star_algebra.semiring }

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

instance [semiring k] : has_scalar k (monoid_star_algebra k G) :=
finsupp.has_scalar

instance [semiring k] : semimodule k (monoid_star_algebra k G) :=
finsupp.semimodule G k

instance [ring k] : module k (monoid_star_algebra k G) :=
by {delta monoid_star_algebra, apply_instance }

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

instance [comm_semiring k] [monoid G] : algebra k (monoid_star_algebra k G) :=
{ to_fun    := single 1,
  map_one'  := rfl,
  map_mul'  := λ x y, by rw [single_mul_single, one_mul],
  map_zero' := single_zero,
  map_add'  := λ x y, single_add,
  smul_def' := λ r a, ext (λ _, smul_apply.trans (single_one_mul_apply _ _ _).symm),
  commutes' := λ r f, ext $ λ _, by rw [single_one_mul_apply, mul_single_one_apply, mul_comm] }

@[simp] lemma coe_algebra_map [comm_semiring k] [monoid G] :
  (algebra_map k (monoid_star_algebra k G) : k → monoid_star_algebra k G) = single 1 :=
rfl

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

instance [group G] [semiring k] :
  distrib_mul_action G (monoid_star_algebra k G) :=
finsupp.comap_distrib_mul_action_self

section lift

variables (k G) [comm_semiring k] [monoid G] (R : Type u₃) [semiring R] [algebra k R]

/-- Any monoid homomorphism `G →* R` can be lifted to an algebra homomorphism
`monoid_star_algebra k G →ₐ[k] R`. -/
def lift : (G →* R) ≃ (monoid_star_algebra k G →ₐ[k] R) :=
{ inv_fun := λ f, (f : monoid_star_algebra k G →* R).comp (of k G),
  to_fun := λ F, { to_fun := λ f, f.sum (λ a b, b • F a),
    map_one' := by { rw [one_def, sum_single_index, one_smul, F.map_one], apply zero_smul },
    map_mul' :=
      begin
        intros f g,
        rw [mul_def, finsupp.sum_mul, finsupp.sum_sum_index];
          try { intros, simp only [zero_smul, add_smul], done },
        refine finset.sum_congr rfl (λ a ha, _), simp only [],
        rw [finsupp.mul_sum, finsupp.sum_sum_index];
          try { intros, simp only [zero_smul, add_smul], done },
        refine finset.sum_congr rfl (λ a' ha', _), simp only [],
        rw [sum_single_index, F.map_mul, algebra.mul_smul_comm, algebra.smul_mul_assoc,
          smul_smul, mul_comm],
        apply zero_smul
      end,
    map_zero' := sum_zero_index,
    map_add' := λ f g, by rw [sum_add_index]; intros; simp only [zero_smul, add_smul],
    commutes' := λ r, by rw [coe_algebra_map, sum_single_index, F.map_one, algebra.smul_def,
      mul_one]; apply zero_smul },
  left_inv := λ f, begin ext x, simp [sum_single_index] end,
  right_inv := λ F,
    begin
      ext f,
      conv_rhs { rw ← f.sum_single },
      simp [← F.map_smul, finsupp.sum, ← F.map_sum]
    end }

variables {k G R}

lemma lift_apply (F : G →* R) (f : monoid_star_algebra k G) :
  lift k G R F f = f.sum (λ a b, b • F a) := rfl

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

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

@[simp] lemma lift_single (F : G →* R) (a b) :
  lift k G R F (single a b) = b • F a :=
by rw [single_eq_algebra_map_mul_of, ← algebra.smul_def, alg_hom.map_smul, lift_of]

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

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

/-- A `k`-algebra homomorphism from `monoid_star_algebra k G` is uniquely defined by its
values on the functions `single a 1`. -/
lemma alg_hom_ext ⦃φ₁ φ₂ : monoid_star_algebra k G →ₐ[k] R⦄
  (h : ∀ x, φ₁ (single x 1) = φ₂ (single x 1)) : φ₁ = φ₂ :=
(lift k G R).symm.injective $ monoid_hom.ext h

end lift

section

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 [group G] [comm_ring k]
  (V : Type u₃) [add_comm_group V] [module (monoid_star_algebra k G) V] (g : G) :
  (module.restrict_scalars k (monoid_star_algebra k G) V) →ₗ[k]
  (module.restrict_scalars k (monoid_star_algebra k G) 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,
  by simp only [module.restrict_scalars_smul_def, coe_algebra_map, ←mul_smul, single_one_comm], }.

@[simp]
lemma group_smul.linear_map_apply [group G] [comm_ring k]
  (V : Type u₃) [add_comm_group V] [module (monoid_star_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 [group G] [comm_ring k]
  {V : Type u₃} {gV : add_comm_group V} {mV : module (monoid_star_algebra k G) V}
  {W : Type u₃} {gW : add_comm_group W} {mW : module (monoid_star_algebra k G) W}
  (f : (module.restrict_scalars k (monoid_star_algebra k G) V) →ₗ[k]
       (module.restrict_scalars k (monoid_star_algebra k G) 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_star_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,
    rw [add_smul, linear_map.map_add, w, add_smul, add_left_inj,
      single_eq_algebra_map_mul_of, ←smul_smul, ←smul_smul],
    erw [f.map_smul, h g v],
    refl, }
  end, }

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

end
end

universe ui
variable {ι : Type ui}

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

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

@[simp]
lemma mul_single_apply (f : monoid_star_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_star_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_star_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 (f a) * 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_star_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 (g a)) x) :
  by rw [← finsupp.sum_apply, ← finsupp.mul_sum, g.sum_single]
... = _ : by simp only [mul_single_apply, finsupp.sum]

end

end monoid_star_algebra

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_star_algebra := G →₀ k

end

namespace add_monoid_star_algebra

variables {k G}
local attribute [reducible] add_monoid_star_algebra

section
variables [semiring k] [add_monoid G]

/-- The product of `f g : add_monoid_star_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_star_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_star_algebra k G} :
  f * g = (f.sum $ λa₁ b₁, g.sum $ λa₂ b₂, single (a₁ + a₂) (b₁ * b₂)) :=
rfl

lemma mul_apply (f g : add_monoid_star_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 support_mul (a b : add_monoid_star_algebra k G) :
  (a * b).support ⊆ a.support.bind (λa₁, b.support.bind $ λa₂, {a₁ + a₂}) :=
subset.trans support_sum $ bind_mono $ assume a₁ _,
  subset.trans support_sum $ bind_mono $ assume a₂ _, support_single_subset

/-- 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_star_algebra k G) :=
⟨single 0 1⟩

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

-- TODO: the simplifier unfolds 0 in the instance proof!
protected lemma zero_mul (f : add_monoid_star_algebra k G) : 0 * f = 0 :=
by simp only [mul_def, sum_zero_index]

protected lemma mul_zero (f : add_monoid_star_algebra k G) : f * 0 = 0 :=
by simp only [mul_def, sum_zero_index, sum_zero]

private lemma left_distrib (a b c : add_monoid_star_algebra k G) : a * (b + c) = a * b + a * c :=
by simp only [mul_def, sum_add_index, mul_add, mul_zero, single_zero, single_add,
  eq_self_iff_true, forall_true_iff, forall_3_true_iff, sum_add]

private lemma right_distrib (a b c : add_monoid_star_algebra k G) : (a + b) * c = a * c + b * c :=
by simp only [mul_def, sum_add_index, add_mul, mul_zero, zero_mul, single_zero,
  single_add, eq_self_iff_true, forall_true_iff, forall_3_true_iff, sum_zero, sum_add]

instance : semiring (add_monoid_star_algebra k G) :=
{ one       := 1,
  mul       := (*),
  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],
  zero_mul  := add_monoid_star_algebra.zero_mul,
  mul_zero  := add_monoid_star_algebra.mul_zero,
  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],
  left_distrib  := left_distrib,
  right_distrib := right_distrib,
  .. finsupp.add_comm_monoid }

lemma single_mul_single {a₁ a₂ : G} {b₁ b₂ : k} :
  (single a₁ b₁ : add_monoid_star_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]))

section

variables (k G)

/-- Embedding of a monoid into its monoid algebra. -/
def of : multiplicative G →* add_monoid_star_algebra k G :=
{ to_fun := λ a, single a 1,
  map_one' := rfl,
  map_mul' := λ a b, by { rw [single_mul_single, one_mul], refl } }

end

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

lemma mul_single_apply_aux (f : add_monoid_star_algebra k G) (r : k)
  (x y z : G) (H : ∀ a, a + x = z ↔ a = y) :
  (f * single x r) z = f y * r :=
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) :
  -- different `decidable` instances make it not trivial
  by { simp only [mul_apply, A, H], congr, funext, split_ifs; refl }
... = 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_zero_apply (f : add_monoid_star_algebra k G) (r : k) (x : G) :
  (f * single 0 r) x = f x * r :=
f.mul_single_apply_aux r _ _ _ $ λ a, by rw [add_zero]

lemma single_mul_apply_aux (f : add_monoid_star_algebra k G) (r : k) (x y z : G)
  (H : ∀ a, x + a = y ↔ a = z) :
  (single x r * f) y = r * f z :=
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 this
... = f.sum (λ a b, ite (a = z) (r * b) 0) :
  by { simp only [H], congr, ext; split_ifs; refl  }
... = 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_zero_mul_apply (f : add_monoid_star_algebra k G) (r : k) (x : G) :
  (single 0 r * f) x = r * f x :=
f.single_mul_apply_aux r _ _ _ $ λ a, by rw [zero_add]

end

instance [comm_semiring k] [add_comm_monoid G] : comm_semiring (add_monoid_star_algebra k G) :=
{ mul_comm := assume f g,
  begin
    simp only [mul_def, finsupp.sum, mul_comm],
    rw [finset.sum_comm],
    simp only [add_comm]
  end,
  .. add_monoid_star_algebra.semiring }

instance [ring k] : has_neg (add_monoid_star_algebra k G) :=
by apply_instance

instance [ring k] [add_monoid G] : ring (add_monoid_star_algebra k G) :=
{ neg := has_neg.neg,
  add_left_neg := add_left_neg,
  .. add_monoid_star_algebra.semiring }

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

instance [semiring k] : has_scalar k (add_monoid_star_algebra k G) :=
finsupp.has_scalar

instance [semiring k] : semimodule k (add_monoid_star_algebra k G) :=
finsupp.semimodule G k

instance [ring k] : module k (add_monoid_star_algebra k G) :=
by { delta add_monoid_star_algebra, apply_instance }

instance [comm_semiring k] [add_monoid G] : algebra k (add_monoid_star_algebra k G) :=
{ to_fun := single 0,
  map_one' := rfl,
  map_mul' := λ x y, by rw [single_mul_single, zero_add],
  map_zero' := single_zero,
  map_add' := λ x y, single_add,
  smul_def' := λ r a, by { ext x, exact smul_apply.trans (single_zero_mul_apply _ _ _).symm },
  commutes' := λ r f, show single 0 r * f = f * single 0 r,
    by ext; rw [single_zero_mul_apply, mul_single_zero_apply, mul_comm] }

@[simp] lemma coe_algebra_map [comm_semiring k] [add_monoid G] :
  (algebra_map k (add_monoid_star_algebra k G) : k → add_monoid_star_algebra k G) = single 0 :=
rfl

/-- Any monoid homomorphism `multiplicative G →* R` can be lifted to an algebra homomorphism
`add_monoid_star_algebra k G →ₐ[k] R`. -/
def lift [comm_semiring k] [add_monoid G] {R : Type u₃} [semiring R] [algebra k R] :
  (multiplicative G →* R) ≃ (add_monoid_star_algebra k G →ₐ[k] R) :=
{ inv_fun := λ f, ((f : add_monoid_star_algebra k G →+* R) : add_monoid_star_algebra k G →* R).comp (of k G),
  to_fun := λ F, { to_fun := λ f, f.sum (λ a b, b • F a),
    map_one' := by { rw [one_def, sum_single_index, one_smul], erw [F.map_one], apply zero_smul },
    map_mul' :=
      begin
        intros f g,
        rw [mul_def, finsupp.sum_mul, finsupp.sum_sum_index];
          try { intros, simp only [zero_smul, add_smul], done },
        refine finset.sum_congr rfl (λ a ha, _), simp only [],
        rw [finsupp.mul_sum, finsupp.sum_sum_index];
          try { intros, simp only [zero_smul, add_smul], done },
        refine finset.sum_congr rfl (λ a' ha', _), simp only [],
        rw [sum_single_index],
        erw [F.map_mul],
        rw [algebra.mul_smul_comm, algebra.smul_mul_assoc, smul_smul, mul_comm],
        apply zero_smul
      end,
    map_zero' := sum_zero_index,
    map_add' := λ f g, by rw [sum_add_index]; intros; simp only [zero_smul, add_smul],
    commutes' := λ r,
    begin
      rw [coe_algebra_map, sum_single_index],
      erw [F.map_one],
      rw [algebra.smul_def, mul_one],
      apply zero_smul
    end, },
  left_inv := λ f, begin ext x, simp [sum_single_index] end,
  right_inv := λ F,
    begin
      ext f,
      conv_rhs { rw ← f.sum_single },
      simp [← F.map_smul, finsupp.sum, ← F.map_sum]
    end }

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

universe ui
variable {ι : Type ui}

lemma prod_single [comm_semiring k] [add_comm_monoid G]
  {s : finset ι} {a : ι → G} {b : ι → k} :
  s.prod (λi, single (a i) (b i)) = single (s.sum a) (s.prod b) :=
finset.induction_on s rfl $ λ a s has ih, by rw [prod_insert has, ih,
  single_mul_single, sum_insert has, prod_insert has]

end add_monoid_star_algebra


import game.max.level03 -- hide

open_locale classical -- hide

noncomputable theory -- hide

namespace xena -- hide

/-
# Chapter ? : Max and abs

## Level 4

`le_max_right` is the statement that `b ≤ max a b`. There's a short
proof using what we've already done.
-/

/- Hint :
Why not start with `rw max_comm`?
-/

/- Lemma
For any real numbers $a$ and $b$, we have $b\leq\max(a,b).$
-/

theorem le_max_right (a b : ℝ) : b ≤ max a b :=
begin
  rw max_comm,
  apply le_max_left

end

end xena --hide


def Multiset (α: Type) : Type := sorry
def Multiset.ndinsert [DecidableEq α](a : α): Multiset α → Multiset α := sorry
def Finset (α : Type _) : Type := @Subtype (Multiset α) sorry
def Finset.insert [DecidableEq α](a : α): Finset α → Finset α
| ⟨ms, prop⟩ => ⟨ms.ndinsert a, sorry⟩

inductive Bar : Finset Nat → Type
| insert : Bar (Finset.insert n Γ)
| empty  : Bar Γ

example {Γ: Finset Nat}: ∀  (p: Bar Γ), Nat
| Bar.empty => 1 -- missing cases: (@Bar.insert _ (Subtype.mk _ _))
| _         => 2 -- redundant alternative


/-
Copyright (c) 2018 Simon Hudon. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Simon Hudon
-/
import tactic.hint

namespace tactic

open expr
open tactic.interactive ( casesm constructor_matching )

/--
  find all assumptions of the shape `¬ (p ∧ q)` or `¬ (p ∨ q)` and
  replace them using de Morgan's law.
-/
meta def distrib_not : tactic unit :=
do hs ← local_context,
   hs.for_each $ λ h,
    all_goals' $
    iterate_at_most' 3 $
      do h ← get_local h.local_pp_name,
         e ← infer_type h,
         match e with
         | `(¬ _ = _) := replace h.local_pp_name ``(mt iff.to_eq %%h)
         | `(_ ≠ _)   := replace h.local_pp_name ``(mt iff.to_eq %%h)
         | `(_ = _)   := replace h.local_pp_name ``(eq.to_iff %%h)
         | `(¬ (_ ∧ _))  := replace h.local_pp_name ``(decidable.not_and_distrib'.mp %%h) <|>
                            replace h.local_pp_name ``(decidable.not_and_distrib.mp %%h)
         | `(¬ (_ ∨ _))  := replace h.local_pp_name ``(not_or_distrib.mp %%h)
         | `(¬ ¬ _)      := replace h.local_pp_name ``(decidable.of_not_not %%h)
         | `(¬ (_ → (_ : Prop))) := replace h.local_pp_name ``(decidable.not_imp.mp %%h)
         | `(¬ (_ ↔ _)) := replace h.local_pp_name ``(decidable.not_iff.mp %%h)
         | `(_ ↔ _) := replace h.local_pp_name ``(decidable.iff_iff_and_or_not_and_not.mp %%h) <|>
                       replace h.local_pp_name ``(decidable.iff_iff_and_or_not_and_not.mp (%%h).symm) <|>
                       () <$ tactic.cases h
         | `(_ → _)     := replace h.local_pp_name ``(decidable.not_or_of_imp %%h)
         | _ := failed
         end

/-!
  The following definitions maintain a path compression datastructure, i.e. a forest such that:
    - every node is the type of a hypothesis
    - there is a edge between two nodes only if they are provably equivalent
    - every edge is labelled with a proof of equivalence for its vertices
    - edges are added when normalizing propositions.
-/

meta def tauto_state := ref $ expr_map (option (expr × expr))

meta def modify_ref {α : Type} (r : ref α) (f : α → α) :=
read_ref r >>= write_ref r ∘ f

meta def add_refl (r : tauto_state) (e : expr) : tactic (expr × expr) :=
do m ← read_ref r,
   p ← mk_mapp `rfl [none,e],
   write_ref r $ m.insert e none,
   return (e,p)

/--
  If there exists a symmetry lemma that can be applied to the hypothesis `e`,
  store it.
-/
meta def add_symm_proof (r : tauto_state) (e : expr) : tactic (expr × expr) :=
do env ← get_env,
   let rel := e.get_app_fn.const_name,
   some symm ← pure $ environment.symm_for env rel
     | add_refl r e,
   (do e' ← mk_meta_var `(Prop),
       iff_t ← to_expr ``(%%e = %%e'),
       (_,p) ← solve_aux iff_t
         (applyc `iff.to_eq ; () <$ split ; applyc symm),
       e' ← instantiate_mvars e',
       m ← read_ref r,
       write_ref r $ (m.insert e (e',p)).insert e' none,
       return (e',p) )
   <|> add_refl r e

meta def add_edge (r : tauto_state) (x y p : expr) : tactic unit :=
modify_ref r $ λ m, m.insert x (y,p)

/--
  Retrieve the root of the hypothesis `e` from the proof forest.
  If `e` has not been internalized, add it to the proof forest.
-/
meta def root (r : tauto_state) : expr → tactic (expr × expr) | e :=
do m ← read_ref r,
   let record_e : tactic (expr × expr) :=
       match e with
       | v@(expr.mvar _ _ _) :=
         (do (e,p) ← get_assignment v >>= root,
             add_edge r v e p,
             return (e,p)) <|>
         add_refl r e
       | _ := add_refl r e
       end,
   some e' ← pure $ m.find e | record_e,
   match e' with
   | (some (e',p')) :=
     do (e'',p'') ← root e',
        p'' ← mk_app `eq.trans [p',p''],
        add_edge r e e'' p'',
        pure (e'',p'')
   | none := prod.mk e <$> mk_mapp `rfl [none,some e]
   end

/--
  Given hypotheses `a` and `b`, build a proof that `a` is equivalent to `b`,
  applying congruence and recursing into arguments if `a` and `b`
  are applications of function symbols.
-/
meta def symm_eq (r : tauto_state) : expr → expr → tactic expr | a b :=
do m ← read_ref r,
   (a',pa) ← root r a,
   (b',pb) ← root r b,
   (unify a' b' >> add_refl r a' *> mk_mapp `rfl [none,a]) <|>
    do p ← match (a', b') with
           | (`(¬ %%a₀), `(¬ %%b₀)) :=
             do p  ← symm_eq a₀ b₀,
                p' ← mk_app `congr_arg [`(not),p],
                add_edge r a' b' p',
                return p'
           | (`(%%a₀ ∧ %%a₁), `(%%b₀ ∧ %%b₁)) :=
             do p₀ ← symm_eq a₀ b₀,
                p₁ ← symm_eq a₁ b₁,
                p' ← to_expr ``(congr (congr_arg and %%p₀) %%p₁),
                add_edge r a' b' p',
                return p'
           | (`(%%a₀ ∨ %%a₁), `(%%b₀ ∨ %%b₁)) :=
             do p₀ ← symm_eq a₀ b₀,
                p₁ ← symm_eq a₁ b₁,
                p' ← to_expr ``(congr (congr_arg or %%p₀) %%p₁),
                add_edge r a' b' p',
                return p'
           | (`(%%a₀ ↔ %%a₁), `(%%b₀ ↔ %%b₁)) :=
             (do p₀ ← symm_eq a₀ b₀,
                 p₁ ← symm_eq a₁ b₁,
                 p' ← to_expr ``(congr (congr_arg iff %%p₀) %%p₁),
                 add_edge r a' b' p',
                 return p') <|>
             do p₀ ← symm_eq a₀ b₁,
                p₁ ← symm_eq a₁ b₀,
                p' ← to_expr ``(eq.trans (congr (congr_arg iff %%p₀) %%p₁)
                                         (iff.to_eq iff.comm ) ),
                add_edge r a' b' p',
                return p'
           | (`(%%a₀ → %%a₁), `(%%b₀ → %%b₁)) :=
             if ¬ a₁.has_var ∧ ¬ b₁.has_var then
             do p₀ ← symm_eq a₀ b₀,
                p₁ ← symm_eq a₁ b₁,
                p' ← mk_app `congr_arg [`(implies),p₀,p₁],
                add_edge r a' b' p',
                return p'
             else unify a' b' >> add_refl r a' *> mk_mapp `rfl [none,a]
           | (_, _) :=
             (do guard $ a'.get_app_fn.is_constant ∧
                         a'.get_app_fn.const_name = b'.get_app_fn.const_name,
                 (a'',pa') ← add_symm_proof r a',
                 guard $ a'' =ₐ b',
                 pure pa' )
           end,
    p' ← mk_eq_trans pa p,
    add_edge r a' b' p',
    mk_eq_symm pb >>= mk_eq_trans p'

meta def find_eq_type (r : tauto_state) : expr → list expr → tactic (expr × expr)
| e []         := failed
| e (H :: Hs) :=
  do t  ← infer_type H,
     (prod.mk H <$> symm_eq r e t) <|> find_eq_type e Hs

private meta def contra_p_not_p (r : tauto_state) : list expr → list expr → tactic unit
| []         Hs := failed
| (H1 :: Rs) Hs :=
  do t ← (extract_opt_auto_param <$> infer_type H1) >>= whnf,
     (do a   ← match_not t,
         (H2,p)  ← find_eq_type r a Hs,
         H2 ← to_expr ``( (%%p).mpr %%H2 ),
         tgt ← target,
         pr  ← mk_app `absurd [tgt, H2, H1],
         tactic.exact pr)
     <|> contra_p_not_p Rs Hs

meta def contradiction_with (r : tauto_state) : tactic unit :=
contradiction <|>
do tactic.try intro1,
   ctx ← local_context,
   contra_p_not_p r ctx ctx

meta def contradiction_symm :=
using_new_ref (native.rb_map.mk _ _) contradiction_with

meta def assumption_with (r : tauto_state) : tactic unit :=
do { ctx ← local_context,
     t   ← target,
     (H,p) ← find_eq_type r t ctx,
     mk_eq_mpr p H >>= tactic.exact }
<|> fail "assumption tactic failed"

meta def assumption_symm :=
using_new_ref (native.rb_map.mk _ _) assumption_with

/--
  Configuration options for `tauto`.
  If `classical` is `tt`, runs `classical` before the rest of `tauto`.
  `closer` is run on any remaining subgoals left by `tauto_core; basic_tauto_tacs`.
-/
meta structure tauto_cfg :=
(classical : bool     := ff)
(closer : tactic unit := pure ())

meta def tautology (cfg : tauto_cfg := {}) : tactic unit := focus1 $
  let basic_tauto_tacs : list (tactic unit) :=
        [reflexivity, solve_by_elim,
          constructor_matching none [``(_ ∧ _),``(_ ↔ _),``(Exists _),``(true)]],

      tauto_core (r : tauto_state) : tactic unit :=
        do try (contradiction_with r);
           try (assumption_with r);
           repeat (do
             gs ← get_goals,
             repeat (() <$ tactic.intro1);
             distrib_not;
             casesm (some ()) [``(_ ∧ _),``(_ ∨ _),``(Exists _),``(false)];
             try (contradiction_with r);
             try (target >>= match_or >> refine ``( or_iff_not_imp_left.mpr _));
             try (target >>= match_or >> refine ``( or_iff_not_imp_right.mpr _));
             repeat (() <$ tactic.intro1);
             constructor_matching (some ()) [``(_ ∧ _),``(_ ↔ _),``(true)];
             try (assumption_with r),
             gs' ← get_goals,
             guard (gs ≠ gs') ) in

    do when cfg.classical classical,
       using_new_ref (expr_map.mk _) tauto_core;
       repeat (first basic_tauto_tacs); cfg.closer, done

namespace interactive
local postfix `?`:9001 := optional
setup_tactic_parser

/--
`tautology` breaks down assumptions of the form `_ ∧ _`, `_ ∨ _`, `_ ↔ _` and `∃ _, _`
and splits a goal of the form `_ ∧ _`, `_ ↔ _` or `∃ _, _` until it can be discharged
using `reflexivity` or `solve_by_elim`.
This is a finishing tactic: it either closes the goal or raises an error.
The variant `tautology!` uses the law of excluded middle.

`tautology {closer := tac}` will use `tac` on any subgoals created by `tautology`
that it is unable to solve before failing.
-/
meta def tautology (c : parse $ (tk "!")?) (cfg : tactic.tauto_cfg := {}) :=
tactic.tautology $ { classical := c.is_some, ..cfg }

-- Now define a shorter name for the tactic `tautology`.

/--
`tauto` breaks down assumptions of the form `_ ∧ _`, `_ ∨ _`, `_ ↔ _` and `∃ _, _`
and splits a goal of the form `_ ∧ _`, `_ ↔ _` or `∃ _, _` until it can be discharged
using `reflexivity` or `solve_by_elim`.
This is a finishing tactic: it either closes the goal or raises an error.
The variant `tauto!` uses the law of excluded middle.

`tauto {closer := tac}` will use `tac` on any subgoals created by `tauto`
that it is unable to solve before failing.
-/
meta def tauto (c : parse $ (tk "!")?) (cfg : tactic.tauto_cfg := {}) : tactic unit :=
tautology c cfg

add_hint_tactic "tauto"

/--
This tactic (with shorthand `tauto`) breaks down assumptions of the form
`_ ∧ _`, `_ ∨ _`, `_ ↔ _` and `∃ _, _`
and splits a goal of the form `_ ∧ _`, `_ ↔ _` or `∃ _, _` until it can be discharged
using `reflexivity` or `solve_by_elim`. This is a finishing tactic: it
either closes the goal or raises an error.

The variants `tautology!` and `tauto!` use the law of excluded middle.

For instance, one can write:
```lean
example (p q r : Prop) [decidable p] [decidable r] : p ∨ (q ∧ r) ↔ (p ∨ q) ∧ (r ∨ p ∨ r) := by tauto
```
and the decidability assumptions can be dropped if `tauto!` is used
instead of `tauto`.

`tauto {closer := tac}` will use `tac` on any subgoals created by `tauto`
that it is unable to solve before failing.
-/
add_tactic_doc
{ name       := "tautology",
  category   := doc_category.tactic,
  decl_names := [`tactic.interactive.tautology, `tactic.interactive.tauto],
  tags       := ["logic", "decision procedure"] }

end interactive
end tactic


def f (x : Nat) := 0

theorem ex1 (h : f x = 1) : False := by
  simp [f] at h

def g (x : Nat) := [x]

theorem ex2 (h : g x = []) : 0 = 1 := by
  simp [g] at h

theorem ex3 (x : α) (h : id x ≠ x) : 0 = 1 := by
  simp at h


import algebra.big_operators.norm_num
import data.nat.fib
import data.nat.succ_pred
import linear_algebra.basis
import ring_theory.adjoin_root
import ring_theory.power_basis
import tactic.norm_fin
import tactic.norm.ring

open_locale big_operators

local attribute [-instance] rat.semiring rat.comm_semiring rat.comm_ring

-- TODO: generalize this so we don't assume a multiplication on `S`
-- or even no structure on `S` at all
structure times_table (ι R S : Type*) [fintype ι]
  [semiring R] [add_comm_monoid S] [module R S] [has_mul S] :=
(basis : basis ι R S)
(table : ι → ι → ι → R)
(unfold_mul' : ∀ x y k, basis.repr (x * y) k = ∑ i j : ι, basis.repr x i * basis.repr y j * table i j k)
-- (mul_def : ∀ i j k, basis.repr (basis i * basis j) k = table i j k)

mk_simp_attribute times_table_simps "The simpset `times_table_simps` is used by the tactic
`times_table` to reduce an expression of the form `(t : times_table).basis.repr x k` to a numeral."

section add_monoid

variables {ι R S : Type*} [fintype ι] [semiring R] [add_comm_monoid S] [module R S] [has_mul S]

noncomputable def times_table.coord (t : times_table ι R S) (x : S) (i : ι) : R :=
t.basis.repr x i

@[simp] lemma times_table.basis_repr_eq (t : times_table ι R S) (x : S) (i : ι) :
  t.basis.repr x i = t.coord x i := rfl

@[simp] lemma times_table.coord_basis [decidable_eq ι] (t : times_table ι R S) (i : ι) :
  t.coord (t.basis i) = pi.single i 1 :=
by ext; rw [← t.basis_repr_eq, t.basis.repr_self i, finsupp.single_eq_pi_single]

lemma times_table.unfold_mul (t : times_table ι R S) :
  ∀ x y k, t.coord (x * y) k = ∑ i j : ι, t.coord x i * t.coord y j * t.table i j k :=
t.unfold_mul'

lemma times_table.ext (t : times_table ι R S) {x y : S} (h : ∀ i, t.coord x i = t.coord y i) :
  x = y :=
t.basis.ext_elem h

end add_monoid

section semiring
variables {ι R S : Type*} [fintype ι] [comm_semiring R] [non_unital_non_assoc_semiring S] [module R S]

@[simp] lemma times_table.mul_def (t : times_table ι R S) (i j k : ι)  :
  t.coord (t.basis i * t.basis j) k = t.table i j k :=
begin
  letI := classical.dec_eq ι,
  simp only [t.unfold_mul, times_table.coord_basis],
  rw [fintype.sum_eq_single i, fintype.sum_eq_single j, pi.single_eq_same,
      pi.single_eq_same, one_mul, one_mul];
    { intros x hx, simp [pi.single_eq_of_ne hx] }
end

variables [smul_comm_class R S S] [is_scalar_tower R S S]

@[simp] lemma linear_equiv.map_bit0 {R M N : Type*} [semiring R] [add_comm_monoid M] [module R M] [add_comm_monoid N] [module R N]
  (f : M ≃ₗ[R] N) (x : M) : f (bit0 x) = bit0 (f x) :=
by { unfold bit0, simp only [_root_.map_add, finsupp.coe_add, pi.add_apply] }
@[simp] lemma linear_equiv.map_bit1 {R M N : Type*} [semiring R] [add_comm_monoid M] [module R M] [add_comm_monoid N] [module R N] [has_one M]
  (f : M ≃ₗ[R] N) (x : M) : f (bit1 x) = bit0 (f x) + f 1 :=
by { unfold bit1 bit0, simp only [_root_.map_add, finsupp.coe_add, pi.add_apply] }

end semiring

namespace tactic.times_table

open tactic

section add_comm_monoid

variables {R S ι : Type*} [fintype ι] [comm_semiring R] [add_comm_monoid S] [module R S]
variables [has_mul S]

protected lemma coord_zero (t : times_table ι R S) (k : ι) :
  t.coord 0 k = 0 :=
by rw [← t.basis_repr_eq, _root_.map_zero, finsupp.zero_apply]

protected lemma coord_bit0 (t : times_table ι R S) (k : ι) {e₁ : S} {e₁' e' : R}
  (e₁_eq : t.coord e₁ k = e₁') (e_eq : e₁' + e₁' = e') :
  t.coord (bit0 e₁) k = e' :=
by rw [bit0, ← t.basis_repr_eq, _root_.map_add, finsupp.add_apply, t.basis_repr_eq, e₁_eq, e_eq]

protected lemma coord_bit1 [has_one S] (t : times_table ι R S) (k : ι) {e₁ : S} {e₁' e₁2 e' o : R}
  (e₁_eq : t.coord e₁ k = e₁') (one_eq : t.coord 1 k = o) (e2_eq : e₁' + e₁' = e₁2)
  (e_eq : e₁2 + o = e') :
  t.coord (bit1 e₁) k = e' :=
by simp only [← t.basis_repr_eq,bit1, bit0, _root_.map_add, finsupp.add_apply, t.basis_repr_eq,
  e₁_eq, e2_eq, one_eq, e_eq]

protected lemma coord_add (t : times_table ι R S) (k : ι) {e₁ e₂ : S} {e₁' e₂' e' : R}
  (e₁_eq : t.coord e₁ k = e₁') (e₂_eq : t.coord e₂ k = e₂') (e_eq : e₁' + e₂' = e') :
  t.coord (e₁ + e₂) k = e' :=
by rw [← t.basis_repr_eq,_root_.map_add, finsupp.add_apply, t.basis_repr_eq, e₁_eq, t.basis_repr_eq,
    e₂_eq, e_eq]

protected lemma coord_mul (t : times_table ι R S) (k : ι) (e₁ e₂ : S) (e' : R)
  (eq : ∑ i j : ι, t.coord e₁ i * t.coord e₂ j * t.table i j k = e') :
  t.coord (e₁ * e₂) k = e' :=
by rw [times_table.unfold_mul t, eq]

protected lemma coord_repr_table {ι : Sort*}
  {r₁i r₂j tijk e₁' e₂' t' e₁e₂ e' : R} (e₁_eq : r₁i = e₁') (e₂_eq : r₂j = e₂')
  (t_eq : tijk = t') (e₁e₂_eq : e₁' * e₂' = e₁e₂) (eq : e₁e₂ * t' = e') :
  r₁i * r₂j * tijk = e' :=
by rw [e₁_eq, e₂_eq, t_eq, e₁e₂_eq, eq]

end add_comm_monoid

section semiring

variables {R S ι : Type*} [fintype ι] [comm_semiring R] [semiring S] [module R S]

protected lemma eval_pow_zero (t : times_table ι R S) (k : ι) (e₁ : S) {e' : R}
  (e_eq : t.coord 1 k = e') :
  t.coord (e₁ ^ 0) k = e' :=
by rw [pow_zero, e_eq]

protected lemma eval_pow_one (t : times_table ι R S) (k : ι) {e₁ : S} {e' : R}
  (e_eq : t.coord e₁ k = e') :
  t.coord (e₁ ^ 1) k = e' :=
by rw [pow_one, e_eq]

protected lemma eval_pow_bit0 (t : times_table ι R S) (k : ι) (n : ℕ) {e₁ : S} {e' : R}
  (e_eq : t.coord (e₁ ^ n * e₁ ^ n) k = e') :
  t.coord (e₁ ^ (bit0 n)) k = e' :=
by rw [pow_bit0, e_eq]

protected lemma eval_pow_bit1 (t : times_table ι R S) (k : ι) (n : ℕ) {e₁ : S} {e' : R}
  (e_eq : t.coord (e₁ ^ n * e₁ ^ n * e₁) k = e') :
  t.coord (e₁ ^ (bit1 n)) k = e' :=
by rw [pow_bit1, e_eq]

end semiring

section ring

variables {R S ι : Type*} [fintype ι] [comm_ring R] [ring S] [module R S]

protected lemma coord_sub (t : times_table ι R S) (k : ι) {e₁ e₂ : S} {e₁' e₂' e' : R}
  (e₁_eq : t.coord e₁ k = e₁') (e₂_eq : t.coord e₂ k = e₂') (e_eq : e₁' - e₂' = e') :
  t.coord (e₁ - e₂) k = e' :=
by rw [← t.basis_repr_eq, _root_.map_sub, finsupp.sub_apply, t.basis_repr_eq, e₁_eq,
  t.basis_repr_eq, e₂_eq, e_eq]

protected lemma coord_neg (t : times_table ι R S) (k : ι) {e₁ : S} {e₁' e' : R}
  (e₁_eq : t.coord e₁ k = e₁') (e_eq : -e₁' = e') :
  t.coord (-e₁) k = e' :=
by rw [← t.basis_repr_eq, _root_.map_neg, finsupp.neg_apply, t.basis_repr_eq, e₁_eq, e_eq]

end ring

section matrix

open matrix

section converter

meta structure context :=
(simps : simp_lemmas)
(cache : tactic.norm.ring.cache)
(coord_univ : native.rb_map expr (expr × expr × list expr))

meta abbreviation eval_m (α : Type*) := state_t context tactic α

/-- Evaluates a parsed (in α) expression into a normal form (in β). -/
meta abbreviation evaluator (α β : Type*) := expr × α → eval_m (expr × expr × β)

meta abbreviation converter := expr → eval_m (expr × expr)

/-- `trace_error msg t` executes the tactic `t`. If `t` fails, traces `msg` and the failure message
of `t`. -/
meta def trace_error {α σ} (msg : string) (t : state_t σ tactic α) : state_t σ tactic α :=
{ run := λ s ts, match t.run s ts with
       | (result.success r s') := result.success r s'
       | (result.exception (some msg') p s') := (trace msg >> trace (msg' ()) >> result.exception
            (some msg') p) s'
       | (result.exception none p s') := result.exception none p s'
       end }

meta def lift {σ α} : tactic α → state_t σ tactic α := state_t.lift
meta def converter.lift {σ α β} : (α → tactic β) → α → state_t σ tactic β := λ t x, lift (t x)

meta def converter.refl : converter
| e := lift (refl_conv e)

meta def converter.or : converter → converter → converter
| c d e := c e <|> d e

meta def converter.or_refl (c : converter) : converter := c.or converter.refl

meta def converter.trans : converter → converter → converter
| c d e := do
  (e', pf_c) ← c.or_refl e,
  (e'', pf_d) ← d.or_refl e',
  pf ← lift $ mk_eq_trans pf_c pf_d,
  pure (e'', pf)

meta def get_context : state_t context tactic context :=
state_t.get

meta def to_expr' : pexpr → tactic expr := i_to_expr

meta def to_expr : pexpr → eval_m expr := lift ∘ to_expr'

end converter

namespace tactic.norm_num

/-- Use `norm_num` to decide equality between two expressions.
If the decision procedure succeeds, the `bool` value indicates whether the expressions are equal,
and the `expr` is a proof of (dis)equality.
This procedure is partial: it will fail in cases where `norm_num` can't reduce either side
to a rational numeral.
-/
meta def decide_eq (l r : expr) : tactic (bool × expr) := do
  (l', l'_pf) ← or_refl_conv norm_num.derive l,
  (r', r'_pf) ← or_refl_conv norm_num.derive r,
  n₁ ← l'.to_rat, n₂ ← r'.to_rat,
  c ← infer_type l' >>= mk_instance_cache,
  if n₁ = n₂ then do
    pf ← mk_eq_symm r'_pf >>= mk_eq_trans l'_pf,
    pure (tt, pf)
  else do
    (_, p) ← norm_num.prove_ne c l' r' n₁ n₂,
    pure (ff, p)

lemma list.mem_cons_of_head {α : Type*} {x y : α} (ys : list α) (h₁ : x = y) :
  x ∈ y :: ys :=
(list.mem_cons_iff x y _).mpr (or.inl h₁)

lemma list.mem_cons_of_tail {α : Type*} {x y : α} {ys : list α} (h₂ : x ∈ ys) :
  x ∈ y :: ys :=
(list.mem_cons_iff x y _).mpr (or.inr h₂)

lemma list.not_mem_cons {α : Type*} {x y : α} {ys : list α} (h₁ : x ≠ y) (h₂ : x ∉ ys) :
  x ∉ y :: ys :=
λ h, ((list.mem_cons_iff _ _ _).mp h).elim h₁ h₂

/-- Use a decision procedure for the equality of list elements to decide list membership.
If the decision procedure succeeds, the `bool` value indicates whether the expressions are equal,
and the `expr` is a proof of (dis)equality.
This procedure is partial iff its parameter `decide_eq` is partial.
-/
meta def list.decide_mem (decide_eq : expr → expr → tactic (bool × expr)) :
  expr → list expr → tactic (bool × expr)
| x [] := do
  pf ← mk_app `list.not_mem_nil [x],
  pure (ff, pf)
| x (y :: ys) := do
  (is_head, head_pf) ← decide_eq x y,
  if is_head then do
    pf ← mk_app `list.mem_cons_of_head [head_pf],
    pure (tt, pf)
  else do
    (mem_tail, tail_pf) ← list.decide_mem x ys,
    if mem_tail then do
      pf ← mk_app `list.mem_cons_of_tail [tail_pf],
      pure (tt, pf)
    else do
      pf ← mk_app `list.not_mem_cons [head_pf, tail_pf],
      pure (ff, pf)

lemma finset.insert_eq_coe_list_of_mem {α : Type*} [decidable_eq α] (x : α) (xs : finset α)
  {xs' : list α} (h : x ∈ xs') (nd_xs : xs'.nodup)
  (hxs' : xs = finset.mk ↑xs' (multiset.coe_nodup.mpr nd_xs)) :
  insert x xs = finset.mk ↑xs' (multiset.coe_nodup.mpr nd_xs) :=
have h : x ∈ xs, by simpa [hxs'] using h,
by rw [finset.insert_eq_of_mem h, hxs']

lemma finset.insert_eq_coe_list_cons {α : Type*} [decidable_eq α] (x : α) (xs : finset α)
  {xs' : list α} (h : x ∉ xs') (nd_xs : xs'.nodup) (nd_xxs : (x :: xs').nodup)
  (hxs' : xs = finset.mk ↑xs' (multiset.coe_nodup.mpr nd_xs)) :
  insert x xs = finset.mk ↑(x :: xs') (multiset.coe_nodup.mpr nd_xxs) :=
have h : x ∉ xs, by simpa [hxs'] using h,
by { rw [← finset.val_inj, finset.insert_val_of_not_mem h, hxs'], simp only [multiset.cons_coe] }

/-- Given an expression defeq to a natural numeral, return the value of this numeral.

This is a slightly more powerful version of `expr.to_nat`.
-/
meta def parse_nat : expr → option ℕ
| `(%%a + %%b) := do
  a' ← parse_nat a,
  b' ← parse_nat b,
  pure (a' + b')
| n := expr.to_nat n

lemma list.map_cons_congr {α β : Type*} (f : α → β) (x : α) (xs : list α) (fx : β) (fxs : list β)
  (h₁ : f x = fx) (h₂ : xs.map f = fxs) : (x :: xs).map f = fx :: fxs :=
by rw [list.map_cons, h₁, h₂]

meta def list.to_expr (α : expr) : list expr → tactic expr
| [] := mk_app `list.nil [α]
| (ex :: xs) := do
  exs ← list.to_expr xs,
  mk_app `list.cons [α, ex, exs]

/-- Apply `ef : α → β` to all elements of the list, constructing an equality proof.
`eval_f (x : expr) : tactic (expr × expr)` is a conversion procedure for simplifying expressions
of the form `(%%ef %%x), where `ef : expr` is the function to apply and `x : expr` is a list
element.
-/
meta def eval_list_map {α β : Type*} (ef : expr)
  (eval_f : expr × α → eval_m (expr × expr × β)) :
  expr → list (α) → state_t context tactic (list (expr × β) × expr)
| exs [] := do
  match exs with
  | `(list.nil) := do
    eq ← lift $ mk_app `list.map_nil [ef],
    pure ([], eq)
  | _ := lift $ fail!"eval_list_map: expecting `list.nil`, received {exs}"
  end
| `(list.cons %%ex %%exs) (x :: xs) := do
  (fx, fx_eq, fx_d) ← eval_f (ex, x),
  (fxs, fxs_eq) ← eval_list_map exs xs,
  ty ← lift $ infer_type fx,
  fxs_list ← lift $ list.to_expr ty (fxs.map prod.fst),
  eq ← lift $ mk_app `tactic.times_table.tactic.norm_num.list.map_cons_congr [ef, ex, exs, fx, fxs_list, fx_eq, fxs_eq],
  pure ((fx, fx_d) :: fxs, eq)
| exs (_ :: _) := lift $ fail format!"eval_list_map: expecting `list.cons _ _`, received {exs}"

lemma list.cons_congr {α : Type*} (x : α) {xs : list α} {xs' : list α} (xs_eq : xs' = xs) :
  x :: xs' = x :: xs :=
by rw xs_eq

lemma list.map_congr {α β : Type*} (f : α → β) {xs xs' : list α}
  {ys : list β} (xs_eq : xs = xs') (ys_eq : xs'.map f = ys) :
  xs.map f = ys :=
by rw [← ys_eq, xs_eq]

/-- Convert an expression denoting a list to a list of elements. -/
meta def eval_list : expr → eval_m (expr × expr × list expr)
| e@`(list.nil) := do
  eq ← lift $ mk_eq_refl e,
  pure (e, eq, [])
| e@`(list.cons %%x %%xs) := do
  (exs, xs_eq, xs) ← eval_list xs,
  e' ← lift $ mk_app `list.cons [x, exs],
  eq ← lift $ mk_app `list.cons_congr [x, xs_eq],
  pure (e', eq, x :: xs)
/-
| e@`(list.range %%en) := do
  n ← lift $ parse_nat en,
  eis ← lift $ (list.range n).mmap (λ i, expr.of_nat `(ℕ) i),
  eq ← lift $ mk_eq_refl e,
  pure (eis, eq)
| `(@list.map %%α %%β %%ef %%exs) := do
  (xs, xs_eq) ← eval_list exs,
  (ys, ys_eq) ← eval_list_map ef (converter.or_refl $ converter.lift norm_num.derive) xs,
  eq ← to_expr ``(list.map_congr %%ef %%xs_eq %%ys_eq),
  pure (ys, eq)
-/
| e@`(@list.fin_range %%en) := do
  n ← lift $ parse_nat en,
  eis ← (list.fin_range n).mmap (λ i, lift $ expr.of_nat `(fin %%en) i),
  eq ← lift $ mk_eq_refl e,
  let e'_list := eis.foldr (λ x xs, `(@list.cons (fin %%en) %%x %%xs)) `(@list.nil (fin %%en)),
  pure (e'_list, eq, eis)
| e := lift $ fail (to_fmt "Unknown list expression" ++ format.line ++ to_fmt e)

lemma multiset.cons_congr {α : Type*} (x : α) {xs : multiset α} {xs' : list α}
  (xs_eq : (xs' : multiset α) = xs) : (list.cons x xs' : multiset α) = x ::ₘ xs :=
by rw [← xs_eq]; refl

lemma multiset.map_congr {α β : Type*} (f : α → β) {xs : multiset α}
  {xs' : list α} {ys : list β} (xs_eq : xs = (xs' : multiset α)) (ys_eq : xs'.map f = ys) :
  xs.map f = (ys : multiset β) :=
by rw [← ys_eq, ← multiset.coe_map, xs_eq]

/-- Convert an expression denoting a multiset to a list of elements,
normalizing the expression to a sequence of `multiset.cons` and `0`.
We return a list rather than a finset, so we can more easily iterate over it
(without having to prove that our tactics are independent of the order of iteration,
which is in general not true).
-/
meta def eval_multiset : expr → eval_m (expr × expr × list expr)
| e@`(@has_zero.zero (multiset _) _) := do
  eq ← lift $ mk_eq_refl e,
  pure (e, eq, [])
| e@`(@has_emptyc.emptyc _ %%inst) := do
  eq ← lift $ mk_eq_refl e,
  pure (e, eq, [])
| e@`(has_singleton.singleton %%x) := do
  eq ← lift $ mk_eq_refl e,
  pure (e, eq, [x])
| e@`(multiset.cons %%x %%xs) := do
  (exs, xs_eq, xs) ← eval_multiset xs,
  e' ← lift $ mk_app `multiset.cons [x, exs],
  eq ← lift $ mk_app `multiset.cons_congr [x, xs_eq],
  pure (e', eq, x :: xs)
| e@`(@@has_insert.insert multiset.has_insert %%x %%xs) := do
  (exs, xs_eq, xs) ← eval_multiset xs,
  e' ← lift $ mk_app `multiset.cons [x, exs],
  eq ← lift $ mk_app `multiset.cons_congr [x, xs_eq],
  pure (e', eq, x :: xs)
/-
| e@`(multiset.range %%en) := do
  n ← lift $ parse_nat en,
  eis ← lift $ (list.range n).mmap (λ i, expr.of_nat `(ℕ) i),
  eq ← lift $ mk_eq_refl e,
  pure (eis, eq)
| `(@multiset.map %%α %%β %%ef %%exs) := do
  (xs, xs_eq) ← eval_multiset exs,
  (ys, ys_eq) ← eval_list_map ef (converter.or_refl $ converter.lift norm_num.derive) xs,
  eq ← to_expr ``(multiset.map_congr %%ef %%xs_eq %%ys_eq),
  pure (ys, eq)
-/
| `(@@coe (@@coe_to_lift (@@coe_base (multiset.has_coe))) %%exs) := do
  (exs, xs_eq, xs) ← trace_error "eval_list" $ eval_list exs,
  e ← to_expr ``(@@coe (@@coe_to_lift (@@coe_base (multiset.has_coe))) %%exs),
  eq ← to_expr ``(congr_arg coe %%xs_eq),
  pure (e, eq, xs)
| e := lift $ fail (to_fmt "Unknown multiset expression" ++ format.line ++ to_fmt e)

lemma finset.mk_congr {α : Type*} {xs xs' : multiset α} (h : xs = xs') (nd nd') :
  finset.mk xs nd = finset.mk xs' nd' :=
by congr; assumption

lemma finset.nodup_congr {α : Type*} (xs xs' : multiset α) (h : xs = xs') (nd : xs.nodup) :
  xs'.nodup :=
by rwa h at nd

/-- Convert an expression denoting a finset to an expression of the form `finset.mk ↑xs nodup`.
We return a list rather than a finset, so we can more easily iterate over it
(without having to prove that our tactics are independent of the order of iteration,
which is in general not true).
`decide_eq` is a (partial) decision procedure for determining whether two
elements of the finset are equal, for example to parse `{2, 1, 2}` into `[2, 1]`.
-/
meta def eval_finset (decide_eq : expr → expr → tactic (bool × expr)) :
  expr → eval_m (expr × expr × list expr)
| e@`(finset.mk %%val %%nd) := do
  (norm, eq, val') ← trace_error "eval_multiset" $ eval_multiset val,
  nd' ← to_expr ``(finset.nodup_congr %%val %%norm %%eq %%nd),
  e' ← to_expr ``(finset.mk %%norm %%nd'),
  eq' ← to_expr ``(finset.mk_congr %%eq %%nd %%nd'),
  pure (e', eq', val')
/-
| e@`(has_emptyc.emptyc) := do
  eq ← mk_eq_refl e,
  nd ← to_expr' ``(list.nodup_nil),
  pure ([], eq, nd)
| e@`(has_singleton.singleton %%x) := do
  eq ← mk_eq_refl e,
  nd ← to_expr' ``(list.nodup_singleton %%x),
  pure ([x], eq, nd)
| `(@@has_insert.insert (@@finset.has_insert %%dec) %%x %%xs) := do
  (exs, xs_eq, xs_nd) ← eval_finset xs,
  (is_mem, mem_pf) ← list.decide_mem decide_eq x exs,
  if is_mem then do
    pf ← to_expr' ``(finset.insert_eq_coe_list_of_mem %%x %%xs %%mem_pf %%xs_nd %%xs_eq),
    pure (exs, pf, xs_nd)
  else do
    nd ← to_expr' ``(list.nodup_cons.mpr ⟨%%mem_pf, %%xs_nd⟩),
    pf ← to_expr' ``(finset.insert_eq_coe_list_cons %%x %%xs %%mem_pf %%xs_nd %%nd %%xs_eq),
    pure (x :: exs, pf, nd)
-/
| `(@@finset.univ %%ft) := trace_error "eval_finset `finset.univ`" $ do
  -- Convert the fintype instance expression `ft` to a list of its elements.
  -- Unfold it to the `fintype.mk` constructor and a list of arguments.
  `fintype.mk ← lift $ get_app_fn_const_whnf ft
    | lift $ fail (to_fmt "Unknown fintype expression" ++ format.line ++ to_fmt ft),
  [_, args, _] ← lift $ get_app_args_whnf ft | lift $ fail (to_fmt "Expected 3 arguments to `fintype.mk`"),
  msg ← lift $ pformat!"error in recursive call `eval_finset {args}`",
  trace_error msg.to_string $ eval_finset args
| e@`(finset.range %%en) := do
  n ← lift $ parse_nat en,
  eis ← lift $ (list.range n).mmap (λ i, expr.of_nat `(ℕ) i),
  eq ← lift $ mk_eq_refl e,
  let e'_list := eis.foldr (λ x xs, `(@list.cons ℕ %%x %%xs)) `(@list.nil ℕ),
  e' ← to_expr ``(finset.mk ↑%%e'_list (multiset.coe_nodup.mpr (list.nodup_range %%en))),
  pure (e', eq, eis)
| e := lift $ fail (to_fmt "Unknown finset expression" ++ format.line ++ to_fmt e)

@[to_additive]
lemma list.prod_cons_congr {α : Type*} [monoid α] (xs : list α) (x y z : α)
  (his : xs.prod = y) (hi : x * y = z) : (x :: xs).prod = z :=
by rw [list.prod_cons, his, hi]

/-
/-- Evaluate `list.prod %%xs`,
producing the evaluated expression and an equality proof. -/
meta def list.prove_prod (α : expr) : list expr → tactic (expr × expr)
| [] := do
  result ← expr.of_nat α 1,
  proof ← to_expr' ``(@list.prod_nil %%α _),
  pure (result, proof)
| (x :: xs) := do
  eval_xs ← list.prove_prod xs,
  xxs ← to_expr' ``(%%x * %%eval_xs.1),
  eval_xxs ← or_refl_conv norm_num.derive xxs,
  exs ← expr.of_list α xs,
  proof ← to_expr'
    ``(list.prod_cons_congr %%exs%%x %%eval_xs.1 %%eval_xxs.1 %%eval_xs.2 %%eval_xxs.2),
  pure (eval_xxs.1, proof)
-/

/-- Evaluate `list.sum %%xs`,
producing the evaluated expression and an equality proof. -/
meta def list.prove_sum {α : Type*}
  (eval_zero : eval_m (expr × expr × α)) (eval_add : expr × α → expr × α → eval_m (expr × expr × α))
  (M : expr) : list (expr × α) → eval_m (expr × expr × α)
| [] := do
  ⟨zero, _, zero_d⟩ ← eval_zero,
  proof ← to_expr ``(@list.sum_nil %%M _),
  pure ⟨zero, proof, zero_d⟩
| (x :: xs) := do
  ⟨sxs, sxs_pf, sxs_d⟩ ← list.prove_sum xs,
  ⟨sxxs, sxxs_pf, sxxs_d⟩ ← eval_add x (sxs, sxs_d),
  exs ← lift $ expr.of_list M (xs.map prod.fst),
  proof ← to_expr
    ``(list.sum_cons_congr %%exs %%x.1 %%sxs %%sxxs %%sxs_pf %%sxxs_pf),
  pure ⟨sxxs, proof, sxxs_d⟩

@[to_additive] lemma list.prod_congr {α : Type*} [monoid α] {xs xs' : list α} {z : α}
  (h₁ : xs = xs') (h₂ : xs'.prod = z) : xs.prod = z := by cc

@[to_additive] lemma multiset.prod_congr {α : Type*} [comm_monoid α]
  {xs : multiset α} {xs' : list α} {z : α}
  (h₁ : xs = (xs' : multiset α)) (h₂ : xs'.prod = z) : xs.prod = z :=
by rw [← h₂, ← multiset.coe_prod, h₁]

/-
/-- Evaluate `(%%xs.map (%%ef : %%α → %%β)).prod`,
producing the evaluated expression and an equality proof.
`eval_f : expr → tactic (expr × expr)` is a conversion procedure for simplifying expressions
of the form `(%%ef %%x), where `ef : expr` is the function to apply and `x : expr` is a list
element.
-/
meta def list.prove_prod_map (β ef : expr) (eval_f : converter)
  (xs : list expr) : state_t context tactic (expr × expr) := do
  (fxs, fxs_eq) ← eval_list_map ef eval_f xs,
  (prod, prod_eq) ← lift $ list.prove_prod β fxs,
  eq ← to_expr ``(list.prod_congr %%fxs_eq %%prod_eq),
  pure (prod, eq)
-/

/-- Evaluate `(%%xs.map (%%ef : %%α → %%β)).sum`,
producing the evaluated expression and an equality proof.
`eval_f : expr → tactic (expr × expr)` is a conversion procedure for simplifying expressions
of the form `(%%ef %%x), where `ef : expr` is the function to apply and `x : expr` is a list
element.
-/
meta def list.prove_sum_map (M ef : expr)
  {α β : Type*}
  (eval_zero : eval_m (expr × expr × α)) (eval_add : expr × α → expr × α → eval_m (expr × expr × α))
  (eval_f : expr × β → eval_m (expr × expr × α))
  (exs : expr) (xs : list β) : eval_m (expr × expr × α) :=
trace_error "internal error in prove_sum_map" $ do
  (fxs, fxs_eq) ← eval_list_map ef eval_f exs xs,
  (sum, sum_eq, sum_d) ← list.prove_sum eval_zero eval_add M fxs,
  eq ← to_expr ``(list.sum_congr %%fxs_eq %%sum_eq),
  pure (sum, eq, sum_d)

@[to_additive]
lemma finset.eval_prod_of_list {β α : Type*} [comm_monoid β]
  (s : finset α) (f : α → β) {is : list α} (his : is.nodup)
  (hs : finset.mk ↑is (multiset.coe_nodup.mpr his) = s)
  {x : β} (hx : (is.map f).prod = x) :
  s.prod f = x :=
by rw [← hs, finset.prod_mk, multiset.coe_map, multiset.coe_prod, hx]

meta def eval_finset_sum {α β : Type*} (eval_set : expr × unit → eval_m (expr × expr × list β))
  (eval_zero : eval_m (expr × expr × α)) (eval_add : expr × α → expr × α → eval_m (expr × expr × α))
  (eval_f : expr → expr × β → eval_m (expr × expr × α)) (eβ ef : expr) (es : expr) :
  eval_m (expr × expr × α) :=
trace_error "internal error in eval_finset_sum" $ do
  (es', list_eq, xs) ← eval_set (es, ()),
  match es' with
  | `(finset.mk (coe %%exs) %%nodup) := do
    (result, sum_eq, result_d) ← list.prove_sum_map eβ ef eval_zero eval_add (eval_f ef) exs xs,
    pf ← to_expr ``(finset.eval_sum_of_list %%es %%ef %%nodup %%list_eq %%sum_eq),
    pure (result, pf, result_d)
  | _ := do
    lift $ fail format!"eval_finset_sum: expected `finset.mk _ _`, received {es'}"
  end

/-- `eval_set` takes a `finset` expression and returns a tuple consisting of:
 * the normal form, of the form `finset.mk (↑bs) nodup`, where `is` is a sequence of `list.cons` and `list.nil`
 * the normalization proof
 * a list of extra information, one per term in `bs` -/
meta def norm_finset_sum {α β : Type*} (eval_set : expr × unit → eval_m (expr × expr × list β))
  (eval_zero : eval_m (expr × expr × α)) (eval_add : expr × α → expr × α → eval_m (expr × expr × α))
  (eval_f : expr → expr × β → eval_m (expr × expr × α)) : expr → eval_m (expr × expr × α)
| `(@finset.sum %%β %%α %%inst %%es %%ef) := eval_finset_sum eval_set eval_zero eval_add eval_f β ef es
| e := lift $ fail $ format! "norm_finset_sum: expected ∑ i in s, f i, got {e}"

/-
/-- `norm_num` plugin for evaluating big operators:
 * `list.prod`
 * `list.sum`
 * `multiset.prod`
 * `multiset.sum`
 * `finset.prod`
 * `finset.sum`
-/
meta def eval_big_operators : converter
| `(@list.prod %%α %%inst1 %%inst2 %%exs) :=
trace_error "Internal error in `tactic.norm_num.eval_big_operators`:" $ do
  (xs, list_eq) ← eval_list exs,
  (result, sum_eq) ← lift $ list.prove_prod α xs,
  pf ← to_expr ``(list.prod_congr %%list_eq %%sum_eq),
  pure (result, pf)
| `(@list.sum %%α %%inst1 %%inst2 %%exs) :=
trace_error "Internal error in `tactic.norm_num.eval_big_operators`:" $ do
  (xs, list_eq) ← eval_list exs,
  (result, sum_eq) ← list.prove_sum (converter.or_refl $ converter.lift norm_num.derive) α xs,
  pf ← to_expr ``(list.sum_congr %%list_eq %%sum_eq),
  pure (result, pf)
| `(@multiset.prod %%α %%inst %%exs) :=
trace_error "Internal error in `tactic.norm_num.eval_big_operators`:" $ do
  (xs, list_eq) ← eval_multiset exs,
  (result, sum_eq) ← lift $ list.prove_prod α xs,
  pf ← to_expr ``(multiset.prod_congr %%list_eq %%sum_eq),
  pure (result, pf)
| `(@multiset.sum %%α %%inst %%exs) :=
trace_error "Internal error in `tactic.norm_num.eval_big_operators`:" $ do
  (xs, list_eq) ← eval_multiset exs,
  (result, sum_eq) ← list.prove_sum (converter.or_refl $ converter.lift norm_num.derive) α xs,
  pf ← to_expr ``(multiset.sum_congr %%list_eq %%sum_eq),
  pure (result, pf)
| `(@finset.prod %%β %%α %%inst %%es %%ef) :=
trace_error "Internal error in `tactic.norm_num.eval_big_operators`:" $ do
  (xs, list_eq, nodup) ← lift $ eval_finset decide_eq es,
  (result, sum_eq) ← list.prove_prod_map β ef (converter.or_refl $ converter.lift norm_num.derive) xs,
  pf ← to_expr ``(finset.eval_prod_of_list %%es %%ef %%nodup %%list_eq %%sum_eq),
  pure (result, pf)
| `(@finset.sum %%β %%α %%inst %%es %%ef) :=
trace_error "Internal error in `tactic.norm_num.eval_big_operators`:" $ do
  (xs, list_eq, nodup) ← lift $ eval_finset decide_eq es,
  (result, sum_eq) ← list.prove_sum_map β ef (converter.or_refl $ converter.lift norm_num.derive) (converter.or_refl $ converter.lift norm_num.derive) xs,
  pf ← to_expr ``(finset.eval_sum_of_list %%es %%ef %%nodup %%list_eq %%sum_eq),
  pure (result, pf)
| _ := lift $ failed
-/

end tactic.norm_num

lemma eval_vec_cons_pf_zero {α : Type*} {n : ℕ} (x : α) (xs : fin n → α) :
  vec_cons x xs has_zero.zero = x := rfl
lemma eval_vec_cons_pf_succ {α : Type*} {n : ℕ} (i : fin n) (x y : α) (xs : fin n → α)
  (h : xs i = y) : vec_cons x xs (fin.succ i) = y :=
by rw [cons_val_succ, h]

/-- `eval_vec_cons n x xs` returns `(y, ⊢ vec_cons x xs n = y)` -/
meta def eval_vec_cons : ℕ → expr → expr → tactic (expr × expr)
| 0 x xs := do
  eq ← mk_app ``eval_vec_cons_pf_zero [x, xs],
  pure (x, eq)
| (n + 1) x' xxs@`(vec_cons %%x %%xs) := do
  (result, eq') ← eval_vec_cons n x xs,
  eq ← to_expr' ``(eval_vec_cons_pf_succ _ %%x' %%result %%xxs %%eq'),
  pure (result, eq)
| (n + 1) x xs := tactic.trace xs >> fail "Expected vector of the form `vec_cons x y`"

open tactic.norm_fin

@[norm_num]
meta def norm_vec_cons : expr → tactic (expr × expr)
| `(vec_cons %%x %%xs %%i) := i.to_nat >>= λ n, tactic.trace_error "Internal error in `norm_vec_cons`." $ do
  (y, pf) ← tactic.trace_error "" $ eval_vec_cons n x xs,
  pure (y, pf)
| e := pformat!"norm_vec_cons: expected `vec_cons x xs i`, got {e}" >>= fail

end matrix

/-- Simplify expressions of the form `(t : times_table).coord x k` using lemmas tagged
`@[times_table_simps]`. -/
-- @[norm_num]
meta def simp_times_table : converter
| e := do
  ctx ← get_context,
  (e', pf, _) ← state_t.lift $ simplify ctx.simps [] e <|>
    fail!"Failed to simplify {e}, are you missing a `@[times_table_simps]` lemma?",
  pure (e', pf)

protected lemma eval_vec_cons_pf {α ι : Type*} (t : ι → ι → ι → α) (i j k : ι)
  {ti : ι → ι → α} (ti_pf : t i = ti) {tij : ι → α} (tij_pf : ti j = tij) :
  t i j k = tij k :=
by rw [ti_pf, tij_pf]

meta def head_beta' (e : expr) : state_t context tactic expr :=
trace_error "error in head_beta" $ lift (head_beta e)

meta def conv_pexpr (conv : converter) (e : pexpr) : state_t context tactic (expr × expr) :=
lift (to_expr' e) >>= conv

meta def norm_cf : expr → state_t context tactic (expr × expr × ℚ)
| e := do
  (e', pf) ← converter.or_refl (converter.lift norm_num.derive) e,
  match e'.to_rat with
  | (some p) := pure (e', pf, p)
  | _ := failure
  end

meta def eval_add_cf : (expr × ℚ) → (expr × ℚ) → state_t context tactic (expr × expr × ℚ)
| (e₁, n₁) (e₂, n₂) := do
  (e', pf) ← conv_pexpr (converter.or_refl $ converter.lift norm_num.derive) ``(%%e₁ + %%e₂),
  pure (e', pf, n₁ + n₂)

meta def eval_neg_cf : (expr × ℚ) → state_t context tactic (expr × expr × ℚ)
| (e, n) := do
  (e', pf) ← conv_pexpr (converter.or_refl $ converter.lift norm_num.derive) ``(- %%e),
  pure (e', pf, -n)

meta def eval_mul_cf : (expr × ℚ) → (expr × ℚ) → state_t context tactic (expr × expr × ℚ)
| (e₁, n₁) (e₂, n₂) := do
  (e', pf) ← conv_pexpr (converter.or_refl $ converter.lift norm_num.derive) ``(%%e₁ * %%e₂),
  pure (e', pf, n₁ * n₂)

meta def eval_pow_cf : (expr × ℚ) → (expr × ℕ) → state_t context tactic (expr × expr × ℚ)
| (e₁, n₁) (e₂, n₂) := do
  (e', pf) ← conv_pexpr (converter.or_refl $ converter.lift norm_num.derive) ``(%%e₁ ^ %%e₂),
  pure (e', pf, n₁ ^ n₂)

meta instance : tactic.norm.ring.monad_ring (state_t context tactic) :=
⟨λ _, lift,
 λ _, failure,
 context.cache <$> state_t.get⟩

meta def eval_ring : evaluator unit (tactic.norm.ring.horner_expr ℚ)
| e := do
  (horner, pf) ← tactic.norm.ring.eval norm_cf eval_add_cf eval_neg_cf eval_mul_cf eval_pow_cf e.1,
  pure (horner.e, pf, horner)

meta def eval_ring_zero (M : expr) : eval_m (expr × expr × tactic.norm.ring.horner_expr ℚ) :=
do
  zero ← lift $ expr.of_nat M 0,
  pf ← lift $ mk_eq_refl zero,
  pure (zero, pf, tactic.norm.ring.horner_expr.const zero 0)

meta def eval_ring_one (M : expr) : eval_m (expr × expr × tactic.norm.ring.horner_expr ℚ) :=
do
  one ← lift $ expr.of_nat M 1,
  pf ← lift $ mk_eq_refl one,
  pure (one, pf, tactic.norm.ring.horner_expr.const one 1)

meta def eval_ring_add (l r : expr × tactic.norm.ring.horner_expr ℚ) :
  eval_m (expr × expr × tactic.norm.ring.horner_expr ℚ) := do
do
  (e', p') ← tactic.norm.ring.eval_add eval_add_cf l.2 r.2,
  return (e', p', e')

meta def eval_ring_mul (l r : expr × tactic.norm.ring.horner_expr ℚ) :
  eval_m (expr × expr × tactic.norm.ring.horner_expr ℚ) := do
do
  (e', p') ← tactic.norm.ring.eval_mul eval_add_cf eval_mul_cf l.2 r.2,
  return (e', p', e')

lemma unfold_sub {α} [add_group α] (a b b' c : α)
  (hb : -b = b') (h : a + b' = c) : a - b = c :=
by rw [sub_eq_add_neg, hb, h]

meta def eval_ring_sub (l r : expr × tactic.norm.ring.horner_expr ℚ) :
  eval_m (expr × expr × tactic.norm.ring.horner_expr ℚ) := do
do
  (r', r'_eq) ← tactic.norm.ring.eval_neg eval_neg_cf r.2,
  (e', p') ← tactic.norm.ring.eval_add eval_add_cf l.2 r',
  p ← to_expr ``(unfold_sub %%(l.2 : expr) %%(r.2 : expr) %%(r' : expr) %%(e' : expr) %%r'_eq %%p'),
  return (e', p, e')

meta def eval_ring_neg (e : expr × tactic.norm.ring.horner_expr ℚ) :
  eval_m (expr × expr × tactic.norm.ring.horner_expr ℚ) := do
do
  (e', p') ← tactic.norm.ring.eval_neg eval_neg_cf e.2,
  return (e', p', e')

meta def mk_cached_finset_univ (ι inst : expr) (ctx : context) : eval_m (expr × expr × list expr) :=
do
  `fintype.mk ← lift $ get_app_fn_const_whnf inst
    | lift $ fail (format!"Unknown fintype expression {inst}"),
  [_, args, _] ← lift $ get_app_args_whnf inst | lift $ fail (format!"Expected 3 arguments to `fintype.mk`"),
  result ← trace_error "eval_finset" $ tactic.norm_num.eval_finset tactic.norm_num.decide_eq args,
  state_t.put { coord_univ := ctx.coord_univ.insert ι result, .. ctx },
  pure result

meta def get_cached_finset_univ : expr × unit → eval_m (expr × expr × list expr)
| (`(@finset.univ %%ι %%inst), _) :=
  do ctx ← get_context,
    match ctx.coord_univ.find ι with
    | (some cu) := pure cu
    | none := mk_cached_finset_univ ι inst ctx
    end
| e := lift $ fail format!"get_cached_finset_univ: expected `(univ : finset _)`, got {e}"

meta def eq_rhs (e : expr) : tactic expr := do
  t ← infer_type e,
  match t with
  | `(_ = %%rhs) := pure rhs
  | _ := fail!"eq_rhs: expecting type of form `(_ = _), got {t}"
  end

/-- Evaluate expressions of the form `t.coord e₁ i * t.coord e₂ j * t.table i j k`.

`eval_coord` is a procedure for evaluating expression of the form `t.coord %%e %%i`.
This is passed as a separate parameter since Lean's support for mutual recursion is limited,
and we tie the recursive knot ourselves.
-/
meta def eval_mul_mul (ι R : expr)
  (eval_coord : expr → expr → eval_m (expr × expr × tactic.norm.ring.horner_expr ℚ)) :
  expr → eval_m (expr × expr × tactic.norm.ring.horner_expr ℚ)
| `(%%e₁i * %%e₂j * %%tableij) := trace_error "internal error in `eval_mul_mul`" $ do
  ι_sort ← lift $ infer_type ι,
  ι_level ← match ι_sort.match_sort with
  | (some ι_level) := pure ι_level
  | none := lift $ fail!"expecting (ι : Type), got ({ι} : {ι_sort})"
  end,

  -- Simplify and evaluate `t.coord e₁ i`
  (e₁i', e₁i_pf₁) ← simp_times_table.trans (converter.lift norm_vec_cons) e₁i,
  (e₁i', e₁i_pf₂, e₁i_expr) ← match e₁i' with
  | `(times_table.coord %%t %%e₁ %%i) := eval_coord e₁ i
  | _ := eval_ring (e₁i', ())
  end,
  e₁i_pf ← lift $ mk_eq_trans e₁i_pf₁ e₁i_pf₂,

  -- Simplify and evaluate `t.coord e₂ j`
  (e₂j', e₂j_pf₁) ← simp_times_table.trans (converter.lift norm_vec_cons) e₂j,
  (e₂j', e₂j_pf₂, e₂j_expr) ← match e₂j' with
  | `(times_table.coord %%t %%e₁ %%i) := eval_coord e₁ i
  | _ := eval_ring (e₂j', ())
  end,
  e₂j_pf ← lift $ mk_eq_trans e₂j_pf₁ e₂j_pf₂,

  -- Simplify and evaluate `t.table i j k`
  (tableij', tableij_pf₁) ← simp_times_table.trans (λ e, match e with
  | (expr.app (expr.app ti@(expr.app t i) j) k) := do
    (ti', ti_pf) ← lift $ norm_vec_cons ti,
    (tij', tij_pf) ← lift $ norm_vec_cons (expr.app ti' j),
    pf ← lift $ mk_app `tactic.times_table.eval_vec_cons_pf [R, ι, t, i, j, k, ti', ti_pf, tij', tij_pf],
    pure (expr.app tij' k, pf)
  | e := lift $ pformat!"expected `t.table i j k`, got {e}" >>= fail
  end) tableij,
  (tableij', tableij_pf₂, tableij_expr) ← eval_ring (tableij', ()),
  tableij_pf ← lift $ mk_eq_trans tableij_pf₁ tableij_pf₂,

  (e₁e₂, e₁e₂_pf, e₁e₂_expr) ← eval_ring_mul (e₁i', e₁i_expr) (e₂j', e₂j_expr),
  (e', e_pf, he') ← eval_ring_mul (e₁e₂, e₁e₂_expr) (tableij', tableij_expr),
  pf ← norm.ring.ic_lift (λ ic, do
    let n := `tactic.times_table.coord_repr_table,
    let l := [ι, e₁i, e₂j, tableij, e₁i', e₂j', tableij', e₁e₂, e', e₁i_pf, e₂j_pf, tableij_pf,
              e₁e₂_pf, e_pf],
    d ← get_decl n,
    (ic, l) ← ic.append_typeclasses d.type.binding_body l,
    return (ic, (expr.const n [ic.univ, ι_level]).mk_app (ic.α :: l))  ),
  pure (e', pf, he')
| e := lift $ pformat!"expected `t.coord e₁ i * t.coord e₂ j * t.table i j k`, got {e}" >>= fail

/-- Normalize `((t : times_table _ _ _).coord e) k` into Horner form. -/
protected meta def eval (ι R S t : expr) :
  expr → expr → eval_m (expr × expr × tactic.norm.ring.horner_expr ℚ)
| `(0) k := trace_error "zero" $ do
  e ← lift $ expr.of_nat R 0,
  pf ← to_expr ``(tactic.times_table.coord_zero %%t %%k),
  pure (e, pf, tactic.norm.ring.horner_expr.const e 0)
| `(bit0 %%e₁) k := trace_error "bit0" $ do
  (e₁', e₁_eq, he₁') ← eval e₁ k,
  (e', e_eq, he') ← eval_ring_add (e₁', he₁') (e₁', he₁'),
  eq ← to_expr ``(tactic.times_table.coord_bit0 %%t %%k %%e₁_eq %%e_eq),
  pure (e', eq, he')
| `(bit1 %%e₁) k := trace_error "bit1" $ do
  (e₁', e₁_eq, he₁') ← eval e₁ k,
  (one', one_eq, hone') ← (lift $ expr.of_nat S 1) >>= (λ e, eval e k),
  (e', e_eq, he') ← eval_ring_add (e₁', he₁') (e₁', he₁'),
  (e'', e'_eq, he'') ← eval_ring_add (e', he') (one', hone'),
  eq ← to_expr ``(tactic.times_table.coord_bit1 %%t %%k %%e₁_eq %%one_eq %%e_eq %%e'_eq),
  pure (e'', eq, he'')
| `(%%e₁ + %%e₂) k := trace_error "add" $ do
  (e₁', e₁_eq, he₁') ← eval e₁ k,
  (e₂', e₂_eq, he₂') ← eval e₂ k,
  (e', e_eq, he') ← eval_ring_add (e₁', he₁') (e₂', he₂'),
  eq ← to_expr ``(tactic.times_table.coord_add %%t %%k %%e₁_eq %%e₂_eq %%e_eq),
  pure (e', eq, he')
| `(%%e₁ - %%e₂) k := trace_error "sub" $ do
  (e₁', e₁_eq, he₁') ← eval e₁ k,
  (e₂', e₂_eq, he₂') ← eval e₂ k,
  (e', e_eq, he') ← eval_ring_sub (e₁', he₁') (e₂', he₂'),
  eq ← to_expr ``(tactic.times_table.coord_sub %%t %%k %%e₁_eq %%e₂_eq %%e_eq),
  pure (e', eq, he')
| `(-%%e₁) k := trace_error "neg" $ do
  (e₁', e₁_eq, he₁') ← eval e₁ k,
  (e', e_eq, he') ← eval_ring_neg (e₁', he₁'),
  eq ← to_expr ``(tactic.times_table.coord_neg %%t %%k %%e₁_eq %%e_eq),
  pure (e', eq, he')
| e@`(%%e₁ * %%e₂) k := trace_error "error in mul" $ do
  eq_sum_mul_times_table ← lift $ mk_app `times_table.unfold_mul [t, e₁, e₂, k],
  e ← lift $ eq_rhs eq_sum_mul_times_table,
  (e', e_eq, he') ← tactic.norm_num.norm_finset_sum get_cached_finset_univ (eval_ring_zero R) eval_ring_add -- evaluates the sum over i
    (λ f ⟨i, ei⟩, do
      term ← lift $ whnf (f i) transparency.reducible,
      tactic.norm_num.norm_finset_sum get_cached_finset_univ (eval_ring_zero R) eval_ring_add -- evaluates the sum over j
        (λ f ⟨j, _⟩, do
          term ← lift $ whnf (f j) transparency.reducible,
          eval_mul_mul ι R eval term)
        term)
    e,
  eq ← lift $ mk_eq_trans eq_sum_mul_times_table e_eq,
  pure (e', eq, he')
| `(%%e₁ ^ %%n) k := trace_error "pow" $ do
  match norm_num.match_numeral n with
  | norm_num.match_numeral_result.zero := do
    one ← lift $ expr.of_nat S 1,
    (one', one_eq, hone') ← eval one k,
    eq ← to_expr ``(tactic.times_table.eval_pow_zero %%t %%k %%e₁ %%one_eq),
    pure (one', eq, hone')
  | norm_num.match_numeral_result.one := do
    (e', e₁_eq, he') ← eval e₁ k,
    eq ← to_expr ``(tactic.times_table.eval_pow_one %%t %%k %%e₁_eq),
    pure (e', eq, he')
  | norm_num.match_numeral_result.bit0 b := do
    e₁' ← to_expr ``((%%e₁ ^ %%b) * (%%e₁ ^ %%b)),
    (e', e_eq, he') ← eval e₁' k,
    eq ← to_expr ``(tactic.times_table.eval_pow_bit0 %%t %%k %%b %%e_eq),
    pure (e', eq, he')
  | norm_num.match_numeral_result.bit1 b := do
    e₁' ← to_expr ``((%%e₁ ^ %%b) * (%%e₁ ^ %%b) * %%e₁),
    (e', e_eq, he') ← eval e₁' k,
    eq ← to_expr ``(tactic.times_table.eval_pow_bit1 %%t %%k %%b %%e_eq),
    pure (e', eq, he')

  | _ := lift $ tactic.fail "Expecting numeral in exponent"
  end
| e k := trace_error "times_table_simps" $ do
  full_e ← to_expr ``(times_table.coord %%t %%e %%k),
  (e', pr) ← simp_times_table full_e,
  (e'', pr', he'') ← eval_ring (e', ()),
  pf ← lift $ mk_eq_trans pr pr',
  pure (e'', pf, he'')

/--
`run_converter' atoms ek conv e` returns a `conv`-normalized form of `ek` = `f e`,
where `f` is some arbitrary function.

See also `run_converter` if you're running on only one subexpression.
-/
meta def run_converter' (atoms : ref (buffer expr)) (ek : expr) : converter → expr → tactic (expr × expr)
| conv e := do
  (simps, _) ← mk_simp_set tt [`times_table_simps]
    [simp_arg_type.expr ``(mul_zero), simp_arg_type.expr ``(zero_mul), simp_arg_type.expr ``(mul_one), simp_arg_type.expr ``(one_mul),
     simp_arg_type.expr ``(add_zero), simp_arg_type.expr ``(zero_add)],
  α ← infer_type ek,
  u ← mk_meta_univ,
  infer_type α >>= unify (expr.sort (level.succ u)),
  u ← get_univ_assignment u,
  ic ← mk_instance_cache α,
  (ic, c) ← ic.get ``comm_semiring,
  nc ← mk_instance_cache `(ℕ),
  using_new_ref ic $ λ r,
  using_new_ref nc $ λ nr,
    let cache : norm.ring.cache := ⟨α, u, c, transparency.semireducible, r, nr, atoms⟩ in do
    (result, _) ← (conv e).run { simps := simps, cache := cache, coord_univ := native.rb_map.mk _ _ },
    pure result

/--
`run_converter ek conv e` returns a `conv`-normalized form of `ek` = `f e`, where `f` is some arbitrary function.
-/
meta def run_converter (ek : expr) : converter → expr → tactic (expr × expr)
| conv e := using_new_ref mk_buffer $ λ atoms, run_converter' atoms ek conv e

set_option eqn_compiler.max_steps 4096

/-- Normalize expressions of the form `t.coord _`. -/
protected meta def norm_conv : converter
| ek@(expr.app (expr.app `(times_table.coord %%t) e) k) := do
  ι ← lift $ infer_type k,
  S ← lift $ infer_type e,
  R ← lift $ infer_type ek,
  (e', pf, he') ← trace_error "Internal error in `tactic.times_table.eval`:" $
    tactic.times_table.eval ι R S t e k,
  pf_ty ← lift $ infer_type pf,
  match pf_ty with
  | `(%%lhs = %%rhs) := do
    lift $ is_def_eq ek lhs <|> (trace "lhs does not match:" >> trace ek >> trace " ≠ " >> trace lhs),
    lift $ is_def_eq e' rhs <|> (trace "rhs does not match:" >> trace e' >> trace " ≠ " >> trace rhs)
  | _ := lift $ trace "Proof type is not an equality: " >> trace pf_ty
  end,
  pure (e', pf)
| _ := failure

/-- `norm_num` extension for expressions of the form `times_table.coord t _` -/
@[norm_num]
protected meta def norm : expr → tactic (expr × expr)
| ek@(expr.app (expr.app `(times_table.coord %%t) e) k) := do
  ι ← infer_type k,
  S ← infer_type e,
  R ← infer_type ek,
  (e', pf) ← tactic.trace_error "Internal error in `tactic.times_table.eval`:" $
    run_converter ek (λ e, tactic.times_table.eval ι R S t e k >>= λ eph, pure (eph.1, eph.2.1)) e,
  pf_ty ← infer_type pf,
  match pf_ty with
  | `(%%lhs = %%rhs) := do
    is_def_eq ek lhs <|> (trace "lhs does not match:" >> trace ek >> trace " ≠ " >> trace lhs),
    is_def_eq e' rhs <|> (trace "rhs does not match:" >> trace e' >> trace " ≠ " >> trace rhs)
  | _ := trace "Proof type is not an equality: " >> trace pf_ty
  end,
  pure (e', pf)
| _ := failure

meta def conv_subexpressions (step : expr → tactic (expr × expr)) (e : expr) : tactic (expr × expr) :=
do e ← instantiate_mvars e,
   (_, e', pr) ←
    ext_simplify_core () {} simp_lemmas.mk (λ _, trace "no discharger" >> failed) (λ _ _ _ _ _, failed)
      (λ _ _ _ _ e,
        do (new_e, pr) ← step e,
           guard (¬ new_e =ₐ e) <|> (trace "rewriting was idempotent: " >> trace e >> trace " → " >> trace new_e >> failure),
           return ((), new_e, some pr, tt))
      `eq e,
    return (e', pr)

end tactic.times_table

namespace tactic.interactive

open tactic

setup_tactic_parser

/-- Tactic for proving equalities of polynomial expressions in a finite extension of a base ring. -/
meta def times_table (red : parse (tk "!")?) : tactic unit :=
let transp := if red.is_some then semireducible else reducible in
do `(%%e₁ = %%e₂) ← target >>= instantiate_mvars,
  using_new_ref mk_buffer $ λ atoms, do
    (e₁', p₁) ← (tactic.times_table.run_converter' atoms e₁ tactic.times_table.norm_conv) e₁,
    (e₂', p₂) ← (tactic.times_table.run_converter' atoms e₂ tactic.times_table.norm_conv) e₂,
    is_def_eq e₁' e₂',
    p ← mk_eq_symm p₂ >>= mk_eq_trans p₁,
    tactic.exact p

end tactic.interactive


import mynat.definition
import mynat.add
import world8.level6
import world8.level9

namespace mynat

theorem add_right_eq_zero (a b : mynat) (h : a + b = 0) : a = 0 :=
begin [nat_num_game]
    cases a with d,
    {
        refl,
    },
    {
        exfalso,
        rw succ_add at h,
        apply succ_ne_zero (d + b),
        exact h,
    },
end

end mynat


import Mathlib.Algebra.Group.Defs
import Mathlib.Algebra.Order.Monoid.Lemmas
import Mathlib.Algebra.Order.Monoid.Canonical.Defs
import Mathlib.Algebra.Ring.Basic
import Mathlib.Data.Nat.Basic
import Mathlib.Data.Nat.Order.Basic
import Mathlib.Init.Algebra.Order
import Mathlib.Algebra.Ring.Basic
import Mathlib.Init.Data.Nat.Lemmas
import Mathlib.Util.WhatsNew -- TODO remove
import Mathlib.Tactic.LibrarySearch
import Mathlib.Tactic.NormCast
import Aesop

inductive Enat where
  | ofN : ℕ → Enat
  | top : Enat
deriving Repr, DecidableEq

notation "ℕ∪∞" => Enat
notation "∞" => Enat.top

namespace Enat

def succ : ℕ∪∞ → ℕ∪∞
  | ofN a => ofN (Nat.succ a)
  | ∞ => ∞

@[simp]
lemma succ_top : succ ∞ = ∞ := rfl

protected def add : ℕ∪∞ → ℕ∪∞ → ℕ∪∞
  | _, ∞ => ∞
  | ∞, _ => ∞
  | ofN a, ofN b => ofN (a + b)

instance : Add ℕ∪∞ where
  add := Enat.add

protected inductive le : ℕ∪∞ → ℕ∪∞ → Prop
  | in_nat {n m : Nat} : Nat.le n m → Enat.le (ofN n) (ofN m)
  | below_top          : Enat.le n ∞

instance : LE ℕ∪∞ where
  le := Enat.le

protected def lt (n m : ℕ∪∞) : Prop :=
  n ≠ ∞ ∧ Enat.le (succ n) m

instance : LT ℕ∪∞ where
  lt := Enat.lt

theorem succ_ofN (a : Nat) : succ (ofN a) = ofN a.succ := rfl

@[simp] theorem add_ofN (a b : Nat) : ofN a + ofN b = ofN (a + b) := rfl

@[simp] theorem add_top (a : ℕ∪∞) : a + ∞ = ∞ := match a with
  | top => rfl
  | ofN _ => rfl
@[simp] theorem top_add (a : ℕ∪∞) : ∞ + a = ∞ := match a with
  | top => rfl
  | ofN _ => rfl

protected theorem add_assoc (a b c : ℕ∪∞) : a + b + c = a + (b + c) := by
  cases a with
  | top => simp
  | ofN a => cases b with
    | top => simp
    | ofN b => cases c with
      | top => simp
      | ofN c => simp [Nat.add_assoc]

protected theorem add_zero (a : ℕ∪∞) : a + ofN 0 = a := by
  match a with
  | top => exact top_add (ofN 0)
  | ofN a => simp

protected theorem zero_add (a : ℕ∪∞) : ofN 0 + a = a := by
  match a with
  | top => exact add_top (ofN 0)
  | ofN a => simp

-- theorem nsmul_zero' (x : ℕ∪∞) : nsmul_rec 0 x = ofN 0 := by
--   simp [nsmul_rec]
--   rfl

-- theorem nsmul_succ' (n : ℕ) (x : ℕ∪∞) : nsmul_rec (Nat.succ n) x = x + nsmul_rec n x := by
--   induction n with
--   | zero =>
--     simp [nsmul_rec, nsmul_zero']
--   | succ n ih =>
--     simp [nsmul_rec]

protected theorem add_comm (a b : ℕ∪∞) : a + b = b + a := by
  cases a with
  | top => simp
  | ofN a => cases b with
    | top => simp
    | ofN b =>
      simp [add_ofN]
      exact Nat.add_comm a b

instance : AddMonoid ℕ∪∞ :=
{ add_assoc   := Enat.add_assoc,
  zero        := ofN Nat.zero,
  add_zero    := Enat.add_zero,
  zero_add    := Enat.zero_add }

instance : AddCommMonoid ℕ∪∞ :=
{ inferInstanceAs (AddMonoid Enat) with
  add_comm    := Enat.add_comm }

protected def one := ofN 1

instance : AddMonoidWithOne ℕ∪∞ :=
{ inferInstanceAs (AddMonoid Enat) with
  one    := Enat.one
  natCast := ofN
  natCast_zero := rfl
  natCast_succ := fun _ => rfl }

@[simp]
theorem succ_ofNat (a : Nat) : succ a = a.succ := rfl
@[simp]
theorem succ_zero : succ 0 = 1 := rfl

theorem add_ofNat (a b : Nat) : a + b = (↑(a + b) : Enat) := rfl

theorem ofN_inj : ofN m = ofN n ↔ m = n := ⟨ofN.inj, congrArg _⟩

@[simp, norm_cast]
lemma cast_eq_cast_iff_Nat (m n : ℕ) : (m : Enat) = (n : Enat) ↔ m = n := ofN_inj

@[simp]
lemma ofN_eq_ofNat : ofN a = a :=
rfl

-- set_option trace.Meta.Tactic.simp.rewrite true
theorem succ_add (a b : ℕ∪∞) : succ a + b = succ (a + b) := by
  cases a with
  | top => simp [succ]
  | ofN a => cases b with
    | top => simp [succ]
    | ofN b =>
      simp only [Enat.add, ofN_eq_ofNat]
      rw [succ_ofNat, add_ofNat, add_ofNat, succ_ofNat]
      rw [Nat.cast_add, Nat.cast_succ]
      norm_cast
      exact Nat.succ_add a b

theorem add_succ (a b : ℕ∪∞) : a + succ b = succ (a + b) := by
  rw [add_comm, succ_add b a, add_comm]

theorem ofN_mul_eq_smul (a b : ℕ) : (a * b : Enat) = a • (b : Enat) := by
induction a with
| zero => simp [zero_nsmul]
| succ k ih => simp [Nat.succ_mul, succ_nsmul, ← ih, add_comm]

theorem ofNat_mul_eq_smul (a b : ℕ) : (a * b : Enat) = a • (b : Enat) := by
induction a with
| zero => simp [zero_nsmul]
| succ k ih => simp [Nat.succ_mul, succ_nsmul, ← ih, add_comm]

protected theorem lt_top (n : ℕ) : n < ∞ := And.intro Enat.noConfusion le.below_top

protected theorem le_top (n : ℕ) : n ≤ ∞ := le.below_top

@[simp, norm_cast]
protected theorem le_iff_cast_le_cast {n m : ℕ} : (n : Enat) ≤ m ↔ n ≤ m := ⟨by
  intro h
  cases h
  assumption,
  le.in_nat⟩

theorem succ_pos (n : ℕ∪∞) : 0 < succ n :=
  match n with
  | ofN n =>
    .intro Enat.noConfusion (by rw [succ_ofN n]; exact le.in_nat (Nat.succ_le_succ (Nat.zero_le n)))
  | top => Enat.lt_top 0

protected theorem zero_le (n : ℕ∪∞) : 0 ≤ n := by
  cases n with
  | ofN n => exact le.in_nat (Nat.zero_le n)
  | top => exact le.below_top

protected theorem le_refl (n : ℕ∪∞) : n ≤ n := by
  cases n with
  | ofN n => exact le.in_nat (Nat.le_refl n)
  | top     => exact le.below_top

protected theorem le_trans {n m k : ℕ∪∞} : n ≤ m → m ≤ k → n ≤ k
  | le.in_nat h, le.in_nat h' => le.in_nat (Nat.le_trans h h')
  | _, le.below_top                 => le.below_top

theorem le_succ (n : ℕ∪∞) : n ≤ succ n := by
  cases n with
  | ofN n => exact le.in_nat (Nat.le_succ n)
  | top     => exact le.below_top

theorem le_of_succ_le {n m : ℕ∪∞} (h : succ n ≤ m) : n ≤ m :=
  Enat.le_trans (le_succ n) h

protected theorem le_of_lt {n m : ℕ∪∞} (h : n < m) : n ≤ m := by
  cases m with
  | ofN m =>
    cases n with
    | ofN n => exact le_of_succ_le h.right
    | top =>
      apply False.elim
      apply h.left
      rfl
  | top    => exact le.below_top

protected theorem lt_or_ge (n m : ℕ∪∞) : n < m ∨ n ≥ m := by
  cases n with
  | top     => exact Or.inr (le.below_top)
  | ofN n =>
    cases m with
    | top     => exact Or.inl (And.intro Enat.noConfusion le.below_top)
    | ofN m =>
      cases Nat.lt_or_ge n m with
      | inl h =>
        exact Or.inl (And.intro Enat.noConfusion (le.in_nat h))
      | inr h =>
        exact Or.inr (le.in_nat h)

protected theorem not_le_of_gt {n m : ℕ∪∞} (h : n > m) : ¬ n ≤ m := by
  cases m with
  | top     =>
    intro _
    apply h.left
    rfl
  | ofN m =>
    cases n with
    | top =>
      intro absurd
      cases absurd
    | ofN n =>
      intro nlem
      cases h.right with
      | in_nat nat_le =>
        apply Nat.not_le_of_gt nat_le
        cases nlem
        assumption

theorem gt_of_not_le {n m : ℕ∪∞} (h : ¬ n ≤ m) : n > m :=
  match Enat.lt_or_ge m n with
  | Or.inl h₁ => h₁
  | Or.inr h₁ => absurd h₁ h

protected lemma lt_iff_le_not_le {m n : ℕ∪∞} : m < n ↔ m ≤ n ∧ ¬ n ≤ m :=
⟨fun h => ⟨Enat.le_of_lt h, Enat.not_le_of_gt h⟩, fun h => gt_of_not_le h.2⟩

instance : Preorder ℕ∪∞ :=
{ le               := Enat.le,
  le_refl          := Enat.le_refl,
  le_trans         := @Enat.le_trans,
  lt_iff_le_not_le := @Enat.lt_iff_le_not_le,
  lt               := Enat.lt}

theorem le_add_right (n k : ℕ∪∞) : n ≤ n + k := by cases n with
  | top   => rw [top_add]
  | ofN n => cases k with
    | top   => rw [add_top]; exact le.below_top
    | ofN k => exact le.in_nat (Nat.le_add_right n k)

@[simp]
theorem succ_eq_add_one (a : Enat) : succ a = a + 1 :=
by
  cases a
  . simp
  . simp

theorem le_add_left (n k : ℕ∪∞) : n ≤ k + n := by
  rw [add_comm]
  exact le_add_right n k

protected
theorem add_le_add_left {n m : ℕ∪∞} (h : n ≤ m) (k : ℕ∪∞) : k + n ≤ k + m := by
  cases k with
  | top =>
    simp
  | ofN k => cases n with
    | top => exact le_trans h (le_add_left m (ofN k))
    | ofN n => cases m with
      | top =>
        simp
        exact le.below_top
      | ofN m =>
        simp
        apply le.in_nat
        cases h with
          | in_nat h => exact Nat.add_le_add_left h k

theorem eq_top_of_top_le (a : ℕ∪∞) (h : ∞ ≤ a) : a = ∞ := by
  cases h with
  | below_top => rfl

@[simp]
theorem top_le_iff_eq_top (a : ℕ∪∞) : ∞ ≤ a ↔ a = ∞ :=
Iff.intro (eq_top_of_top_le _) (fun h => by simp [h])

theorem eq_top_of_add_eq_top (a : ℕ∪∞) (n : ℕ) (h : a + n = ∞) : a = ∞ := by
  cases a with
  | top => rfl
  | ofN a => exact Enat.noConfusion h

protected theorem le_of_add_le_add_left {a : ℕ} {b c : ℕ∪∞} (h : a + b ≤ a + c) : b ≤ c :=
by
  cases b with
  | top =>
    simp only [add_comm, top_add, top_le_iff_eq_top] at h
    rw [eq_top_of_add_eq_top c a h]
  | ofN b => cases c with
    | top => exact le.below_top
    | ofN c =>
      apply le.in_nat
      apply @Nat.le_of_add_le_add_left a b
      cases h with
      | in_nat h' => exact h'

theorem succ_le_of_lt {n m : ℕ∪∞} (h : n < m) : succ n ≤ m := h.2

protected theorem le_antisymm {n m : ℕ∪∞} (h1 : n ≤ m) (h2 : m ≤ n) : n = m := by
  cases n with
  | top =>
    cases h1
    rfl
  | ofN n =>
    cases m with
    | top => cases h2
    | ofN m =>
      cases h1 with
      | in_nat h1 =>
        cases h2 with
        | in_nat h2 =>
          exact congrArg ofN (Nat.le_antisymm h1 h2)

protected theorem le_total (m n : ℕ∪∞) : m ≤ n ∨ n ≤ m :=
  match Enat.lt_or_ge m n with
  | Or.inl h => Or.inl (le_of_lt h)
  | Or.inr h => Or.inr h

@[simp]
lemma le_ofN (m n : Nat) : (m : Enat) ≤ n ↔ m ≤ n := by
  apply Iff.intro
  . intro h
    cases h
    assumption
  .  exact le.in_nat

@[simp]
theorem lt_ofN (m n : ℕ) : (m : Enat) < n ↔ m < n := by
  apply Iff.intro
  . intro h
    cases h.right
    assumption
  . intro h
    exact And.intro (Enat.noConfusion) (le.in_nat h)

lemma eq_ofN (m n : Nat) : m = n ↔ (m : Enat) = n := by
  apply Iff.intro
  . exact congrArg ofN
  . intro h
    cases h
    rfl

instance : DecidableRel ((. ≤ . ) : ℕ∪∞ → ℕ∪∞ → Prop) := fun n m =>
match n, m with
  | ofN b, ofN c =>
  decidable_of_decidable_of_iff (le_ofN b c).symm
  | _, ∞         => isTrue le.below_top
  | ∞, ofN a     => isFalse (fun h => by cases h)

-- instance : DecidableRel ((. = . ) : ℕ∪∞ → ℕ∪∞ → Prop) := fun n m =>
-- match n, m with
--   | ofN b, ofN c =>
--   decidable_of_decidable_of_iff (eq_ofN b c)
--   | ∞, ∞         => isTrue rfl
--   | ∞, ofN a     => isFalse (fun h => by cases h)
--   | ofN a, ∞     => isFalse (fun h => by cases h)

protected theorem eq_zero_or_pos : ∀ (n : ℕ∪∞), n = 0 ∨ n > 0
  | ofN 0   => Or.inl rfl
  | ofN (Nat.succ n) => by rw [←succ_ofN n]; exact Or.inr (succ_pos _)
  | ∞ => Or.inr (Enat.lt_top 0)

protected lemma pos_of_ne_zero {n : ℕ∪∞} : n ≠ 0 → 0 < n :=
Or.resolve_left (Enat.eq_zero_or_pos n)

protected theorem pos_iff_ne_zero (n : ℕ∪∞) : 0 < n ↔ n ≠ 0 :=
Iff.intro ne_of_gt Enat.pos_of_ne_zero

-- TODO  what is the right typeclass that does this?
protected lemma lt_add_right (a b c : ℕ∪∞) : a < b -> a < b + c :=
  fun h => lt_of_lt_of_le h (le_add_right _ _)

-- TODO if min max are left as underscores this becomes noncomputable, another code generator bug?
instance : LinearOrder ℕ∪∞ :=
{ Enat.instPreorderEnat with
  min := fun a b => if a ≤ b then a else b,
  max := fun a b => if a ≤ b then b else a,
  le_antisymm      := @Enat.le_antisymm,
  le_total         := @Enat.le_total,
  decidable_lt     := inferInstance, -- TODO check if these are actually better than the defaults
  decidable_le     := inferInstance,
  decidable_eq     := inferInstance }

@[simp, norm_cast]
protected theorem lt_iff_cast_lt_cast {n m : ℕ} : (n : Enat) < m ↔ n < m :=
by simp [lt_iff_le_and_ne]

theorem add_right_cancel_ofN (a : ℕ) (b c : ℕ∪∞) : b + a = c + a → b = c := by
  cases b with
  | top   => cases c with
    | top   => intro; rfl
    | ofN c =>
      rw [top_add]
      exact fun h => absurd h Enat.noConfusion
  | ofN b => cases c with
    | top   => exact fun h => absurd h Enat.noConfusion
    | ofN c =>
      simp only [ofN_eq_ofNat, cast_eq_cast_iff_Nat]
      norm_cast
      exact Nat.add_right_cancel

theorem add_left_inj_ofN (a : ℕ) {b c : ℕ∪∞} : b + a = c + a ↔ b = c :=
⟨add_right_cancel_ofN a b c, λ h => h ▸ rfl⟩

theorem lt_of_succ_le {n : ℕ} {m : ℕ∪∞} (h : succ n ≤ m) : n < m :=
And.intro Enat.noConfusion h

theorem lt_iff_succ_le {n : ℕ} {m : ℕ∪∞} : n < m ↔ succ n ≤ m :=
Iff.intro succ_le_of_lt lt_of_succ_le

-- TODO this should be automatically derivable
theorem enat_disjunction (a : ℕ∪∞) : a = ∞ ∨ ∃ n : ℕ, a = n :=
  match a with
  | top => Or.inl rfl
  | ofN n => Or.inr (Exists.intro n rfl)

def to_nat {a : ℕ∪∞} (h : a ≠ ∞) : ℕ := by
  cases a with
  | top => exact False.elim (h (Eq.refl ∞))
  | ofN n => exact n

@[simp]
lemma to_nat_ofN {a : ℕ} (h : (a : ℕ∪∞) ≠ ∞) : to_nat h = a := rfl

@[simp]
lemma ofN_to_nat_eq_self {a : ℕ∪∞} (h : a ≠ ∞) : to_nat h = a := by
  cases a with
  | top => exact False.elim (h (Eq.refl ∞))
  | ofN n => rfl

instance : CanonicallyOrderedAddMonoid ℕ∪∞ :=
{ Enat.instLinearOrderEnat with
  bot := 0
  bot_le := Enat.zero_le
  le_self_add := Enat.le_add_right
  exists_add_of_le := by
    intro a b h
    cases b
    case ofN b =>
      cases a
      case ofN a =>
        simp at h
        obtain ⟨c, hc⟩ := exists_add_of_le h
        use c
        simp
        exact_mod_cast hc
      case top =>
        simp at h
    case top =>
      use ∞
      simp
  add_le_add_left := fun _ _ h c => Enat.add_le_add_left h c }

protected def mul : ℕ∪∞ → ℕ∪∞ → ℕ∪∞
  | ofN a, ofN b => ofN (a * b)
  | 0, ∞ => 0
  | ∞, 0 => 0
  | _, ∞ => ∞
  | ∞, _ => ∞

instance : Mul ℕ∪∞ where
  mul := Enat.mul

@[simp]
protected lemma top_mul_top : ∞ * ∞ = ∞ := rfl
protected lemma top_mul_zero : ∞ * 0 = 0 := rfl
protected lemma zero_mul : 0 * (a : ℕ∪∞) = 0 := by
  cases a with | top => rfl | ofN a =>
    show ofN 0 * ofN a = ofN 0
    conv =>
      rhs
      rw [← zero_mul a]

protected lemma mul_coe (a b : ℕ) : (a : Enat) * (b : Enat) = ↑(a * b) :=
by cases a <;> cases b <;> rfl

protected theorem mul_comm (a b : ℕ∪∞) : a * b = b * a := by
  cases a with
  | top =>
  cases b with
    | top => simp
    | ofN b =>
      cases b
      rfl
      rfl
  | ofN a =>
  cases b with
    | top =>
      cases a
      rfl
      rfl
    | ofN b =>
      cases b <;> cases a <;>
      . show ofN (_ * _) = ofN (_ * _)
        rw [Nat.mul_comm]

protected lemma left_distrib (a b c : ℕ∪∞) : a * (b + c) = a * b + a * c :=
match a, b, c with
| ofN a, ofN b, ofN c => by
  simp only [ofN_eq_ofNat, Enat.mul_coe]
  norm_cast
  rw [Enat.mul_coe, left_distrib]
| ∞, ∞, ∞ => rfl
| ∞, ∞, ofN _ => by simp [Enat.mul]
| ∞, ofN _, ∞ => by simp
| ∞, ofN _, ofN 0 => by simp [Enat.top_mul_zero]
| ∞, ofN 0, ofN _ => by simp [Enat.top_mul_zero]
| ∞, ofN (_ + 1), (ofN (_ + 1)) => rfl
| (ofN 0), ∞, ∞ => by simp
| (ofN (_ + 1)), ∞, ∞ => rfl
| (ofN 0), ∞, (ofN 0) => by simp
| (ofN (_ + 1)), ∞, (ofN (_ + 1)) => rfl
| (ofN (0)), ∞, (ofN (_ + 1)) => by simp [Enat.zero_mul]
| (ofN (_ + 1)), ∞, (ofN _) => rfl
| (ofN 0), (ofN _), ∞ => by simp [Enat.zero_mul]
| (ofN (_ + 1)), (ofN _), ∞ => rfl

instance : CommSemiring ℕ∪∞ :=
{ Enat.instAddMonoidWithOneEnat with
  mul := Enat.mul
  add_comm := fun a b => AddCommSemigroup.add_comm a b

  zero_mul := fun a => by cases a with | top => rfl | ofN a =>
      show ofN 0 * ofN a = ofN 0
      conv =>
        rhs
        rw [← zero_mul a]

  mul_comm := fun a b => Enat.mul_comm a b

  mul_zero := fun a => by
      rw [Enat.mul_comm] -- TODO refer to other fields
      cases a with | top => rfl | ofN a =>
      show ofN 0 * ofN a = ofN 0
      conv =>
        rhs
        rw [← zero_mul a]

  one_mul := fun a => by cases a with
    | top => rfl
    | ofN a =>
      show ofN 1 * ofN a = ofN a
      conv =>
        rhs
        rw [← one_mul a]

  mul_one := fun a => by
    rw [Enat.mul_comm] -- TODO refer to other fields
    cases a with
    | top => rfl
    | ofN a =>
      show ofN 1 * ofN a = ofN a
      conv =>
        rhs
        rw [← one_mul a]

  left_distrib := Enat.left_distrib
  right_distrib := fun a b c =>
    by rw [Enat.mul_comm, Enat.left_distrib, Enat.mul_comm b, Enat.mul_comm c]
  mul_assoc := fun a b c => -- TODO this should be automatable
    match a, b, c with
    | ofN a, ofN b, ofN c => by
      simp only [ofN_eq_ofNat, Enat.mul_coe]
      rw [mul_assoc]
    | ∞, ∞, ∞ => rfl
    | ∞, ∞, ofN 0 => rfl
    | ∞, ∞, ofN (_ + 1) => rfl
    | ∞, (ofN 0), ∞ => rfl
    | ∞, (ofN (_ + 1)), ∞ => rfl
    | ∞, (ofN 0), (ofN 0) => rfl
    | ∞, (ofN (_ + 1)), (ofN 0) => rfl
    | ∞, (ofN 0), (ofN (_)) => by simp [Enat.top_mul_zero, Enat.zero_mul]
    | ∞, (ofN (_ + 1)), (ofN (_ + 1)) => rfl
    | (ofN 0), ∞, ∞ => rfl
    | (ofN (_ + 1)), ∞, ∞ => rfl
    | (ofN 0), ∞, (ofN 0) => rfl
    | (ofN (_ + 1)), ∞, (ofN (_ + 1)) => rfl
    | (ofN (0)), ∞, (ofN (_ + 1)) => by simp [Enat.zero_mul]
    | (ofN (_ + 1)), ∞, (ofN 0) => rfl
    | (ofN 0), (ofN _), ∞ => by simp [Enat.zero_mul]
    | (ofN (_ + 1)), (ofN 0), ∞ => rfl
    | (ofN (_ + 1)), (ofN (_ + 1)), ∞ => rfl }

@[simp]
lemma ofNatAtLeastTwoMulInfty {n : ℕ} (h : Nat.AtLeastTwo (m + 2)) :
  (@OfNat.ofNat _ _ (@instOfNat ℕ∪∞ _ Semiring.toNatCast h) : Enat) * ∞ = ∞ := rfl
@[simp]
lemma inftyMulofNatAtLeastTwo {n : ℕ} (h : Nat.AtLeastTwo (m + 2)) :
  ∞ * (@OfNat.ofNat _ _ (@instOfNat ℕ∪∞ _ Semiring.toNatCast h) : Enat) = ∞ := rfl

instance : CanonicallyOrderedCommSemiring ℕ∪∞ :=
{ Enat.instCommSemiringEnat, Enat.instCanonicallyOrderedAddMonoidEnat with
  eq_zero_or_eq_zero_of_mul_eq_zero := by
    intros a b h
    cases a with
    | top =>
    cases b with
      | top => simp at *
      | ofN b =>
        cases b
        simp at *
        simp [mul_add] at *
    | ofN a =>
    cases b with
      | top =>
        cases a
        simp [add_mul] at *
        simp [add_mul] at *
      | ofN b =>
        cases b <;> cases a <;>
        . simp [mul_add, add_mul] at * <;>
          aesop }
end Enat

-- TODO linter complains about autogenerated decls
-- #lint