/-
Copyright (c) 2022 Michael Stoll. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Michael Stoll
-/
import algebra.char_p.basic
import algebra.euclidean_domain.instances
import algebra.group.conj_finite

/-!
# Multiplicative characters of finite rings and fields

Let `R` and `R'` be a commutative rings.
A *multiplicative character* of `R` with values in `R'` is a morphism of
monoids from the multiplicative monoid of `R` into that of `R'`
that sends non-units to zero.

We use the namespace `mul_char` for the definitions and results.

## Main results

We show that the multiplicative characters form a group (if `R'` is commutative);
see `mul_char.comm_group`. We also provide an equivalence with the
homomorphisms `Rˣ →* R'ˣ`; see `mul_char.equiv_to_unit_hom`.

We define a multiplicative character to be *quadratic* if its values
are among `0`, `1` and `-1`, and we prove some properties of quadratic characters.

Finally, we show that the sum of all values of a nontrivial multiplicative
character vanishes; see `mul_char.is_nontrivial.sum_eq_zero`.

## Tags

multiplicative character
-/

section definition_and_group

/-!
### Definitions related to multiplicative characters

Even though the intended use is when domain and target of the characters
are commutative rings, we define them in the more general setting when
the domain is a commutative monoid and the target is a commutative monoid
with zero. (We need a zero in the target, since non-units are supposed
to map to zero.)

In this setting, there is an equivalence between multiplicative characters
`R → R'` and group homomorphisms `Rˣ → R'ˣ`, and the multiplicative characters
have a natural structure as a commutative group.
-/

universes u v

section defi

-- The domain of our multiplicative characters
variables (R : Type u) [comm_monoid R]
-- The target
variables (R' : Type v) [comm_monoid_with_zero R']

/-- Define a structure for multiplicative characters.
A multiplicative character from a commutative monoid `R` to a commutative monoid with zero `R'`
is a homomorphism of (multiplicative) monoids that sends non-units to zero. -/
structure mul_char extends monoid_hom R R' :=
(map_nonunit' : ∀ a : R, ¬ is_unit a → to_fun a = 0)

/-- This is the corresponding extension of `monoid_hom_class`. -/
class mul_char_class (F : Type*) (R R' : out_param $ Type*) [comm_monoid R]
 [comm_monoid_with_zero R']
  extends monoid_hom_class F R R' :=
(map_nonunit : ∀ (χ : F) {a : R} (ha : ¬ is_unit a), χ a = 0)

attribute [simp] mul_char_class.map_nonunit

end defi

section group

namespace mul_char

-- The domain of our multiplicative characters
variables {R : Type u} [comm_monoid R]
-- The target
variables {R' : Type v} [comm_monoid_with_zero R']

instance coe_to_fun : has_coe_to_fun (mul_char R R') (λ _, R → R') :=
⟨λ χ, χ.to_fun⟩

/-- See note [custom simps projection] -/
protected def simps.apply (χ : mul_char R R') : R → R' := χ
initialize_simps_projections mul_char (to_monoid_hom_to_fun → apply, -to_monoid_hom)

section trivial

variables (R R')

/-- The trivial multiplicative character. It takes the value `0` on non-units and
the value `1` on units. -/
@[simps]
noncomputable
def trivial : mul_char R R' :=
{ to_fun := by { classical, exact λ x, if is_unit x then 1 else 0 },
  map_nonunit' := by { intros a ha, simp only [ha, if_false], },
  map_one' := by simp only [is_unit_one, if_true],
  map_mul' := by { intros x y,
                   classical,
                   simp only [is_unit.mul_iff, boole_mul],
                   split_ifs; tauto, } }

end trivial

@[simp]
lemma coe_coe (χ : mul_char R R') : (χ.to_monoid_hom : R → R') = χ := rfl

@[simp]
lemma to_fun_eq_coe (χ : mul_char R R') : χ.to_fun = χ := rfl

@[simp]
lemma coe_mk (f : R →* R') (hf) : (mul_char.mk f hf : R → R') = f := rfl

/-- Extensionality. See `ext` below for the version that will actually be used. -/
lemma ext' {χ χ' : mul_char R R'} (h : ∀ a, χ a = χ' a) : χ = χ' :=
begin
  cases χ,
  cases χ',
  congr,
  exact monoid_hom.ext h,
end

instance : mul_char_class (mul_char R R') R R' :=
{ coe := λ χ, χ.to_monoid_hom.to_fun,
  coe_injective' := λ f g h, ext' (λ a, congr_fun h a),
  map_mul := λ χ, χ.map_mul',
  map_one := λ χ, χ.map_one',
  map_nonunit := λ χ, χ.map_nonunit', }

lemma map_nonunit (χ : mul_char R R') {a : R} (ha : ¬ is_unit a) : χ a = 0 :=
χ.map_nonunit' a ha

/-- Extensionality. Since `mul_char`s always take the value zero on non-units, it is sufficient
to compare the values on units. -/
@[ext]
lemma ext {χ χ' : mul_char R R'} (h : ∀ a : Rˣ, χ a = χ' a) : χ = χ' :=
begin
  apply ext',
  intro a,
  by_cases ha : is_unit a,
  { exact h ha.unit, },
  { rw [map_nonunit χ ha, map_nonunit χ' ha], },
end

lemma ext_iff {χ χ' : mul_char R R'} : χ = χ' ↔ ∀ a : Rˣ, χ a = χ' a :=
⟨by { rintro rfl a, refl }, ext⟩

/-!
### Equivalence of multiplicative characters with homomorphisms on units

We show that restriction / extension by zero gives an equivalence
between `mul_char R R'` and `Rˣ →* R'ˣ`.
-/

/-- Turn a `mul_char` into a homomorphism between the unit groups. -/
def to_unit_hom (χ : mul_char R R') : Rˣ →* R'ˣ := units.map χ

lemma coe_to_unit_hom (χ : mul_char R R') (a : Rˣ) :
  ↑(χ.to_unit_hom a) = χ a :=
rfl

/-- Turn a homomorphism between unit groups into a `mul_char`. -/
noncomputable
def of_unit_hom (f : Rˣ →* R'ˣ) : mul_char R R' :=
{ to_fun := by { classical, exact λ x, if hx : is_unit x then f hx.unit else 0 },
  map_one' := by { have h1 : (is_unit_one.unit : Rˣ) = 1 := units.eq_iff.mp rfl,
                   simp only [h1, dif_pos, units.coe_eq_one, map_one, is_unit_one], },
  map_mul' :=
  begin
    classical,
    intros x y,
    by_cases hx : is_unit x,
    { simp only [hx, is_unit.mul_iff, true_and, dif_pos],
      by_cases hy : is_unit y,
      { simp only [hy, dif_pos],
        have hm : (is_unit.mul_iff.mpr ⟨hx, hy⟩).unit = hx.unit * hy.unit := units.eq_iff.mp rfl,
        rw [hm, map_mul],
        norm_cast, },
      { simp only [hy, not_false_iff, dif_neg, mul_zero], }, },
    { simp only [hx, is_unit.mul_iff, false_and, not_false_iff, dif_neg, zero_mul], },
  end ,
  map_nonunit' := by { intros a ha, simp only [ha, not_false_iff, dif_neg], }, }

lemma of_unit_hom_coe (f : Rˣ →* R'ˣ) (a : Rˣ) :
  of_unit_hom f ↑a = f a :=
by simp [of_unit_hom]

/-- The equivalence between multiplicative characters and homomorphisms of unit groups. -/
noncomputable
def equiv_to_unit_hom : mul_char R R' ≃ (Rˣ →* R'ˣ) :=
{ to_fun := to_unit_hom,
  inv_fun := of_unit_hom,
  left_inv :=
  by { intro χ, ext x, rw [of_unit_hom_coe, coe_to_unit_hom] },
  right_inv :=
  by { intro f, ext x, rw [coe_to_unit_hom, of_unit_hom_coe], } }

@[simp]
lemma to_unit_hom_eq (χ : mul_char R R') : to_unit_hom χ = equiv_to_unit_hom χ := rfl

@[simp]
lemma of_unit_hom_eq (χ : Rˣ →* R'ˣ) : of_unit_hom χ = equiv_to_unit_hom.symm χ := rfl

@[simp]
lemma coe_equiv_to_unit_hom (χ : mul_char R R') (a : Rˣ) :
  ↑(equiv_to_unit_hom χ a) = χ a :=
coe_to_unit_hom χ a

@[simp]
lemma equiv_unit_hom_symm_coe (f : Rˣ →* R'ˣ) (a : Rˣ) :
  equiv_to_unit_hom.symm f ↑a = f a :=
of_unit_hom_coe f a

/-!
### Commutative group structure on multiplicative characters

The multiplicative characters `R → R'` form a commutative group.
-/

protected
lemma map_one (χ : mul_char R R') : χ (1 : R) = 1 :=
χ.map_one'

/-- If the domain has a zero (and is nontrivial), then `χ 0 = 0`. -/
protected
lemma map_zero {R : Type u} [comm_monoid_with_zero R] [nontrivial R] (χ : mul_char R R') :
  χ (0 : R) = 0 :=
by rw [map_nonunit χ not_is_unit_zero]

/-- If the domain is a ring `R`, then `χ (ring_char R) = 0`. -/
lemma map_ring_char {R : Type u} [comm_ring R] [nontrivial R] (χ : mul_char R R') :
  χ (ring_char R) = 0 :=
by rw [ring_char.nat.cast_ring_char, χ.map_zero]

noncomputable
instance has_one : has_one (mul_char R R') := ⟨trivial R R'⟩

noncomputable
instance inhabited : inhabited (mul_char R R') := ⟨1⟩

/-- Evaluation of the trivial character -/
@[simp]
lemma one_apply_coe (a : Rˣ) : (1 : mul_char R R') a = 1 :=
by { classical, exact dif_pos a.is_unit }

/-- Multiplication of multiplicative characters. (This needs the target to be commutative.) -/
def mul (χ χ' : mul_char R R') : mul_char R R' :=
{ to_fun := χ * χ',
  map_nonunit' := λ a ha, by simp [map_nonunit χ ha],
  ..χ.to_monoid_hom * χ'.to_monoid_hom }

instance has_mul : has_mul (mul_char R R') := ⟨mul⟩

lemma mul_apply (χ χ' : mul_char R R') (a : R) : (χ * χ') a = χ a * χ' a := rfl

@[simp]

protected
lemma one_mul (χ : mul_char R R') : (1 : mul_char R R') * χ = χ := by { ext, simp }

protected
lemma mul_one (χ : mul_char R R') : χ * 1 = χ := by { ext, simp }

/-- The inverse of a multiplicative character. We define it as `inverse ∘ χ`. -/
noncomputable
def inv (χ : mul_char R R') : mul_char R R' :=
{ to_fun := λ a, monoid_with_zero.inverse (χ a),
  map_nonunit' := λ a ha, by simp [map_nonunit _ ha],
  ..monoid_with_zero.inverse.to_monoid_hom.comp χ.to_monoid_hom }

noncomputable
instance has_inv : has_inv (mul_char R R') := ⟨inv⟩

/-- The inverse of a multiplicative character `χ`, applied to `a`, is the inverse of `χ a`. -/
lemma inv_apply_eq_inv (χ : mul_char R R') (a : R) :
  χ⁻¹ a = ring.inverse (χ a) :=
eq.refl $ inv χ a

/-- The inverse of a multiplicative character `χ`, applied to `a`, is the inverse of `χ a`.
Variant when the target is a field -/
lemma inv_apply_eq_inv' {R' : Type v} [field R'] (χ : mul_char R R') (a : R) :
  χ⁻¹ a = (χ a)⁻¹ :=
(inv_apply_eq_inv χ a).trans $ ring.inverse_eq_inv (χ a)

/-- When the domain has a zero, then the inverse of a multiplicative character `χ`,
applied to `a`, is `χ` applied to the inverse of `a`. -/
lemma inv_apply {R : Type u} [comm_monoid_with_zero R] (χ : mul_char R R') (a : R) :
  χ⁻¹ a = χ (ring.inverse a) :=
begin
  by_cases ha : is_unit a,
  { rw [inv_apply_eq_inv],
    have h := is_unit.map χ ha,
    apply_fun ((*) (χ a)) using is_unit.mul_right_injective h,
    rw [ring.mul_inverse_cancel _ h, ← map_mul, ring.mul_inverse_cancel _ ha, mul_char.map_one], },
  { revert ha, nontriviality R, intro ha, -- `nontriviality R` by itself doesn't do it
    rw [map_nonunit _ ha, ring.inverse_non_unit a ha, mul_char.map_zero χ], },
end

/-- When the domain has a zero, then the inverse of a multiplicative character `χ`,
applied to `a`, is `χ` applied to the inverse of `a`. -/
lemma inv_apply' {R : Type u} [field R] (χ : mul_char R R') (a : R) : χ⁻¹ a = χ a⁻¹ :=
(inv_apply χ a).trans $ congr_arg _ (ring.inverse_eq_inv a)

/-- The product of a character with its inverse is the trivial character. -/
@[simp]
lemma inv_mul (χ : mul_char R R') : χ⁻¹ * χ = 1 :=
begin
  ext x,
  rw [coe_to_fun_mul, pi.mul_apply, inv_apply_eq_inv,
      ring.inverse_mul_cancel _ (is_unit.map _ x.is_unit), one_apply_coe],
end

/-- The commutative group structure on `mul_char R R'`. -/
noncomputable
instance comm_group : comm_group (mul_char R R') :=
{ one := 1,
  mul := (*),
  inv := has_inv.inv,
  mul_left_inv := inv_mul,
  mul_assoc := by { intros χ₁ χ₂ χ₃, ext a, simp [mul_assoc], },
  mul_comm := by { intros χ₁ χ₂, ext a, simp [mul_comm], },
  one_mul := one_mul,
  mul_one := mul_one, }

/-- If `a` is a unit and `n : ℕ`, then `(χ ^ n) a = (χ a) ^ n`. -/
lemma pow_apply_coe (χ : mul_char R R') (n : ℕ) (a : Rˣ) :
  (χ ^ n) a = (χ a) ^ n :=
begin
  induction n with n ih,
  { rw [pow_zero, pow_zero, one_apply_coe], },
  { rw [pow_succ, pow_succ, mul_apply, ih], },
end

/-- If `n` is positive, then `(χ ^ n) a = (χ a) ^ n`. -/
lemma pow_apply' (χ : mul_char R R') {n : ℕ} (hn : 0 < n) (a : R) :
  (χ ^ n) a = (χ a) ^ n :=
begin
  by_cases ha : is_unit a,
  { exact pow_apply_coe χ n ha.unit, },
  { rw [map_nonunit (χ ^ n) ha, map_nonunit χ ha, zero_pow hn], },
end

end mul_char

end group

end definition_and_group

/-!
### Properties of multiplicative characters

We introduce the properties of being nontrivial or quadratic and prove
some basic facts about them.

We now assume that domain and target are commutative rings.
-/

section properties

namespace mul_char

universes u v w

variables {R : Type u} [comm_ring R] {R' : Type v} [comm_ring R'] {R'' : Type w} [comm_ring R'']

/-- A multiplicative character is *nontrivial* if it takes a value `≠ 1` on a unit. -/
def is_nontrivial (χ : mul_char R R') : Prop := ∃ a : Rˣ, χ a ≠ 1

/-- A multiplicative character is nontrivial iff it is not the trivial character. -/
lemma is_nontrivial_iff (χ : mul_char R R') : χ.is_nontrivial ↔ χ ≠ 1 :=
by simp only [is_nontrivial, ne.def, ext_iff, not_forall, one_apply_coe]

/-- A multiplicative character is *quadratic* if it takes only the values `0`, `1`, `-1`. -/
def is_quadratic (χ : mul_char R R') : Prop := ∀ a, χ a = 0 ∨ χ a = 1 ∨ χ a = -1

/-- If two values of quadratic characters with target `ℤ` agree after coercion into a ring
of characteristic not `2`, then they agree in `ℤ`. -/
lemma is_quadratic.eq_of_eq_coe {χ : mul_char R ℤ} (hχ : is_quadratic χ)
  {χ' : mul_char R' ℤ} (hχ' : is_quadratic χ') [nontrivial R''] (hR'' : ring_char R'' ≠ 2)
  {a : R} {a' : R'} (h : (χ a : R'') = χ' a') :
  χ a = χ' a' :=
int.cast_inj_on_of_ring_char_ne_two hR'' (hχ a) (hχ' a') h

/-- We can post-compose a multiplicative character with a ring homomorphism. -/
@[simps]
def ring_hom_comp (χ : mul_char R R') (f : R' →+* R'') : mul_char R R'' :=
{ to_fun := λ a, f (χ a),
  map_nonunit' := λ a ha, by simp only [map_nonunit χ ha, map_zero],
  ..f.to_monoid_hom.comp χ.to_monoid_hom }

/-- Composition with an injective ring homomorphism preserves nontriviality. -/
lemma is_nontrivial.comp {χ : mul_char R R'} (hχ : χ.is_nontrivial)
 {f : R' →+* R''} (hf : function.injective f) :
  (χ.ring_hom_comp f).is_nontrivial :=
begin
  obtain ⟨a, ha⟩ := hχ,
  use a,
  rw [ring_hom_comp_apply, ← ring_hom.map_one f],
  exact λ h, ha (hf h),
end

/-- Composition with a ring homomorphism preserves the property of being a quadratic character. -/
lemma is_quadratic.comp {χ : mul_char R R'} (hχ : χ.is_quadratic) (f : R' →+* R'') :
  (χ.ring_hom_comp f).is_quadratic :=
begin
  intro a,
  rcases hχ a with (ha | ha | ha);
    simp [ha],
end

/-- The inverse of a quadratic character is itself. →  -/
lemma is_quadratic.inv {χ : mul_char R R'} (hχ : χ.is_quadratic) : χ⁻¹ = χ :=
begin
  ext x,
  rw [inv_apply_eq_inv],
  rcases hχ x with h₀ | h₁ | h₂,
  { rw [h₀, ring.inverse_zero], },
  { rw [h₁, ring.inverse_one], },
  { rw [h₂, (by norm_cast : (-1 : R') = (-1 : R'ˣ)), ring.inverse_unit (-1 : R'ˣ)],
    refl, },
end

/-- The square of a quadratic character is the trivial character. -/
lemma is_quadratic.sq_eq_one {χ : mul_char R R'} (hχ : χ.is_quadratic) : χ ^ 2 = 1 :=
begin
  convert mul_left_inv _,
  rw [pow_two, hχ.inv],
end

/-- The `p`th power of a quadratic character is itself, when `p` is the (prime) characteristic
of the target ring. -/
lemma is_quadratic.pow_char {χ : mul_char R R'} (hχ : χ.is_quadratic)
 (p : ℕ) [hp : fact p.prime] [char_p R' p] :
  χ ^ p = χ :=
begin
  ext x,
  rw [pow_apply_coe],
  rcases hχ x with (hx | hx | hx); rw hx,
  { rw [zero_pow (fact.out p.prime).pos], },
  { rw [one_pow], },
  { exact char_p.neg_one_pow_char R' p, },
end

/-- The `n`th power of a quadratic character is the trivial character, when `n` is even. -/
lemma is_quadratic.pow_even {χ : mul_char R R'} (hχ : χ.is_quadratic) {n : ℕ} (hn : even n) :
  χ ^ n = 1 :=
begin
  obtain ⟨n, rfl⟩ := even_iff_two_dvd.mp hn,
  rw [pow_mul, hχ.sq_eq_one, one_pow]
end

/-- The `n`th power of a quadratic character is itself, when `n` is odd. -/
lemma is_quadratic.pow_odd {χ : mul_char R R'} (hχ : χ.is_quadratic) {n : ℕ} (hn : odd n) :
  χ ^ n = χ :=
begin
  obtain ⟨n, rfl⟩ := hn,
  rw [pow_add, pow_one, hχ.pow_even (even_two_mul _), one_mul]
end

open_locale big_operators

/-- The sum over all values of a nontrivial multiplicative character on a finite ring is zero
(when the target is a domain). -/
lemma is_nontrivial.sum_eq_zero [fintype R] [is_domain R'] {χ : mul_char R R'}
 (hχ : χ.is_nontrivial) :
  ∑ a, χ a = 0 :=
begin
  rcases hχ with ⟨b, hb⟩,
  refine eq_zero_of_mul_eq_self_left hb _,
  simp only [finset.mul_sum, ← map_mul],
  exact fintype.sum_bijective _ (units.mul_left_bijective b) _ _ (λ x, rfl)
end

/-- The sum over all values of the trivial multiplicative character on a finite ring is
the cardinality of its unit group. -/
lemma sum_one_eq_card_units [fintype R] [decidable_eq R] :
  ∑ a, (1 : mul_char R R') a = fintype.card Rˣ :=
begin
  calc ∑ a, (1 : mul_char R R') a
      = ∑ a : R, if is_unit a then 1 else 0 : finset.sum_congr rfl (λ a _, _)
  ... = ((finset.univ : finset R).filter is_unit).card : finset.sum_boole
  ... = (finset.univ.map (⟨(coe : Rˣ → R), units.ext⟩)).card : _
  ... = fintype.card Rˣ : congr_arg _ (finset.card_map _),
  { split_ifs with h h,
    { exact one_apply_coe h.unit },
    { exact map_nonunit _ h } },
  { congr,
    ext a,
    simp only [finset.mem_filter, finset.mem_univ, true_and, finset.mem_map,
               function.embedding.coe_fn_mk, exists_true_left, is_unit], },
end

end mul_char

end properties


/-
Copyright (c) 2014 Floris van Doorn (c) 2016 Microsoft Corporation. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Floris van Doorn, Leonardo de Moura, Jeremy Avigad, Mario Carneiro
-/

/- excerpt of https://github.com/leanprover-community/mathlib/blob/fee93e961d7b74a4b0ce9e454b8a960e48acc3b2/src/data/nat/basic.lean -/
namespace nat

@[simp] lemma one_mod (n : ℕ) : 1 % (n + 2) = 1 := nat.mod_eq_of_lt (add_lt_add_right n.succ_pos 1)

@[simp] theorem mod_add_mod (m n k : ℕ) : (m % n + k) % n = (m + k) % n :=
by have := (add_mul_mod_self_left (m % n + k) n (m / n)).symm;
   rwa [add_right_comm, mod_add_div] at this

@[simp] theorem add_mod_mod (m n k : ℕ) : (m + n % k) % k = (m + n) % k :=
by rw [add_comm, mod_add_mod, add_comm]

end nat


/-
Copyright (c) 2016 Jeremy Avigad. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Jeremy Avigad

The integers, with addition, multiplication, and subtraction.
-/
import Mathlib.Mathport.Rename
import Mathlib.Init.Data.Nat.Notation
import Mathlib.Init.ZeroOne
import Std.Data.Int.Lemmas

open Nat

-- TODO: backport?
#align int.neg_succ_of_nat Int.negSucc

-- @[inherit_doc]
notation "ℤ" => Int

namespace Int

/-- The number `0 : ℤ`, as a standalone definition. -/
@[deprecated] protected def zero : ℤ := ofNat 0

/-- The number `1 : ℤ`, as a standalone definition. -/
@[deprecated] protected def one : ℤ := ofNat 1

#align int.of_nat_zero Int.ofNat_zero
#align int.of_nat_one Int.ofNat_one
#align int.sub_nat_nat_of_sub_eq_zero Int.subNatNat_of_sub_eq_zero
#align int.sub_nat_nat_of_sub_eq_succ Int.subNatNat_of_sub_eq_succ
#align int.of_nat_add Int.ofNat_add
#align int.of_nat_mul Int.ofNat_mul
#align int.of_nat_succ Int.ofNat_succ
#align int.neg_of_nat_of_succ Int.neg_ofNat_succ
#align int.neg_neg_of_nat_succ Int.neg_negSucc

#align int.of_nat_eq_coe Int.ofNat_eq_coe

#align int.neg_succ_of_nat_coe Int.negSucc_coe
#align int.coe_nat_add Int.ofNat_add
#align int.coe_nat_mul Int.ofNat_mul
#align int.coe_nat_zero Int.ofNat_zero
#align int.coe_nat_one Int.ofNat_one
#align int.coe_nat_succ Int.ofNat_succ

protected theorem ofNat_add_out (m n : ℕ) : ↑m + ↑n = (↑(m + n) : ℤ) := rfl
#align int.coe_nat_add_out Int.ofNat_add_out

protected theorem ofNat_mul_out (m n : ℕ) : ↑m * ↑n = (↑(m * n) : ℤ) := rfl
#align int.coe_nat_mul_out Int.ofNat_mul_out

protected theorem ofNat_add_one_out (n : ℕ) : ↑n + (1 : ℤ) = ↑(succ n) := rfl
#align int.coe_nat_add_one_out Int.ofNat_add_one_out

#align int.of_nat_add_of_nat Int.ofNat_add_ofNat

#align int.of_nat_add_neg_succ_of_nat Int.ofNat_add_negSucc
#align int.neg_succ_of_nat_add_of_nat Int.negSucc_add_ofNat
#align int.neg_succ_of_nat_add_neg_succ_of_nat Int.negSucc_add_negSucc
#align int.of_nat_mul_of_nat Int.ofNat_mul_ofNat
#align int.of_nat_mul_neg_succ_of_nat Int.ofNat_mul_negSucc'
#align int.neg_succ_of_nat_of_nat Int.negSucc_mul_ofNat'
#align int.mul_neg_succ_of_nat_neg_succ_of_nat Int.negSucc_mul_negSucc'

#align int.coe_nat_inj Int.ofNat.inj
#align int.of_nat_eq_of_nat_iff Int.ofNat_inj
#align int.coe_nat_eq_coe_nat_iff Int.ofNat_inj
#align int.neg_succ_of_nat_inj_iff Int.negSucc_inj
#align int.neg_succ_of_nat_eq Int.negSucc_eq

protected theorem neg_eq_neg {a b : ℤ} (h : -a = -b) : a = b := Int.neg_inj.1 h
#align int.neg_inj Int.neg_eq_neg

#align int.sub_nat_nat_elim Int.subNatNat_elim
#align int.sub_nat_nat_add_left Int.subNatNat_add_left
#align int.sub_nat_nat_add_right Int.subNatNat_add_right
#align int.sub_nat_nat_add_add Int.subNatNat_add_add
#align int.sub_nat_nat_of_le Int.subNatNat_of_le
#align int.sub_nat_nat_of_lt Int.subNatNat_of_lt
#align int.nat_abs_of_nat Int.natAbs_ofNat

#align int.nat_abs Int.natAbs

@[deprecated natAbs_eq_zero]
theorem eq_zero_of_natAbs_eq_zero : ∀ {a : ℤ}, natAbs a = 0 → a = 0 := natAbs_eq_zero.1
#align int.eq_zero_of_nat_abs_eq_zero Int.eq_zero_of_natAbs_eq_zero

@[deprecated natAbs_pos]
theorem natAbs_pos_of_ne_zero {a : ℤ} (h : a ≠ 0) : 0 < natAbs a := natAbs_pos.2 h
#align int.nat_abs_pos_of_ne_zero Int.natAbs_pos_of_ne_zero

#align int.nat_abs_zero Int.natAbs_zero
#align int.nat_abs_one Int.natAbs_one
#align int.nat_abs_mul_self Int.natAbs_mul_self
#align int.nat_abs_neg Int.natAbs_neg
#align int.nat_abs_eq Int.natAbs_eq
#align int.eq_coe_or_neg Int.eq_nat_or_neg

#align int.div Int.ediv
#align int.mod Int.emod
#align int.quot Int.div
#align int.rem Int.mod

#align int.sub_nat_nat_sub Int.subNatNat_subₓ -- reordered implicits
#align int.sub_nat_nat_add Int.subNatNat_add
#align int.sub_nat_nat_add_neg_succ_of_nat Int.subNatNat_add_negSucc

#align int.add_assoc_aux1 Int.add_assoc.aux1
#align int.add_assoc_aux2 Int.add_assoc.aux2

#align int.sub_nat_self Int.subNatNat_self

#align int.of_nat_mul_neg_of_nat Int.ofNat_mul_negOfNat
#align int.neg_of_nat_mul_of_nat Int.negOfNat_mul_ofNat
#align int.neg_succ_of_nat_mul_neg_of_nat Int.negSucc_mul_negOfNat
#align int.neg_of_nat_mul_neg_succ_of_nat Int.negOfNat_mul_negSucc
#align int.neg_of_nat_eq_sub_nat_nat_zero Int.negOfNat_eq_subNatNat_zero
#align int.of_nat_mul_sub_nat_nat Int.ofNat_mul_subNatNat
#align int.neg_of_nat_add Int.negOfNat_add
#align int.neg_succ_of_nat_mul_sub_nat_nat Int.negSucc_mul_subNatNat
#align int.distrib_left Int.mul_add
#align int.distrib_right Int.add_mul
#align int.of_nat_sub Int.ofNat_subₓ -- reordered implicits
#align int.neg_succ_of_nat_coe' Int.negSucc_coe'
#align int.coe_nat_sub Int.ofNat_sub
#align int.sub_nat_nat_eq_coe Int.subNatNat_eq_coe
#align int.to_nat_sub Int.toNat_sub

/-- The modulus of an integer by another as a natural. Uses the E-rounding convention. -/
def natMod (m n : ℤ) : ℕ := (m % n).toNat
#align int.nat_mod Int.natMod

#align int.sign_mul_nat_abs Int.sign_mul_natAbs

#align int.to_nat' Int.toNat'


import tactic.default .tactic .basic
universes u v w

namespace two_three

variables (α : Type u) (β : Type v) {γ : Type w}

open tree nat

variables {α β}

inductive liftp (p : α → Prop) : tree α β → Prop
| leaf {k v} : p k → liftp (tree.leaf k v)
| node2 {x} {t₀ t₁} : p x → liftp t₀ → liftp t₁ → liftp (tree.node2 t₀ x t₁)
| node3 {x y} {t₀ t₁ t₂} : p x → p y → liftp t₀ → liftp t₁ → liftp t₂ → liftp (tree.node3 t₀ x t₁ y t₂)
-- | node4 {x y z} {t₀ t₁ t₂ t₃} :
--   p x → p y → p z →
--   liftp t₀ → liftp t₁ →
--   liftp t₂ → liftp t₃ →
--   liftp (tree.node4 t₀ x t₁ y t₂ z t₃)

lemma liftp_true {t : tree α β} : liftp (λ _, true) t :=
begin
  induction t; repeat { trivial <|> assumption <|> constructor },
end

lemma liftp_map {p q : α → Prop} {t : tree α β} (f : ∀ x, p x → q x) (h : liftp p t) :
  liftp q t :=
begin
  induction h; constructor; solve_by_elim
end

lemma liftp_and {p q : α → Prop} {t : tree α β} (h : liftp p t) (h' : liftp q t) :
  liftp (λ x, p x ∧ q x) t :=
begin
  induction h; cases h'; constructor;
  solve_by_elim [and.intro]
end

lemma exists_of_liftp {p : α → Prop} {t : tree α β} (h : liftp p t) :
  ∃ x, p x :=
begin
  cases h; split; assumption
end

section defs
variables [has_le α] [has_lt α]

open tree nat

variables [@decidable_rel α (<)]

def insert' (x : α) (v' : β) :
  tree α β →
  (tree α β → γ) →
  (tree α β → α → tree α β → γ) → γ
| (tree.leaf y v) ret_one inc_two :=
  match cmp x y with
  | ordering.lt := inc_two (tree.leaf x v') y (tree.leaf y v)
  | ordering.eq := ret_one (tree.leaf y v')
  | ordering.gt := inc_two (tree.leaf y v) x (tree.leaf x v')
  end
| (tree.node2 t₀ y t₁) ret_one inc_two :=
  if x < y then
    insert' t₀
      (λ t',      ret_one $ tree.node2 t' y t₁)
      (λ ta k tb, ret_one $ tree.node3 ta k tb y t₁)
  else
    insert' t₁
      (λ t',      ret_one $ tree.node2 t₀ y t')
      (λ ta k tb, ret_one $ tree.node3 t₀ y ta k tb)
| (tree.node3 t₀ y t₁ z t₂) ret_one inc_two :=
  if x < y
    then insert' t₀
      (λ t',      ret_one $ tree.node3 t' y t₁ z t₂)
      (λ ta k tb, inc_two (tree.node2 ta k tb) y (tree.node2 t₁ z t₂))
  else if x < z
    then insert' t₁
      (λ t',      ret_one $ tree.node3 t₀ y t' z t₂)
      (λ ta k tb, inc_two (tree.node2 t₀ y ta) k (tree.node2 tb z t₂))
    else insert' t₂
      (λ t',      ret_one $ tree.node3 t₀ y t₁ z t')
      (λ ta k tb, inc_two (tree.node2 t₀ y t₁) z (tree.node2 ta k tb))

def insert (x : α) (v' : β) (t : tree α β) : tree α β :=
insert' x v' t id tree.node2

-- inductive shrunk (α : Type u) : ℕ
section add_

variables (ret shr : tree α β → γ)

def add_left : tree α β → α → tree α β → γ
| t₀ x t@(tree.leaf _ _) := ret t₀
| t₀ x (tree.node2 t₁ y t₂) := shr (tree.node3 t₀ x t₁ y t₂)
| t₀ x (tree.node3 t₁ y t₂ z t₃) := ret (tree.node2 (tree.node2 t₀ x t₁) y (tree.node2 t₂ z t₃))

def add_right : tree α β → α → tree α β → γ
| t@(tree.leaf _ _) x t₀ := ret t
| (tree.node2 t₀ x t₁) y t₂ := shr (tree.node3 t₀ x t₁ y t₂)
| (tree.node3 t₀ x t₁ y t₂) z t₃ := ret (tree.node2 (tree.node2 t₀ x t₁) y (tree.node2 t₂ z t₃))

variables (t₀ : tree α β) (x : α) (t₁ : tree α β) (y : α) (t₂ : tree α β)

def add_left_left : Π (t₀ : tree α β) (x : α) (t₁ : tree α β) (y : α) (t₂ : tree α β), γ
| t₀ x (tree.leaf k v)           z t₂ := ret t₀
| t₀ x (tree.node2 t₁ y t₂)      z t₃ := ret (tree.node2 (tree.node3 t₀ x t₁ y t₂) z t₃)
| t₀ w (tree.node3 t₁ x t₂ y t₃) z t₄ := ret (tree.node3 (tree.node2 t₀ w t₁) x (tree.node2 t₂ y t₃) z t₄)

def add_middle : Π (t₀ : tree α β) (x : α) (t₁ : tree α β) (y : α) (t₂ : tree α β), γ
| t@(tree.leaf k v)           y t₁ z t₂ := ret t
| (tree.node2 t₀ x t₁)      y t₂ z t₃ := ret (tree.node2 (tree.node3 t₀ x t₁ y t₂) z t₃)
| (tree.node3 t₀ w t₁ x t₂) y t₃ z t₄ := ret (tree.node3 (tree.node2 t₀ w t₁) x (tree.node2 t₂ y t₃) z t₄)

def add_right_right : Π (t₀ : tree α β) (x : α) (t₁ : tree α β) (y : α) (t₂ : tree α β), γ
| t₀ x (tree.leaf k v)           z t₂ := ret t₀
| t₀ x (tree.node2 t₁ y t₂)      z t₃ := ret (tree.node2 t₀ x (tree.node3 t₁ y t₂ z t₃))
| t₀ w (tree.node3 t₁ x t₂ y t₃) z t₄ := ret (tree.node3 t₀ w (tree.node2 t₁ x t₂) y (tree.node2 t₃ z t₄))

end add_

def delete' [decidable_eq α] (x : α) :
  tree α β →
  (option α → tree α β → γ) →
  (option α → tree α β → γ) →
  (unit → γ) → γ
| (tree.leaf y v) ret shr del :=
  if x = y then del () else ret (some y) (tree.leaf y v)
| (tree.node2 t₀ y t₁) ret shr del :=
  if x < y
    then delete' t₀ (λ a t', ret a $ tree.node2 t' y t₁)
                    (λ a t', add_left (ret a) (shr a) t' y t₁)
                    (λ _, shr (some y) t₁)
    else delete' t₁ (λ y' t', ret none $ tree.node2 t₀ (y'.get_or_else y) t')
                    (λ y' t', add_right (ret none) (shr none) t₀ (y'.get_or_else y) t')
                    (λ _, shr none t₀)
| (tree.node3 t₀ y t₁ z t₂) ret shr del :=
  if x < y
    then delete' t₀ (λ a t', ret a $ tree.node3 t' y t₁ z t₂)
                    (λ a t', add_left_left (ret a) t' y t₁ z t₂)
                    (λ _, ret (some y) $ tree.node2 t₁ z t₂)
  else if x < z
    then delete' t₁ (λ a t', ret none $ tree.node3 t₀ (a.get_or_else y) t' z t₂)
                    (λ a t', add_middle (ret none) t₀ y t' z t₂)
                    (λ _, ret none $ tree.node2 t₀ z t₂)
    else delete' t₂ (λ a t', ret none $ tree.node3 t₀ y t₁ (a.get_or_else z) t')
                    (λ a t', add_right_right (ret none) t₀ y t₁ z t')
                    (λ _, ret none $ tree.node2 t₀ y t₁)

def delete [decidable_eq α] (x : α) (t : tree α β) : option (tree α β) :=
delete' x t (λ _, some) (λ _, some) (λ _, none)

end defs

local attribute [simp] add_left add_right add_left_left add_middle add_right_right first last

variables [linear_order α]

-- #check @above_of_above_of_forall_le_of_le

lemma first_le_last_of_sorted {t : tree α β} (h : sorted' t) :
  first t ≤ last t :=
begin
  induction h; subst_vars; dsimp [first, last],
  { refl },
  repeat { solve_by_elim [le_of_lt] <|> transitivity },
end

lemma eq_of_below {x : option α} {y : α} (h : below x y) : x.get_or_else y = y :=
by cases h; refl

lemma above_of_above_of_le {x y : α} {k}
  (h : x ≤ y) (h' : above y k) : above x k :=
by cases h'; constructor; solve_by_elim [lt_of_le_of_lt]

@[interactive]
meta def interactive.saturate : tactic unit := do
tactic.interactive.casesm (some ()) [``(above _ (some _)), ``(below (some _) _), ``(below' (some _) _)],
tactic.find_all_hyps ``(sorted' _) $ λ h, do
{ n ← tactic.get_unused_name `h,
  tactic.mk_app ``first_le_last_of_sorted [h] >>= tactic.note n none,
  tactic.skip },
tactic.find_all_hyps ``(below _ _) $ λ h, do
{ n ← tactic.get_unused_name `h,
  tactic.mk_app ``eq_of_below [h] >>= tactic.note n none,
  tactic.skip },
tactic.find_all_hyps ``(¬ _ < _) $ λ h, do
{ -- n ← tactic.get_unused_name `h,
  tactic.mk_app ``le_of_not_gt [h] >>= tactic.note h.local_pp_name none,
  tactic.clear h,
  tactic.skip }

@[interactive]
meta def interactive.above : tactic unit := do
-- tactic.interactive.saturate,
tactic.find_hyp ``(above _ _) $ λ h, do
  tactic.refine ``(above_of_above_of_le _ %%h),
  tactic.interactive.chain_trans

section sorted_insert

variables (lb ub : option α)
  (P : γ → Prop)
  (ret : tree α β → γ)
  -- (ret' : tree α β → tree α β)
  (mk : tree α β → α → tree α β → γ)
  (h₀ : ∀ t,
      below lb (first t) →
      above (last t) ub →
    sorted' t → P (ret t))
  (h₂ : ∀ t₀ x t₁,
      below lb (first t₀) →
      above (last t₀) (some x) →
      below (some x) (first t₁) →
      above (last t₁) ub →
      sorted' t₀ → sorted' t₁ → P (mk t₀ x t₁))

include h₀ h₂

lemma sorted_insert_aux' {k : α} {v : β} {t}
  (h : sorted' t)
  (h' : below lb (min k (first t)))
  (h'' : above k ub)
  (h''' : above (last t) ub) :
    P (insert' k v t ret mk) :=
begin
  -- generalize_hyp hlb : none = k₀ at h,
  induction h generalizing lb ub ret mk,
  case two_three.sorted'.leaf : k' v'  lb ub ret mk h₀ h₂ h' h''
  { dsimp [insert'],
    trichotomy k =? k'; dsimp [insert']; apply h₀ <|> apply h₂,
    all_goals
    { try { have h := le_of_lt h },
      simp [first, h, min_eq_left, min_eq_right, min_self] at h', },
    repeat { assumption <|> constructor <|> refl } },
  case two_three.sorted'.node2 : x t₀ t₁ h h' h_a h_a_1
    h_ih₀ h_ih₁ lb ub ret mk h₀ h₂
  { dsimp [insert'],
    split_ifs; [apply @h_ih₀ lb (some x), apply @h_ih₁ (some x) ub]; clear h_ih₀ h_ih₁,
    all_goals
    { try { intros, apply h₀ <|> apply h₂ },
      clear h₀ h₂, },
    all_goals
    { casesm* [above _ (some _), below (some _) _],
      dsimp [first, last] at * { fail_if_unchanged := ff },
      repeat { assumption <|> constructor } },
    all_goals
    { find_all_hyps foo := ¬ (_ < _) then { replace foo := le_of_not_gt foo },
      find_all_hyps ht := sorted' _ then { have hh := first_le_last_of_sorted ht } },
    { rw min_eq_right at h'_1, assumption, chain_trans, },
    { have h : first t₀ ≤ k, chain_trans,
      have hh' := min_eq_right h, cc, },
    { subst x,
      rw min_eq_right h_1, constructor } },
  case two_three.sorted'.node3 : x y t₀ t₁ t₂ h_a h_a_1 h_a_2 h_a_3 h_a_4 h_a_5 h_a_6
    h_ih₀ h_ih₁ h_ih₂ lb ub ret mk h₀ h₂ h' h'' h'''
  { dsimp [insert'],
    split_ifs; [apply @h_ih₀ lb (some x), apply @h_ih₁ (some x) (some y), apply @h_ih₂ (some y) ub];
      clear h_ih₀ h_ih₁ h_ih₂,
    all_goals
    { try { intros, apply h₀ <|> apply h₂ },
      clear h₀ h₂, },
    all_goals
    { casesm* [above _ (some _), below (some _) _],
      subst_vars,
      dsimp [first, last] at * { fail_if_unchanged := ff },
      repeat { assumption <|> constructor } },
    all_goals
    { find_all_hyps foo := ¬ (_ < _) then { replace foo := le_of_not_gt foo },
      find_all_hyps ht := sorted' _ then { have hh := first_le_last_of_sorted ht },
      have h₀ : first t₀ ≤ k; [chain_trans, skip],
      try { have h₁ : first t₁ ≤ k; [chain_trans, skip] },
      try { have h₂ : first t₂ ≤ k; [chain_trans, skip] } },
    { have hh' := min_eq_right h₀, cc, },
    { have hh' := min_eq_right h₀, cc, },
    { rw min_eq_right h₁, constructor, },
    { have hh' := min_eq_right h₀, cc, },
    { have hh' := min_eq_right h₀, cc, },
    { rw min_eq_right h₂, constructor, } },
end

end sorted_insert

lemma sorted_insert {k : α} {v : β} {t : tree α β}
  (h : sorted' t) :
   sorted' (insert k v t) :=
sorted_insert_aux' none none _ _ _
  (λ t _ _ h, h)
  (λ t₀ x t₁ h₀ h₁ h₂ h₃ ht₀ ht₁, sorted'.node2 (by cases h₁; assumption) (by cases h₂; refl) ht₀ ht₁)
  h (by constructor) (by constructor) (by constructor)

section with_height_insert

variables (n : ℕ) (P : γ → Prop)
  (ret : tree α β → γ)
  (mk : tree α β → α → tree α β → γ)
  (h₀ : ∀ t, with_height n t → P (ret t))
  (h₂ : ∀ t₀ x t₁,
      with_height n t₀ → with_height n t₁ → P (mk t₀ x t₁))

include h₀ h₂

lemma with_height_insert_aux {k : α} {v : β} {t}
  (h : with_height n t) :
  P (insert' k v t ret mk) :=
begin
  induction h generalizing ret mk,
  case two_three.with_height.leaf : k' v'
  { dsimp [insert'],
    trichotomy k =? k',
    all_goals
    { dsimp [insert'], subst_vars, apply h₂ <|> apply h₀, repeat { constructor }, }, },
  case two_three.with_height.node2 : h_n h_x h_t₀ h_t₁ h_a h_a_1 h_ih₀ h_ih₁
  { dsimp [insert'], split_ifs,
    repeat { intro <|> apply h_ih₀ <|> apply h_ih₁ <|>
             apply h₀ <|> apply h₂ <|> assumption <|> constructor }, },
  case two_three.with_height.node3 : h_n h_x h_y h_t₀ h_t₁ h_t₂ h_a h_a_1 h_a_2 h_ih₀ h_ih₁ h_ih₂
  { dsimp [insert'], split_ifs,
    repeat { intro <|> apply h_ih₀ <|> apply h_ih₁ <|> apply h_ih₂ <|>
             apply h₀ <|> apply h₂ <|> assumption <|> constructor }, },
end

end with_height_insert

lemma with_height_insert {k : α} {v : β} {n t}
  (h : with_height n t) :
  with_height n (insert k v t) ∨
  with_height (succ n) (insert k v t) :=
begin
  apply with_height_insert_aux _ (λ t' : tree α β, with_height n t' ∨ with_height (succ n) t') _ _ _ _ h,
  { introv h', left, apply h' },
  { introv h₀ h₁, right, constructor; assumption }
end

section with_height_add_left

variables (n : ℕ) (P : γ → Prop)
  (ret shr : tree α β → γ)

variables
  (h₀ : ∀ t, with_height (succ (succ n)) t → P (ret t))
  (h₁ : ∀ t, with_height (succ n) t → P (shr t))

include h₀ h₁

lemma with_height_add_left {k : α} {t₀ t₁}
  (h : with_height n t₀)
  (h' : with_height (succ n) t₁) :
  P (add_left ret shr t₀ k t₁) :=
begin
  cases h'; dsimp [add_left],
  { apply h₁, repeat { assumption <|> constructor}, },
  { apply h₀, repeat { assumption <|> constructor}, },
end

lemma with_height_add_right {k : α} {t₀ t₁}
  (h : with_height (succ n) t₀)
  (h' : with_height n t₁) :
  P (add_right ret shr t₀ k t₁) :=
begin
  cases h; dsimp [add_right],
  { apply h₁, repeat { assumption <|> constructor}, },
  { apply h₀, repeat { assumption <|> constructor}, },
end

omit h₁

lemma with_height_add_left_left {k k' : α} {t₀ t₁ t₂}
  (hh₀ : with_height n t₀)
  (hh₁ : with_height (succ n) t₁)
  (hh₂ : with_height (succ n) t₂) :
  P (add_left_left ret t₀ k t₁ k' t₂) :=
begin
  cases hh₁; clear hh₁; dsimp; apply h₀,
  repeat { assumption <|> constructor },
end

lemma with_height_add_middle {k k' : α} {t₀ t₁ t₂}
  (hh₀ : with_height (succ n) t₀)
  (hh₁ : with_height n t₁)
  (hh₂ : with_height (succ n) t₂) :
  P (add_middle ret t₀ k t₁ k' t₂) :=
begin
  cases hh₀; clear hh₀; dsimp; apply h₀,
  repeat { assumption <|> constructor },
end

lemma with_height_add_right_right {k k' : α} {t₀ t₁ t₂}
  (hh₀ : with_height (succ n) t₀)
  (hh₁ : with_height (succ n) t₁)
  (hh₂ : with_height n t₂) :
  P (add_right_right ret t₀ k t₁ k' t₂) :=
begin
  cases hh₁; clear hh₁; dsimp; apply h₀,
  repeat { assumption <|> constructor },
end

end with_height_add_left

section with_height_delete

variables (n : ℕ) (P : γ → Prop)
  (ret shr : option α → tree α β → γ)
  (del : unit → γ)
  (h₀ : ∀ a t, with_height n t → P (ret a t))
  (h₁ : ∀ a t n', succ n' = n → with_height n' t → P (shr a t))
  (h₂ : ∀ u, n = 0 → P (del u))

include h₀ h₁ h₂

lemma with_height_delete_aux {k : α} {t}
  (h : with_height n t) :
  P (delete' k t ret shr del) :=
begin
  induction h generalizing ret shr del,
  case two_three.with_height.leaf : k' v'
  { dsimp [delete'],
    split_ifs,
    all_goals
    { subst_vars, apply h₂ <|> apply h₀ <|> apply h₁, repeat { constructor }, }, },
  case two_three.with_height.node2 : n h_x h_t₀ h_t₁ h_a h_a_1 h_ih₀ h_ih₁
  { dsimp [delete'], split_ifs,
    repeat { intro <|> apply h_ih₀ <|> apply h_ih₁ <|>
             apply h₀ <|> apply h₁ <|> apply with_height_add_left <|>
             apply with_height_add_right <|> assumption <|> constructor, try { subst_vars } } },
  case two_three.with_height.node3 : h_n h_x h_y h_t₀ h_t₁ h_t₂ h_a h_a_1 h_a_2 h_ih₀ h_ih₁ h_ih₂
  { dsimp [delete'], split_ifs,
    repeat { intro <|> apply h_ih₀ <|> apply h_ih₁ <|> apply h_ih₂ },
    all_goals
    { repeat { intro <|> apply h₀ <|> apply h₁ <|> apply h₂ <|>
               apply with_height_add_left <|>
               apply with_height_add_right <|>
               apply with_height_add_left_left <|>
               apply with_height_add_middle <|>
               apply with_height_add_right_right,  },
      repeat
      { subst_vars,
        assumption <|> constructor } }, },
end

end with_height_delete

lemma with_height_delete {n} {k : α} {t : tree α β}
  (h : with_height n t) :
  option.elim (delete k t) false (with_height n) ∨ option.elim (delete k t) (n = 0) (with_height n.pred) :=
with_height_delete_aux n (λ x : option (tree α β), option.elim x false (with_height n) ∨ option.elim x (n = 0) (with_height n.pred))
  (λ _, some) (λ _, some) _
  (by { dsimp, tauto })
  (by { dsimp, intros, subst n, tauto })
  (by { dsimp, tauto })
  h

section sorted_add_left

variables (P : γ → Prop)
  (lb ub : option α)
  (ret shr : tree α β → γ)

variables
  (h₀ : ∀ t, below lb (first t) → above (last t) ub → sorted' t → P (ret t))
  (h₁ : ∀ t, below lb (first t) → above (last t) ub → sorted' t → P (shr t))

include h₀ h₁

lemma sorted_add_left {k : α} {t₀ t₁}
  (hhₐ : below lb (first t₀))
  (hh₀ : sorted' t₀)
  (hh₁ : last t₀ < k)
  (hh₂ : k = first t₁)
  (hh₃ : sorted' t₁)
  (hh₄ : above (last t₁) ub) :
  P (add_left ret shr t₀ k t₁) :=
begin
  cases hh₃; clear hh₃; dsimp [add_left],
  all_goals
  { apply h₁ <|> apply h₀, clear h₀ h₁,
    repeat { assumption <|> constructor } },
  dsimp at *, subst_vars,
  cases hh₄; constructor,
  chain_trans
end

lemma sorted_add_right {k : α} {t₀ t₁}
  (hhₐ : below lb (first t₀))
  (hh₀ : sorted' t₀)
  (hh₁ : last t₀ < k)
  (hh₂ : k = first t₁)
  (hh₃ : sorted' t₁)
  (hh₄ : above (last t₁) ub) :
  P (add_right ret shr t₀ k t₁) :=
begin
  cases hh₀; clear hh₀; dsimp [add_left],
  all_goals
  { apply h₁ <|> apply h₀, clear h₀ h₁,
    repeat { assumption <|> constructor } },
  dsimp at *, subst_vars,
  cases hh₄; constructor,
  have := first_le_last_of_sorted hh₃,
  chain_trans
end

omit h₁

lemma sorted_add_left_left {k k' : α} {t₀ t₁ t₂}
  (hhₐ : below lb (first t₀))
  (hh₀ : sorted' t₀)
  (hh₁ : last t₀ < k)
  (hh₂ : k = first t₁)
  (hh₃ : sorted' t₁)
  (hh₄ : last t₁ < k')
  (hh₅ : k' = first t₂)
  (hh₆ : sorted' t₂)
  (hh₇ : above (last t₂) ub) :
  P (add_left_left ret t₀ k t₁ k' t₂) :=
begin
  cases hh₃; clear hh₃; dsimp at *,
  all_goals
  { saturate,
    subst_vars, apply h₀,
    repeat { assumption <|> constructor <|> above }, },
end

lemma sorted_add_middle {k k' : α} {t₀ t₁ t₂}
  (hhₐ : below lb (first t₀))
  (hh₀ : sorted' t₀)
  (hh₁ : last t₀ < k)
  (hh₂ : k = first t₁)
  (hh₃ : sorted' t₁)
  (hh₄ : last t₁ < k')
  (hh₅ : k' = first t₂)
  (hh₆ : sorted' t₂)
  (hh₇ : above (last t₂) ub) :
  P (add_middle ret t₀ k t₁ k' t₂) :=
begin
  cases hh₀; clear hh₀; dsimp; apply h₀; clear h₀,
  repeat { assumption <|> constructor <|> above },
end

lemma sorted_add_right_right {k k' : α} {t₀ t₁ t₂}
  (hhₐ : below lb (first t₀))
  (hh₀ : sorted' t₀)
  (hh₁ : last t₀ < k)
  (hh₂ : k = first t₁)
  (hh₃ : sorted' t₁)
  (hh₄ : last t₁ < k')
  (hh₅ : k' = first t₂)
  (hh₆ : sorted' t₂)
  (hh₇ : above (last t₂) ub) :
  P (add_right_right ret t₀ k t₁ k' t₂) :=
begin
  cases hh₃; clear hh₃; dsimp at *; apply h₀; clear h₀,
  repeat { assumption <|> constructor <|> above },
end

end sorted_add_left

section sorted_delete

variables
  (lb ub : option α)
  (P : γ → Prop)
  (ret shr : option α → tree α β → γ)
  (del : unit → γ)
  -- (h₀ : ∀ a t, sorted' t → P (ret a t))
  -- (h₁ : ∀ a t, sorted' t → P (shr a t))
  -- (h₀ : ∀ a t, below lb (first t) → below a (first t) → above (last t) ub → sorted' t → P (ret a t))
  -- (h₁ : ∀ a t, below lb (first t) → below a (first t) → above (last t) ub → sorted' t → P (shr a t))
  (h₀ : ∀ a t, below lb (first t) → above (last t) ub → sorted' t → P (ret a t))
  (h₁ : ∀ a t, below lb (first t) → above (last t) ub → sorted' t → P (shr a t))
  (h₂ : ∀ u, P (del u))

include h₀ h₁ h₂

lemma sorted_delete_aux {k : α} {t}
  (hh₀ : below lb (first t))
  (hh₁ : sorted' t)
  (hh₂ : above (last t) ub) :
  P (delete' k t ret shr del) :=
begin
  induction hh₁ generalizing lb ub ret shr del,
  case two_three.sorted'.leaf : k' v'
  { dsimp [delete'],
    split_ifs,
    all_goals
    { subst_vars, apply h₂ <|> apply h₀ <|> apply h₁,
      repeat { assumption <|> constructor <|> dsimp at * }, }, },
  case two_three.sorted'.node2 : n h_x h_t₀ h_t₁ hh₀ hh₁ hh₂ h_ih₀ h_ih₁
  { dsimp [delete'],
    find_all_hyps hh := sorted' _ then { have h := first_le_last_of_sorted hh },
    split_ifs,
    all_goals {
    try {
    repeat
    { repeat { intro h, try { have := first_le_last_of_sorted h } },
      apply h_ih₀ lb (some n) <|> apply h_ih₁ (some n) ub <|>
      casesm [above _ (some _)] <|>
      apply h₀ <|> apply h₁ <|> apply h₂ <|>
      apply sorted_add_left <|>
      apply sorted_add_right <|>
      apply sorted_add_left_left <|>
      apply sorted_add_middle <|>
      apply sorted_add_right_right <|>
      assumption <|> constructor,
      try { subst_vars } },
      done }
    },

    { apply h_ih₀ lb (some n); clear h_ih₀ h_ih₁,
      { intros, casesm* [above _ (some _)],
        apply h₀,
        repeat { assumption <|> constructor } },
      { intros, apply sorted_add_left,
        intros, apply h₀,
        repeat { assumption <|> constructor },
    all_goals
    { casesm* [above _ (some _)],
      repeat { intro <|> apply h₀ <|> apply h₁ <|> apply h₂ <|>
               apply with_height_add_left <|>
               apply with_height_add_right <|>
               apply with_height_add_left_left <|>
               apply with_height_add_middle <|>
               apply with_height_add_right_right,  } },
      repeat
      { subst_vars,
        intro <|> assumption <|> constructor } },

admit,
admit,
admit,
 },
admit
 },
admit,
  -- case two_three.sorted'.node3 : h_n h_x h_y h_t₀ h_t₁ h_t₂ h_a h_a_1 h_a_2 h_ih₀ h_ih₁ h_ih₂
  -- { dsimp [delete'], split_ifs,
  --   repeat { intro <|> apply h_ih₀ <|> apply h_ih₁ <|> apply h_ih₂ },
  --   all_goals
  --   { repeat { intro <|> apply h₀ <|> apply h₁ <|> apply h₂ <|>
  --              apply with_height_add_left <|>
  --              apply with_height_add_right <|>
  --              apply with_height_add_left_left <|>
  --              apply with_height_add_middle <|>
  --              apply with_height_add_right_right,  },
  --     repeat
  --     { subst_vars,
  --       assumption <|> constructor } }, },
end

end sorted_delete

end two_three


/-
Copyright (c) 2018 Mario Carneiro. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Mario Carneiro, Aurélien Saue, Tim Baanen
-/
import Lean.Elab.Tactic.Basic
import Mathlib.Algebra.GroupPower.Basic
import Mathlib.Algebra.Ring.Basic
import Mathlib.Tactic.NormNum
import Mathlib.Tactic.Clear!
import Mathlib.Util.AtomM

/-!
# `ring` tactic

A tactic for solving equations in commutative (semi)rings,
where the exponents can also contain variables.
Based on <http://www.cs.ru.nl/~freek/courses/tt-2014/read/10.1.1.61.3041.pdf> .

More precisely, expressions of the following form are supported:
- constants (non-negative integers)
- variables
- coefficients (any rational number, embedded into the (semi)ring)
- addition of expressions
- multiplication of expressions (`a * b`)
- scalar multiplication of expressions (`n • a`; the multiplier must have type `ℕ`)
- exponentiation of expressions (the exponent must have type `ℕ`)
- subtraction and negation of expressions (if the base is a full ring)

The extension to exponents means that something like `2 * 2^n * b = b * 2^(n+1)` can be proved,
even though it is not strictly speaking an equation in the language of commutative rings.

## Implementation notes

The basic approach to prove equalities is to normalise both sides and check for equality.
The normalisation is guided by building a value in the type `ExSum` at the meta level,
together with a proof (at the base level) that the original value is equal to
the normalised version.

The outline of the file:
- Define a mutual inductive family of types `ExSum`, `ExProd`, `ExBase`,
  which can represent expressions with `+`, `*`, `^` and rational numerals.
  The mutual induction ensures that associativity and distributivity are applied,
  by restricting which kinds of subexpressions appear as arguments to the various operators.
- Represent addition, multiplication and exponentiation in the `ExSum` type,
  thus allowing us to map expressions to `ExSum` (the `eval` function drives this).
  We apply associativity and distributivity of the operators here (helped by `Ex*` types)
  and commutativity as well (by sorting the subterms; unfortunately not helped by anything).
  Any expression not of the above formats is treated as an atom (the same as a variable).

There are some details we glossed over which make the plan more complicated:
- The order on atoms is not initially obvious.
  We construct a list containing them in order of initial appearance in the expression,
  then use the index into the list as a key to order on.
- For `pow`, the exponent must be a natural number, while the base can be any semiring `α`.
  We swap out operations for the base ring `α` with those for the exponent ring `ℕ`
  as soon as we deal with exponents.

## Caveats and future work

The normalized form of an expression is the one that is useful for the tactic,
but not as nice to read. To remedy this, the user-facing normalization calls `ringNFCore`.

Subtraction cancels out identical terms, but division does not.
That is: `a - a = 0 := by ring` solves the goal,
but `a / a := 1 by ring` doesn't.
Note that `0 / 0` is generally defined to be `0`,
so division cancelling out is not true in general.

Multiplication of powers can be simplified a little bit further:
`2 ^ n * 2 ^ n = 4 ^ n := by ring` could be implemented
in a similar way that `2 * a + 2 * a = 4 * a := by ring` already works.
This feature wasn't needed yet, so it's not implemented yet.

## Tags

ring, semiring, exponent, power
-/

namespace Mathlib.Tactic
namespace Ring
open Mathlib.Meta Qq NormNum Lean.Meta AtomM
open Lean (MetaM Expr mkRawNatLit)

/-- A shortcut instance for `CommSemiring ℕ` used by ring. -/
def instCommSemiringNat : CommSemiring ℕ := inferInstance

/--
A typed expression of type `CommSemiring ℕ` used when we are working on
ring subexpressions of type `ℕ`.
-/
def sℕ : Q(CommSemiring ℕ) := q(instCommSemiringNat)

mutual

/-- The base `e` of a normalized exponent expression. -/
inductive ExBase : ∀ {α : Q(Type u)}, Q(CommSemiring $α) → (e : Q($α)) → Type
  /--
  An atomic expression `e` with id `id`.

  Atomic expressions are those which `ring` cannot parse any further.
  For instance, `a + (a % b)` has `a` and `(a % b)` as atoms.
  The `ring1` tactic does not normalize the subexpressions in atoms, but `ring_nf` does.

  Atoms in fact represent equivalence classes of expressions, modulo definitional equality.
  The field `index : ℕ` should be a unique number for each class,
  while `value : expr` contains a representative of this class.
  The function `resolve_atom` determines the appropriate atom for a given expression.
  -/
  | atom (id : ℕ) : ExBase sα e
  /-- A sum of monomials.  -/
  | sum (_ : ExSum sα e) : ExBase sα e

/--
A monomial, which is a product of powers of `ExBase` expressions,
terminated by a (nonzero) constant coefficient.
-/
inductive ExProd : ∀ {α : Q(Type u)}, Q(CommSemiring $α) → (e : Q($α)) → Type
  /-- A coefficient `value`, which must not be `0`. `e` is a raw rat cast.
  If `value` is not an integer, then `hyp` should be a proof of `(value.den : α) ≠ 0`. -/
  | const (value : ℚ) (hyp : Option Expr := none) : ExProd sα e
  /-- A product `x ^ e * b` is a monomial if `b` is a monomial. Here `x` is a `ExBase`
  and `e` is a `ExProd` representing a monomial expression in `ℕ` (it is a monomial instead of
  a polynomial because we eagerly normalize `x ^ (a + b) = x ^ a * x ^ b`.) -/
  | mul {α : Q(Type u)} {sα : Q(CommSemiring $α)} {x : Q($α)} {e : Q(ℕ)} {b : Q($α)} :
    ExBase sα x → ExProd sℕ e → ExProd sα b → ExProd sα q($x ^ $e * $b)

/-- A polynomial expression, which is a sum of monomials. -/
inductive ExSum : ∀ {α : Q(Type u)}, Q(CommSemiring $α) → (e : Q($α)) → Type
  /-- Zero is a polynomial. `e` is the expression `0`. -/
  | zero {α : Q(Type u)} {sα : Q(CommSemiring $α)} : ExSum sα q(0 : $α)
  /-- A sum `a + b` is a polynomial if `a` is a monomial and `b` is another polynomial. -/
  | add {α : Q(Type u)} {sα : Q(CommSemiring $α)} {a b : Q($α)} :
    ExProd sα a → ExSum sα b → ExSum sα q($a + $b)
end

mutual -- partial only to speed up compilation

/-- Equality test for expressions. This is not a `BEq` instance because it is heterogeneous. -/
partial def ExBase.eq : ExBase sα a → ExBase sα b → Bool
  | .atom i, .atom j => i == j
  | .sum a, .sum b => a.eq b
  | _, _ => false

@[inherit_doc ExBase.eq]
partial def ExProd.eq : ExProd sα a → ExProd sα b → Bool
  | .const i _, .const j _ => i == j
  | .mul a₁ a₂ a₃, .mul b₁ b₂ b₃ => a₁.eq b₁ && a₂.eq b₂ && a₃.eq b₃
  | _, _ => false

@[inherit_doc ExBase.eq]
partial def ExSum.eq : ExSum sα a → ExSum sα b → Bool
  | .zero, .zero => true
  | .add a₁ a₂, .add b₁ b₂ => a₁.eq b₁ && a₂.eq b₂
  | _, _ => false
end

mutual -- partial only to speed up compilation
/--
A total order on normalized expressions.
This is not an `Ord` instance because it is heterogeneous.
-/
partial def ExBase.cmp : ExBase sα a → ExBase sα b → Ordering
  | .atom i, .atom j => compare i j
  | .sum a, .sum b => a.cmp b
  | .atom .., .sum .. => .lt
  | .sum .., .atom .. => .gt

@[inherit_doc ExBase.cmp]
partial def ExProd.cmp : ExProd sα a → ExProd sα b → Ordering
  | .const i _, .const j _ => compare i j
  | .mul a₁ a₂ a₃, .mul b₁ b₂ b₃ => (a₁.cmp b₁).then (a₂.cmp b₂) |>.then (a₃.cmp b₃)
  | .const _ _, .mul .. => .lt
  | .mul .., .const _ _ => .gt

@[inherit_doc ExBase.cmp]
partial def ExSum.cmp : ExSum sα a → ExSum sα b → Ordering
  | .zero, .zero => .eq
  | .add a₁ a₂, .add b₁ b₂ => (a₁.cmp b₁).then (a₂.cmp b₂)
  | .zero, .add .. => .lt
  | .add .., .zero => .gt
end

instance : Inhabited (Σ e, (ExBase sα) e) := ⟨default, .atom 0⟩
instance : Inhabited (Σ e, (ExSum sα) e) := ⟨_, .zero⟩
instance : Inhabited (Σ e, (ExProd sα) e) := ⟨default, .const 0 none⟩

mutual

/-- Converts `ExBase sα` to `ExBase sβ`, assuming `sα` and `sβ` are defeq. -/
partial def ExBase.cast : ExBase sα a → Σ a, ExBase sβ a
  | .atom i => ⟨a, .atom i⟩
  | .sum a => let ⟨_, vb⟩ := a.cast; ⟨_, .sum vb⟩

/-- Converts `ExProd sα` to `ExProd sβ`, assuming `sα` and `sβ` are defeq. -/
partial def ExProd.cast : ExProd sα a → Σ a, ExProd sβ a
  | .const i h => ⟨a, .const i h⟩
  | .mul a₁ a₂ a₃ => ⟨_, .mul a₁.cast.2 a₂ a₃.cast.2⟩

/-- Converts `ExSum sα` to `ExSum sβ`, assuming `sα` and `sβ` are defeq. -/
partial def ExSum.cast : ExSum sα a → Σ a, ExSum sβ a
  | .zero => ⟨_, .zero⟩
  | .add a₁ a₂ => ⟨_, .add a₁.cast.2 a₂.cast.2⟩

end

/--
The result of evaluating an (unnormalized) expression `e` into the type family `E`
(one of `ExSum`, `ExProd`, `ExBase`) is a (normalized) element `e'`
and a representation `E e'` for it, and a proof of `e = e'`.
-/
structure Result {α : Q(Type u)} (E : Q($α) → Type) (e : Q($α)) where
  /-- The normalized result. -/
  expr : Q($α)
  /-- The data associated to the normalization. -/
  val : E expr
  /-- A proof that the original expression is equal to the normalized result. -/
  proof : Q($e = $expr)

instance [Inhabited (Σ e, E e)] : Inhabited (Result E e) :=
  let ⟨e', v⟩ : Σ e, E e := default; ⟨e', v, default⟩

variable {α : Q(Type u)} (sα : Q(CommSemiring $α)) [CommSemiring R]

/--
Constructs the expression corresponding to `.const n`.
(The `.const` constructor does not check that the expression is correct.)
-/
def ExProd.mkNat (n : ℕ) : (e : Q($α)) × ExProd sα e :=
  let lit : Q(ℕ) := mkRawNatLit n
  ⟨q(($lit).rawCast : $α), .const n none⟩

/--
Constructs the expression corresponding to `.const (-n)`.
(The `.const` constructor does not check that the expression is correct.)
-/
def ExProd.mkNegNat (_ : Q(Ring $α)) (n : ℕ) : (e : Q($α)) × ExProd sα e :=
  let lit : Q(ℕ) := mkRawNatLit n
  ⟨q((Int.negOfNat $lit).rawCast : $α), .const (-n) none⟩

/--
Constructs the expression corresponding to `.const (-n)`.
(The `.const` constructor does not check that the expression is correct.)
-/
def ExProd.mkRat (_ : Q(DivisionRing $α)) (q : ℚ) (n : Q(ℤ)) (d : Q(ℕ)) (h : Expr) :
    (e : Q($α)) × ExProd sα e :=
  ⟨q(Rat.rawCast $n $d : $α), .const q h⟩

section
variable {sα}

/-- Embed an exponent (a `ExBase, ExProd` pair) as a `ExProd` by multiplying by 1. -/
def ExBase.toProd (va : ExBase sα a) (vb : ExProd sℕ b) :
  ExProd sα q($a ^ $b * (nat_lit 1).rawCast) := .mul va vb (.const 1 none)

/-- Embed `ExProd` in `ExSum` by adding 0. -/
def ExProd.toSum (v : ExProd sα e) : ExSum sα q($e + 0) := .add v .zero

/-- Get the leading coefficient of a `ExProd`. -/
def ExProd.coeff : ExProd sα e → ℚ
  | .const q _ => q
  | .mul _ _ v => v.coeff
end

/--
Two monomials are said to "overlap" if they differ by a constant factor, in which case the
constants just add. When this happens, the constant may be either zero (if the monomials cancel)
or nonzero (if they add up); the zero case is handled specially.
-/
inductive Overlap (e : Q($α)) where
  /-- The expression `e` (the sum of monomials) is equal to `0`. -/
  | zero (_ : Q(IsNat $e (nat_lit 0)))
  /-- The expression `e` (the sum of monomials) is equal to another monomial
  (with nonzero leading coefficient). -/
  | nonzero (_ : Result (ExProd sα) e)

theorem add_overlap_pf (x : R) (e) (pq_pf : a + b = c) :
    x ^ e * a + x ^ e * b = x ^ e * c := by subst_vars; simp [mul_add]

theorem add_overlap_pf_zero (x : R) (e) :
    IsNat (a + b) (nat_lit 0) → IsNat (x ^ e * a + x ^ e * b) (nat_lit 0)
  | ⟨h⟩ => ⟨by simp [h, ← mul_add]⟩

/--
Given monomials `va, vb`, attempts to add them together to get another monomial.
If the monomials are not compatible, returns `none`.
For example, `xy + 2xy = 3xy` is a `.nonzero` overlap, while `xy + xz` returns `none`
and `xy + -xy = 0` is a `.zero` overlap.
-/
def evalAddOverlap (va : ExProd sα a) (vb : ExProd sα b) : Option (Overlap sα q($a + $b)) :=
  match va, vb with
  | .const za ha, .const zb hb => do
    let ra := Result.ofRawRat za a ha; let rb := Result.ofRawRat zb b hb
    let res ← NormNum.evalAdd.core q($a + $b) _ _ ra rb
    match res with
    | .isNat _ (.lit (.natVal 0)) p => pure <| .zero p
    | rc =>
      let ⟨zc, hc⟩ ← rc.toRatNZ
      let ⟨c, pc⟩ := rc.toRawEq
      pure <| .nonzero ⟨c, .const zc hc, pc⟩
  | .mul (x := a₁) (e := a₂) va₁ va₂ va₃, .mul vb₁ vb₂ vb₃ => do
    guard (va₁.eq vb₁ && va₂.eq vb₂)
    match ← evalAddOverlap va₃ vb₃ with
    | .zero p => pure <| .zero (q(add_overlap_pf_zero $a₁ $a₂ $p) : Expr)
    | .nonzero ⟨_, vc, p⟩ =>
      pure <| .nonzero ⟨_, .mul va₁ va₂ vc, (q(add_overlap_pf $a₁ $a₂ $p) : Expr)⟩
  | _, _ => none

theorem add_pf_zero_add (b : R) : 0 + b = b := by simp

theorem add_pf_add_zero (a : R) : a + 0 = a := by simp

theorem add_pf_add_overlap
    (_ : a₁ + b₁ = c₁) (_ : a₂ + b₂ = c₂) : (a₁ + a₂ : R) + (b₁ + b₂) = c₁ + c₂ := by
  subst_vars; simp [add_assoc, add_left_comm]

theorem add_pf_add_overlap_zero
    (h : IsNat (a₁ + b₁) (nat_lit 0)) (h₄ : a₂ + b₂ = c) : (a₁ + a₂ : R) + (b₁ + b₂) = c := by
  subst_vars; rw [add_add_add_comm, h.1, Nat.cast_zero, add_pf_zero_add]

theorem add_pf_add_lt (a₁ : R) (_ : a₂ + b = c) : (a₁ + a₂) + b = a₁ + c := by simp [*, add_assoc]

theorem add_pf_add_gt (b₁ : R) (_ : a + b₂ = c) : a + (b₁ + b₂) = b₁ + c := by
  subst_vars; simp [add_left_comm]

/-- Adds two polynomials `va, vb` together to get a normalized result polynomial.

* `0 + b = 0`
* `a + 0 = 0`
* `a * x + a * y = a * (x + y)` (for `x`, `y` coefficients; uses `evalAddOverlap`)
* `(a₁ + a₂) + (b₁ + b₂) = a₁ + (a₂ + (b₁ + b₂))` (if `a₁.lt b₁`)
* `(a₁ + a₂) + (b₁ + b₂) = b₁ + ((a₁ + a₂) + b₂)` (if not `a₁.lt b₁`)
-/
partial def evalAdd (va : ExSum sα a) (vb : ExSum sα b) : Result (ExSum sα) q($a + $b) :=
  match va, vb with
  | .zero, vb => ⟨b, vb, q(add_pf_zero_add $b)⟩
  | va, .zero => ⟨a, va, q(add_pf_add_zero $a)⟩
  | .add (a := a₁) (b := _a₂) va₁ va₂, .add (a := b₁) (b := _b₂) vb₁ vb₂ =>
    match evalAddOverlap sα va₁ vb₁ with
    | some (.nonzero ⟨_, vc₁, pc₁⟩) =>
      let ⟨_, vc₂, pc₂⟩ := evalAdd va₂ vb₂
      ⟨_, .add vc₁ vc₂, q(add_pf_add_overlap $pc₁ $pc₂)⟩
    | some (.zero pc₁) =>
      let ⟨c₂, vc₂, pc₂⟩ := evalAdd va₂ vb₂
      ⟨c₂, vc₂, q(add_pf_add_overlap_zero $pc₁ $pc₂)⟩
    | none =>
      if let .lt := va₁.cmp vb₁ then
        let ⟨_c, vc, (pc : Q($_a₂ + ($b₁ + $_b₂) = $_c))⟩ := evalAdd va₂ vb
        ⟨_, .add va₁ vc, q(add_pf_add_lt $a₁ $pc)⟩
      else
        let ⟨_c, vc, (pc : Q($a₁ + $_a₂ + $_b₂ = $_c))⟩ := evalAdd va vb₂
        ⟨_, .add vb₁ vc, q(add_pf_add_gt $b₁ $pc)⟩

theorem one_mul (a : R) : (nat_lit 1).rawCast * a = a := by simp [Nat.rawCast]

theorem mul_one (a : R) : a * (nat_lit 1).rawCast = a := by simp [Nat.rawCast]

theorem mul_pf_left (a₁ : R) (a₂) (_ : a₃ * b = c) : (a₁ ^ a₂ * a₃ : R) * b = a₁ ^ a₂ * c := by
  subst_vars; rw [mul_assoc]

theorem mul_pf_right (b₁ : R) (b₂) (_ : a * b₃ = c) : a * (b₁ ^ b₂ * b₃) = b₁ ^ b₂ * c := by
  subst_vars; rw [mul_left_comm]

theorem mul_pp_pf_overlap (x : R) (_ : ea + eb = e) (_ : a₂ * b₂ = c) :
    (x ^ ea * a₂ : R) * (x ^ eb * b₂) = x ^ e * c := by
  subst_vars; simp [pow_add, mul_mul_mul_comm]

/-- Multiplies two monomials `va, vb` together to get a normalized result monomial.

* `x * y = (x * y)` (for `x`, `y` coefficients)
* `x * (b₁ * b₂) = b₁ * (b₂ * x)` (for `x` coefficient)
* `(a₁ * a₂) * y = a₁ * (a₂ * y)` (for `y` coefficient)
* `(x ^ ea * a₂) * (x ^ eb * b₂) = x ^ (ea + eb) * (a₂ * b₂)`
    (if `ea` and `eb` are identical except coefficient)
* `(a₁ * a₂) * (b₁ * b₂) = a₁ * (a₂ * (b₁ * b₂))` (if `a₁.lt b₁`)
* `(a₁ * a₂) * (b₁ * b₂) = b₁ * ((a₁ * a₂) * b₂)` (if not `a₁.lt b₁`)
-/
partial def evalMulProd (va : ExProd sα a) (vb : ExProd sα b) : Result (ExProd sα) q($a * $b) :=
  match va, vb with
  | .const za ha, .const zb hb =>
    if za = 1 then
      ⟨b, .const zb hb, (q(one_mul $b) : Expr)⟩
    else if zb = 1 then
      ⟨a, .const za ha, (q(mul_one $a) : Expr)⟩
    else
      let ra := Result.ofRawRat za a ha; let rb := Result.ofRawRat zb b hb
      let rc := (NormNum.evalMul.core q($a * $b) _ _ q(CommSemiring.toSemiring) ra rb).get!
      let ⟨zc, hc⟩ := rc.toRatNZ.get!
      let ⟨c, pc⟩ :=  rc.toRawEq
      ⟨c, .const zc hc, pc⟩
  | .mul (x := a₁) (e := a₂) va₁ va₂ va₃, .const _ _ =>
    let ⟨_, vc, pc⟩ := evalMulProd va₃ vb
    ⟨_, .mul va₁ va₂ vc, (q(mul_pf_left $a₁ $a₂ $pc) : Expr)⟩
  | .const _ _, .mul (x := b₁) (e := b₂) vb₁ vb₂ vb₃ =>
    let ⟨_, vc, pc⟩ := evalMulProd va vb₃
    ⟨_, .mul vb₁ vb₂ vc, (q(mul_pf_right $b₁ $b₂ $pc) : Expr)⟩
  | .mul (x := xa) (e := ea) vxa vea va₂, .mul (x := xb) (e := eb) vxb veb vb₂ => Id.run do
    if vxa.eq vxb then
      if let some (.nonzero ⟨_, ve, pe⟩) := evalAddOverlap sℕ vea veb then
        let ⟨_, vc, pc⟩ := evalMulProd va₂ vb₂
        return ⟨_, .mul vxa ve vc, (q(mul_pp_pf_overlap $xa $pe $pc) : Expr)⟩
    if let .lt := (vxa.cmp vxb).then (vea.cmp veb) then
      let ⟨_, vc, pc⟩ := evalMulProd va₂ vb
      ⟨_, .mul vxa vea vc, (q(mul_pf_left $xa $ea $pc) : Expr)⟩
    else
      let ⟨_, vc, pc⟩ := evalMulProd va vb₂
      ⟨_, .mul vxb veb vc, (q(mul_pf_right $xb $eb $pc) : Expr)⟩

theorem mul_zero (a : R) : a * 0 = 0 := by simp

theorem mul_add (_ : (a : R) * b₁ = c₁) (_ : a * b₂ = c₂) (_ : c₁ + 0 + c₂ = d) :
    a * (b₁ + b₂) = d := by subst_vars; simp [_root_.mul_add]

/-- Multiplies a monomial `va` to a polynomial `vb` to get a normalized result polynomial.

* `a * 0 = 0`
* `a * (b₁ + b₂) = (a * b₁) + (a * b₂)`
-/
def evalMul₁ (va : ExProd sα a) (vb : ExSum sα b) : Result (ExSum sα) q($a * $b) :=
  match vb with
  | .zero => ⟨_, .zero, q(mul_zero $a)⟩
  | .add vb₁ vb₂ =>
    let ⟨_, vc₁, pc₁⟩ := evalMulProd sα va vb₁
    let ⟨_, vc₂, pc₂⟩ := evalMul₁ va vb₂
    let ⟨_, vd, pd⟩ := evalAdd sα vc₁.toSum vc₂
    ⟨_, vd, q(mul_add $pc₁ $pc₂ $pd)⟩

theorem zero_mul (b : R) : 0 * b = 0 := by simp

theorem add_mul (_ : (a₁ : R) * b = c₁) (_ : a₂ * b = c₂) (_ : c₁ + c₂ = d) :
    (a₁ + a₂) * b = d := by subst_vars; simp [_root_.add_mul]

/-- Multiplies two polynomials `va, vb` together to get a normalized result polynomial.

* `0 * b = 0`
* `(a₁ + a₂) * b = (a₁ * b) + (a₂ * b)`
-/
def evalMul (va : ExSum sα a) (vb : ExSum sα b) : Result (ExSum sα) q($a * $b) :=
  match va with
  | .zero => ⟨_, .zero, q(zero_mul $b)⟩
  | .add va₁ va₂ =>
    let ⟨_, vc₁, pc₁⟩ := evalMul₁ sα va₁ vb
    let ⟨_, vc₂, pc₂⟩ := evalMul va₂ vb
    let ⟨_, vd, pd⟩ := evalAdd sα vc₁ vc₂
    ⟨_, vd, q(add_mul $pc₁ $pc₂ $pd)⟩

theorem natCast_nat (n) : ((Nat.rawCast n : ℕ) : R) = Nat.rawCast n := by simp

theorem natCast_mul (a₂) (_ : ((a₁ : ℕ) : R) = b₁) (_ : ((a₃ : ℕ) : R) = b₃) :
    ((a₁ ^ a₂ * a₃ : ℕ) : R) = b₁ ^ a₂ * b₃ := by subst_vars; simp

theorem natCast_zero : ((0 : ℕ) : R) = 0 := Nat.cast_zero

theorem natCast_add (_ : ((a₁ : ℕ) : R) = b₁) (_ : ((a₂ : ℕ) : R) = b₂) :
    ((a₁ + a₂ : ℕ) : R) = b₁ + b₂ := by subst_vars; simp

mutual

/-- Applies `Nat.cast` to a nat polynomial to produce a polynomial in `α`.

* An atom `e` causes `↑e` to be allocated as a new atom.
* A sum delegates to `ExSum.evalNatCast`.
-/
partial def ExBase.evalNatCast (va : ExBase sℕ a) : AtomM (Result (ExBase sα) q($a)) :=
  match va with
  | .atom _ => do
    let a' : Q($α) := q($a)
    let i ← addAtom a'
    pure ⟨a', ExBase.atom i, (q(Eq.refl $a') : Expr)⟩
  | .sum va => do
    let ⟨_, vc, p⟩ ← va.evalNatCast
    pure ⟨_, .sum vc, p⟩

/-- Applies `Nat.cast` to a nat monomial to produce a monomial in `α`.

* `↑c = c` if `c` is a numeric literal
* `↑(a ^ n * b) = ↑a ^ n * ↑b`
-/
partial def ExProd.evalNatCast (va : ExProd sℕ a) : AtomM (Result (ExProd sα) q($a)) :=
  match va with
  | .const c hc =>
    have n : Q(ℕ) := a.appArg!
    pure ⟨q(Nat.rawCast $n), .const c hc, (q(natCast_nat (R := $α) $n) : Expr)⟩
  | .mul (e := a₂) va₁ va₂ va₃ => do
    let ⟨_, vb₁, pb₁⟩ ← va₁.evalNatCast
    let ⟨_, vb₃, pb₃⟩ ← va₃.evalNatCast
    pure ⟨_, .mul vb₁ va₂ vb₃, q(natCast_mul $a₂ $pb₁ $pb₃)⟩

/-- Applies `Nat.cast` to a nat polynomial to produce a polynomial in `α`.

* `↑0 = 0`
* `↑(a + b) = ↑a + ↑b`
-/
partial def ExSum.evalNatCast (va : ExSum sℕ a) : AtomM (Result (ExSum sα) q($a)) :=
  match va with
  | .zero => pure ⟨_, .zero, q(natCast_zero (R := $α))⟩
  | .add va₁ va₂ => do
    let ⟨_, vb₁, pb₁⟩ ← va₁.evalNatCast
    let ⟨_, vb₂, pb₂⟩ ← va₂.evalNatCast
    pure ⟨_, .add vb₁ vb₂, q(natCast_add $pb₁ $pb₂)⟩

end

theorem smul_nat (_ : (a * b : ℕ) = c) : a • b = c := by subst_vars; simp

theorem smul_eq_cast (_ : ((a : ℕ) : R) = a') (_ : a' * b = c) : a • b = c := by subst_vars; simp

/-- Constructs the scalar multiplication `n • a`, where both `n : ℕ` and `a : α` are normalized
polynomial expressions.

* `a • b = a * b` if `α = ℕ`
* `a • b = ↑a * b` otherwise
-/
def evalNSMul (va : ExSum sℕ a) (vb : ExSum sα b) : AtomM (Result (ExSum sα) q($a • $b)) := do
  if ← isDefEq sα sℕ then
    let ⟨_, va'⟩ := va.cast
    have _b : Q(ℕ) := b
    let ⟨(_c : Q(ℕ)), vc, (pc : Q($a * $_b = $_c))⟩ := evalMul sα va' vb
    pure ⟨_, vc, (q(smul_nat $pc) : Expr)⟩
  else
    let ⟨_, va', pa'⟩ ← va.evalNatCast sα
    let ⟨_, vc, pc⟩ := evalMul sα va' vb
    pure ⟨_, vc, (q(smul_eq_cast $pa' $pc) : Expr)⟩

theorem neg_one_mul {R} [Ring R] {a b : R} (_ : (Int.negOfNat (nat_lit 1)).rawCast * a = b) :
    -a = b := by subst_vars; simp [Int.negOfNat]

theorem neg_mul {R} [Ring R] (a₁ : R) (a₂) {a₃ b : R}
    (_ : -a₃ = b) : -(a₁ ^ a₂ * a₃) = a₁ ^ a₂ * b := by subst_vars; simp

/-- Negates a monomial `va` to get another monomial.

* `-c = (-c)` (for `c` coefficient)
* `-(a₁ * a₂) = a₁ * -a₂`
-/
def evalNegProd (rα : Q(Ring $α)) (va : ExProd sα a) : Result (ExProd sα) q(-$a) :=
  match va with
  | .const za ha =>
    let lit : Q(ℕ) := mkRawNatLit 1
    let ⟨m1, _⟩ := ExProd.mkNegNat sα rα 1
    let rm := Result.isNegNat rα lit (q(IsInt.of_raw $α (.negOfNat $lit)) : Expr)
    let ra := Result.ofRawRat za a ha
    let rb := (NormNum.evalMul.core q($m1 * $a) _ _ q(CommSemiring.toSemiring) rm ra).get!
    let ⟨zb, hb⟩ := rb.toRatNZ.get!
    let ⟨b, (pb : Q((Int.negOfNat (nat_lit 1)).rawCast * $a = $b))⟩ :=  rb.toRawEq
    ⟨b, .const zb hb, (q(neg_one_mul (R := $α) $pb) : Expr)⟩
  | .mul (x := a₁) (e := a₂) va₁ va₂ va₃ =>
    let ⟨_, vb, pb⟩ := evalNegProd rα va₃
    ⟨_, .mul va₁ va₂ vb, (q(neg_mul $a₁ $a₂ $pb) : Expr)⟩

theorem neg_zero {R} [Ring R] : -(0 : R) = 0 := by simp

theorem neg_add {R} [Ring R] {a₁ a₂ b₁ b₂ : R}
    (_ : -a₁ = b₁) (_ : -a₂ = b₂) : -(a₁ + a₂) = b₁ + b₂ := by subst_vars; simp [add_comm]

/-- Negates a polynomial `va` to get another polynomial.

* `-0 = 0` (for `c` coefficient)
* `-(a₁ + a₂) = -a₁ + -a₂`
-/
def evalNeg (rα : Q(Ring $α)) (va : ExSum sα a) : Result (ExSum sα) q(-$a) :=
  match va with
  | .zero => ⟨_, .zero, (q(neg_zero (R := $α)) : Expr)⟩
  | .add va₁ va₂ =>
    let ⟨_, vb₁, pb₁⟩ := evalNegProd sα rα va₁
    let ⟨_, vb₂, pb₂⟩ := evalNeg rα va₂
    ⟨_, .add vb₁ vb₂, (q(neg_add $pb₁ $pb₂) : Expr)⟩

theorem sub_pf {R} [Ring R] {a b c d : R}
    (_ : -b = c) (_ : a + c = d) : a - b = d := by subst_vars; simp [sub_eq_add_neg]

/-- Subtracts two polynomials `va, vb` to get a normalized result polynomial.

* `a - b = a + -b`
-/
def evalSub (rα : Q(Ring $α)) (va : ExSum sα a) (vb : ExSum sα b) : Result (ExSum sα) q($a - $b) :=
  let ⟨_c, vc, pc⟩ := evalNeg sα rα vb
  let ⟨d, vd, (pd : Q($a + $_c = $d))⟩ := evalAdd sα va vc
  ⟨d, vd, (q(sub_pf $pc $pd) : Expr)⟩

theorem pow_prod_atom (a : R) (b) : a ^ b = (a + 0) ^ b * (nat_lit 1).rawCast := by simp

/--
The fallback case for exponentiating polynomials is to use `ExBase.toProd` to just build an
exponent expression. (This has a slightly different normalization than `evalPowAtom` because
the input types are different.)

* `x ^ e = (x + 0) ^ e * 1`
-/
def evalPowProdAtom (va : ExProd sα a) (vb : ExProd sℕ b) : Result (ExProd sα) q($a ^ $b) :=
  ⟨_, (ExBase.sum va.toSum).toProd vb, q(pow_prod_atom $a $b)⟩

theorem pow_atom (a : R) (b) : a ^ b = a ^ b * (nat_lit 1).rawCast + 0 := by simp

/--
The fallback case for exponentiating polynomials is to use `ExBase.toProd` to just build an
exponent expression.

* `x ^ e = x ^ e * 1 + 0`
-/
def evalPowAtom (va : ExBase sα a) (vb : ExProd sℕ b) : Result (ExSum sα) q($a ^ $b) :=
  ⟨_, (va.toProd vb).toSum, q(pow_atom $a $b)⟩

theorem const_pos (n : ℕ) (h : Nat.ble 1 n = true) : 0 < (n.rawCast : ℕ) := Nat.le_of_ble_eq_true h

theorem mul_exp_pos (n) (h₁ : 0 < a₁) (h₂ : 0 < a₂) : 0 < a₁ ^ n * a₂ :=
  Nat.mul_pos (Nat.pos_pow_of_pos _ h₁) h₂

theorem add_pos_left (a₂) (h : 0 < a₁) : 0 < a₁ + a₂ := Nat.lt_of_lt_of_le h (Nat.le_add_right ..)

theorem add_pos_right (a₁) (h : 0 < a₂) : 0 < a₁ + a₂ := Nat.lt_of_lt_of_le h (Nat.le_add_left ..)

mutual

/-- Attempts to prove that a polynomial expression in `ℕ` is positive.

* Atoms are not (necessarily) positive
* Sums defer to `ExSum.evalPos`
-/
partial def ExBase.evalPos (va : ExBase sℕ a) : Option Q(0 < $a) :=
  match va with
  | .atom _ => none
  | .sum va => va.evalPos

/-- Attempts to prove that a monomial expression in `ℕ` is positive.

* `0 < c` (where `c` is a numeral) is true by the normalization invariant (`c` is not zero)
* `0 < x ^ e * b` if `0 < x` and `0 < b`
-/
partial def ExProd.evalPos (va : ExProd sℕ a) : Option Q(0 < $a) :=
  match va with
  | .const _ _ =>
    -- it must be positive because it is a nonzero nat literal
    have lit : Q(ℕ) := a.appArg!
    let p : Q(Nat.ble 1 $lit = true) := (q(Eq.refl true) : Expr)
    some (q(const_pos $lit $p) : Expr)
  | .mul (e := ea₁) vxa₁ _ va₂ => do
    let pa₁ ← vxa₁.evalPos
    let pa₂ ← va₂.evalPos
    some q(mul_exp_pos $ea₁ $pa₁ $pa₂)

/-- Attempts to prove that a polynomial expression in `ℕ` is positive.

* `0 < 0` fails
* `0 < a + b` if `0 < a` or `0 < b`
-/
partial def ExSum.evalPos (va : ExSum sℕ a) : Option Q(0 < $a) :=
  match va with
  | .zero => none
  | .add (a := a₁) (b := a₂) va₁ va₂ => do
    match va₁.evalPos with
    | some p => some q(add_pos_left $a₂ $p)
    | none => let p ← va₂.evalPos; some q(add_pos_right $a₁ $p)

end

theorem pow_one (a : R) : a ^ nat_lit 1 = a := by simp

theorem pow_bit0 (_ : (a : R) ^ k = b) (_ : b * b = c) : a ^ (Nat.mul (nat_lit 2) k) = c := by
  subst_vars; simp [Nat.succ_mul, pow_add]

theorem pow_bit1 (_ : (a : R) ^ k = b) (_ : b * b = c) (_ : c * a = d) :
    a ^ (Nat.add (Nat.mul (nat_lit 2) k) (nat_lit 1)) = d := by
  subst_vars; simp [Nat.succ_mul, pow_add]

/--
The main case of exponentiation of ring expressions is when `va` is a polynomial and `n` is a
nonzero literal expression, like `(x + y)^5`. In this case we work out the polynomial completely
into a sum of monomials.

* `x ^ 1 = x`
* `x ^ (2*n) = x ^ n * x ^ n`
* `x ^ (2*n+1) = x ^ n * x ^ n * x`
-/
partial def evalPowNat (va : ExSum sα a) (n : Q(ℕ)) : Result (ExSum sα) q($a ^ $n) :=
  let nn := n.natLit!
  if nn = 1 then
    ⟨_, va, (q(pow_one $a) : Expr)⟩
  else
    let nm := nn >>> 1
    have m : Q(ℕ) := mkRawNatLit nm
    if nn &&& 1 = 0 then
      let ⟨_, vb, pb⟩ := evalPowNat va m
      let ⟨_, vc, pc⟩ := evalMul sα vb vb
      ⟨_, vc, (q(pow_bit0 $pb $pc) : Expr)⟩
    else
      let ⟨_, vb, pb⟩ := evalPowNat va m
      let ⟨_, vc, pc⟩ := evalMul sα vb vb
      let ⟨_, vd, pd⟩ := evalMul sα vc va
      ⟨_, vd, (q(pow_bit1 $pb $pc $pd) : Expr)⟩

theorem one_pow (b : ℕ) : ((nat_lit 1).rawCast : R) ^ b = (nat_lit 1).rawCast := by simp

theorem mul_pow (_ : ea₁ * b = c₁) (_ : a₂ ^ b = c₂) :
    (xa₁ ^ ea₁ * a₂ : R) ^ b = xa₁ ^ c₁ * c₂ := by subst_vars; simp [_root_.mul_pow, pow_mul]

/-- There are several special cases when exponentiating monomials:

* `1 ^ n = 1`
* `x ^ y = (x ^ y)` when `x` and `y` are constants
* `(a * b) ^ e = a ^ e * b ^ e`

In all other cases we use `evalPowProdAtom`.
-/
def evalPowProd (va : ExProd sα a) (vb : ExProd sℕ b) : Result (ExProd sα) q($a ^ $b) :=
  let res : Option (Result (ExProd sα) q($a ^ $b)) := do
    match va, vb with
    | .const 1, _ => some ⟨_, va, (q(one_pow (R := $α) $b) : Expr)⟩
    | .const za ha, .const zb hb =>
      assert! 0 ≤ zb
      let ra := Result.ofRawRat za a ha
      have lit : Q(ℕ) := b.appArg!
      let rb := (q(IsNat.of_raw ℕ $lit) : Expr)
      let rc ← NormNum.evalPow.core q($a ^ $b) _ b lit rb q(CommSemiring.toSemiring) ra
      let ⟨zc, hc⟩ ← rc.toRatNZ
      let ⟨c, pc⟩ := rc.toRawEq
      some ⟨c, .const zc hc, pc⟩
    | .mul vxa₁ vea₁ va₂, vb => do
      let ⟨_, vc₁, pc₁⟩ := evalMulProd sℕ vea₁ vb
      let ⟨_, vc₂, pc₂⟩ := evalPowProd va₂ vb
      some ⟨_, .mul vxa₁ vc₁ vc₂, q(mul_pow $pc₁ $pc₂)⟩
    | _, _ => none
  res.getD (evalPowProdAtom sα va vb)

/--
The result of `extractCoeff` is a numeral and a proof that the original expression
factors by this numeral.
-/
structure ExtractCoeff (e : Q(ℕ)) where
  /-- A raw natural number literal. -/
  k : Q(ℕ)
  /-- The result of extracting the coefficient is a monic monomial. -/
  e' : Q(ℕ)
  /-- `e'` is a monomial. -/
  ve' : ExProd sℕ e'
  /-- The proof that `e` splits into the coefficient `k` and the monic monomial `e'`. -/
  p : Q($e = $e' * $k)

theorem coeff_one (k : ℕ) : k.rawCast = (nat_lit 1).rawCast * k := by simp

theorem coeff_mul (a₁ a₂ : ℕ) (_ : a₃ = c₂ * k) : a₁ ^ a₂ * a₃ = (a₁ ^ a₂ * c₂) * k := by
  subst_vars; rw [mul_assoc]

/-- Given a monomial expression `va`, splits off the leading coefficient `k` and the remainder
`e'`, stored in the `ExtractCoeff` structure.

* `c = 1 * c` (if `c` is a constant)
* `a * b = (a * b') * k` if `b = b' * k`
-/
def extractCoeff (va : ExProd sℕ a) : ExtractCoeff a :=
  match va with
  | .const _ _ =>
    have k : Q(ℕ) := a.appArg!
    ⟨k, q((nat_lit 1).rawCast), .const 1, (q(coeff_one $k) : Expr)⟩
  | .mul (x := a₁) (e := a₂) va₁ va₂ va₃ =>
    let ⟨k, _, vc, pc⟩ := extractCoeff va₃
    ⟨k, _, .mul va₁ va₂ vc, q(coeff_mul $a₁ $a₂ $pc)⟩

theorem pow_one_cast (a : R) : a ^ (nat_lit 1).rawCast = a := by simp

theorem zero_pow (_ : 0 < b) : (0 : R) ^ b = 0 := match b with | b+1 => by simp [pow_succ]

theorem single_pow (_ : (a : R) ^ b = c) : (a + 0) ^ b = c + 0 := by simp [*]

theorem pow_nat (_ : b = c * k) (_ : a ^ c = d) (_ : d ^ k = e) : (a : R) ^ b = e := by
  subst_vars; simp [pow_mul]

/-- Exponentiates a polynomial `va` by a monomial `vb`, including several special cases.

* `a ^ 1 = a`
* `0 ^ e = 0` if `0 < e`
* `(a + 0) ^ b = a ^ b` computed using `evalPowProd`
* `a ^ b = (a ^ b') ^ k` if `b = b' * k` and `k > 1`

Otherwise `a ^ b` is just encoded as `a ^ b * 1 + 0` using `evalPowAtom`.
-/
partial def evalPow₁ (va : ExSum sα a) (vb : ExProd sℕ b) : Result (ExSum sα) q($a ^ $b) :=
  match va, vb with
  | _, .const 1 => ⟨_, va, (q(pow_one_cast $a) : Expr)⟩
  | .zero, vb => match vb.evalPos with
    | some p => ⟨_, .zero, q(zero_pow (R := $α) $p)⟩
    | none => evalPowAtom sα (.sum .zero) vb
  | ExSum.add va .zero, vb => -- TODO: using `.add` here takes a while to compile?
    let ⟨_, vc, pc⟩ := evalPowProd sα va vb
    ⟨_, vc.toSum, q(single_pow $pc)⟩
  | va, vb =>
    if vb.coeff > 1 then
      let ⟨k, _, vc, pc⟩ := extractCoeff vb
      let ⟨_, vd, pd⟩ := evalPow₁ va vc
      let ⟨_, ve, pe⟩ := evalPowNat sα vd k
      ⟨_, ve, q(pow_nat $pc $pd $pe)⟩
    else evalPowAtom sα (.sum va) vb

theorem pow_zero (a : R) : a ^ 0 = (nat_lit 1).rawCast + 0 := by simp

/-- Exponentiates two polynomials `va, vb`.

* `a ^ 0 = 1`
* `a ^ (b₁ + b₂) = a ^ b₁ * a ^ b₂`
-/
def evalPow (va : ExSum sα a) (vb : ExSum sℕ b) : Result (ExSum sα) q($a ^ $b) :=
  match vb with
  | .zero => ⟨_, (ExProd.mkNat sα 1).2.toSum, q(pow_zero $a)⟩
  | .add vb₁ vb₂ =>
    let ⟨_, vc₁, pc₁⟩ := evalPow₁ sα va vb₁
    let ⟨_, vc₂, pc₂⟩ := evalPow va vb₂
    let ⟨_, vd, pd⟩ := evalMul sα vc₁ vc₂
    ⟨_, vd, q(pow_add $pc₁ $pc₂ $pd)⟩

/-- This cache contains data required by the `ring` tactic during execution. -/
structure Cache {α : Q(Type u)} (sα : Q(CommSemiring $α)) :=
  /-- A ring instance on `α`, if available. -/
  rα : Option Q(Ring $α)
  /-- A division ring instance on `α`, if available. -/
  dα : Option Q(DivisionRing $α)
  /-- A characteristic zero ring instance on `α`, if available. -/
  czα : Option Q(CharZero $α)

/-- Create a new cache for `α` by doing the necessary instance searches. -/
def mkCache {α : Q(Type u)} (sα : Q(CommSemiring $α)) : MetaM (Cache sα) :=
  return {
    rα := (← trySynthInstanceQ (q(Ring $α) : Q(Type u))).toOption
    dα := (← trySynthInstanceQ (q(DivisionRing $α) : Q(Type u))).toOption
    czα := (← trySynthInstanceQ (q(CharZero $α) : Q(Prop))).toOption }

theorem cast_pos : IsNat (a : R) n → a = n.rawCast + 0
  | ⟨e⟩ => by simp [e]

theorem cast_zero : IsNat (a : R) (nat_lit 0) → a = 0
  | ⟨e⟩ => by simp [e]

theorem cast_neg {R} [Ring R] {a : R} : IsInt a (.negOfNat n) → a = (Int.negOfNat n).rawCast + 0
  | ⟨e⟩ => by simp [e]

theorem cast_rat {R} [DivisionRing R] {a : R} : IsRat a n d → a = Rat.rawCast n d + 0
  | ⟨_, e⟩ => by simp [e, div_eq_mul_inv]

/-- Converts a proof by `norm_num` that `e` is a numeral, into a normalization as a monomial:

* `e = 0` if `norm_num` returns `IsNat e 0`
* `e = Nat.rawCast n + 0` if `norm_num` returns `IsNat e n`
* `e = Int.rawCast n + 0` if `norm_num` returns `IsInt e n`
* `e = Rat.rawCast n d + 0` if `norm_num` returns `IsRat e n d`
-/
def evalCast : NormNum.Result e → Option (Result (ExSum sα) e)
  | .isNat _ (.lit (.natVal 0)) p => do
    assumeInstancesCommute
    pure ⟨_, .zero, q(cast_zero $p)⟩
  | .isNat _ lit p => do
    assumeInstancesCommute
    pure ⟨_, (ExProd.mkNat sα lit.natLit!).2.toSum, (q(cast_pos $p) :)⟩
  | .isNegNat rα lit p =>
    pure ⟨_, (ExProd.mkNegNat _ rα lit.natLit!).2.toSum, (q(cast_neg $p) : Expr)⟩
  | .isRat dα q n d p =>
    pure ⟨_, (ExProd.mkRat sα dα q n d q(IsRat.den_nz $p)).2.toSum, (q(cast_rat $p) : Expr)⟩
  | _ => none

theorem toProd_pf (p : (a : R) = a') :
    a = a' ^ (nat_lit 1).rawCast * (nat_lit 1).rawCast := by simp [*]
theorem atom_pf (a : R) : a = a ^ (nat_lit 1).rawCast * (nat_lit 1).rawCast + 0 := by simp
theorem atom_pf' (p : (a : R) = a') :
    a = a' ^ (nat_lit 1).rawCast * (nat_lit 1).rawCast + 0 := by simp [*]

/--
Evaluates an atom, an expression where `ring` can find no additional structure.

* `a = a ^ 1 * 1 + 0`
-/
def evalAtom (e : Q($α)) : AtomM (Result (ExSum sα) e) := do
  let r ← (← read).evalAtom e
  have e' : Q($α) := r.expr
  let i ← addAtom e'
  let ve' := (ExBase.atom i (e := e')).toProd (ExProd.mkNat sℕ 1).2 |>.toSum
  pure ⟨_, ve', match r.proof? with
  | none => (q(atom_pf $e) : Expr)
  | some (p : Q($e = $e')) => (q(atom_pf' $p) : Expr)⟩

theorem inv_mul {R} [DivisionRing R] {a₁ a₂ a₃ b₁ b₃ c}
    (_ : (a₁⁻¹ : R) = b₁) (_ : (a₃⁻¹ : R) = b₃)
    (_ : b₃ * (b₁ ^ a₂ * (nat_lit 1).rawCast) = c) :
    (a₁ ^ a₂ * a₃ : R)⁻¹ = c := by subst_vars; simp

nonrec theorem inv_zero {R} [DivisionRing R] : (0 : R)⁻¹ = 0 := inv_zero

theorem inv_single {R} [DivisionRing R] {a b : R}
    (_ : (a : R)⁻¹ = b) : (a + 0)⁻¹ = b + 0 := by simp [*]

theorem inv_add (_ : ((a₁ : ℕ) : R) = b₁) (_ : ((a₂ : ℕ) : R) = b₂) :
    ((a₁ + a₂ : ℕ) : R) = b₁ + b₂ := by subst_vars; simp

section
variable (dα : Q(DivisionRing $α))

/-- Applies `⁻¹` to a polynomial to get an atom. -/
def evalInvAtom (a : Q($α)) : AtomM (Result (ExBase sα) q($a⁻¹)) := do
  let a' : Q($α) := q($a⁻¹)
  let i ← addAtom a'
  pure ⟨a', ExBase.atom i, (q(Eq.refl $a') : Expr)⟩

/-- Inverts a polynomial `va` to get a normalized result polynomial.

* `c⁻¹ = (c⁻¹)` if `c` is a constant
* `(a ^ b * c)⁻¹ = a⁻¹ ^ b * c⁻¹`
-/
def ExProd.evalInv (czα : Option Q(CharZero $α)) (va : ExProd sα a) :
    AtomM (Result (ExProd sα) q($a⁻¹)) := do
  match va with
  | .const c hc =>
    let ra := Result.ofRawRat c a hc
    match NormNum.evalInv.core q($a⁻¹) a ra dα czα with
    | some rc =>
      let ⟨zc, hc⟩ := rc.toRatNZ.get!
      let ⟨c, pc⟩ := rc.toRawEq
      pure ⟨c, .const zc hc, pc⟩
    | none =>
      let ⟨_, vc, pc⟩ ← evalInvAtom sα dα a
      pure ⟨_, vc.toProd (ExProd.mkNat sℕ 1).2, q(toProd_pf $pc)⟩
  | .mul (x := a₁) (e := _a₂) _va₁ va₂ va₃ => do
    let ⟨_b₁, vb₁, pb₁⟩ ← evalInvAtom sα dα a₁
    let ⟨_b₃, vb₃, pb₃⟩ ← va₃.evalInv czα
    let ⟨c, vc, (pc : Q($_b₃ * ($_b₁ ^ $_a₂ * Nat.rawCast 1) = $c))⟩ :=
      evalMulProd sα vb₃ (vb₁.toProd va₂)
    pure ⟨c, vc, (q(inv_mul $pb₁ $pb₃ $pc) : Expr)⟩

/-- Inverts a polynomial `va` to get a normalized result polynomial.

* `0⁻¹ = 0`
* `a⁻¹ = (a⁻¹)` if `a` is a nontrivial sum
-/
def ExSum.evalInv (czα : Option Q(CharZero $α)) (va : ExSum sα a) :
    AtomM (Result (ExSum sα) q($a⁻¹)) :=
  match va with
  | ExSum.zero => pure ⟨_, .zero, (q(inv_zero (R := $α)) : Expr)⟩
  | ExSum.add va ExSum.zero => do
    let ⟨_, vb, pb⟩ ← va.evalInv dα czα
    pure ⟨_, vb.toSum, (q(inv_single $pb) : Expr)⟩
  | va => do
    let ⟨_, vb, pb⟩ ← evalInvAtom sα dα a
    pure ⟨_, vb.toProd (ExProd.mkNat sℕ 1).2 |>.toSum, q(atom_pf' $pb)⟩

end

theorem div_pf {R} [DivisionRing R] {a b c d : R}
    (_ : b⁻¹ = c) (_ : a * c = d) : a / b = d := by subst_vars; simp [div_eq_mul_inv]

/-- Divides two polynomials `va, vb` to get a normalized result polynomial.

* `a / b = a * b⁻¹`
-/
def evalDiv (rα : Q(DivisionRing $α)) (czα : Option Q(CharZero $α)) (va : ExSum sα a)
    (vb : ExSum sα b) : AtomM (Result (ExSum sα) q($a / $b)) := do
  let ⟨_c, vc, pc⟩ ← vb.evalInv sα rα czα
  let ⟨d, vd, (pd : Q($a * $_c = $d))⟩ := evalMul sα va vc
  pure ⟨d, vd, (q(div_pf $pc $pd) : Expr)⟩

theorem add_congr (_ : a = a') (_ : b = b')
    (_ : a' + b' = c) : (a + b : R) = c := by subst_vars; rfl

theorem mul_congr (_ : a = a') (_ : b = b')
    (_ : a' * b' = c) : (a * b : R) = c := by subst_vars; rfl

theorem nsmul_congr (_ : (a : ℕ) = a') (_ : b = b')
    (_ : a' • b' = c) : (a • (b : R)) = c := by subst_vars; rfl

theorem pow_congr (_ : a = a') (_ : b = b')
    (_ : a' ^ b' = c) : (a ^ b : R) = c := by subst_vars; rfl

theorem neg_congr {R} [Ring R] {a a' b : R} (_ : a = a')
    (_ : -a' = b) : (-a : R) = b := by subst_vars; rfl

theorem sub_congr {R} [Ring R] {a a' b b' c : R} (_ : a = a') (_ : b = b')
    (_ : a' - b' = c) : (a - b : R) = c := by subst_vars; rfl

theorem inv_congr {R} [DivisionRing R] {a a' b : R} (_ : a = a')
    (_ : a'⁻¹ = b) : (a⁻¹ : R) = b := by subst_vars; rfl

theorem div_congr {R} [DivisionRing R] {a a' b b' c : R} (_ : a = a') (_ : b = b')
    (_ : a' / b' = c) : (a / b : R) = c := by subst_vars; rfl

/-- A precomputed `Cache` for `ℕ`. -/
def Cache.nat : Cache sℕ := { rα := none, dα := none, czα := some q(inferInstance) }

/-- Checks whether `e` would be processed by `eval` as a ring expression,
or otherwise if it is an atom or something simplifiable via `norm_num`.

We use this in `ring_nf` to avoid rewriting atoms unnecessarily.

Returns:
* `none` if `eval` would process `e` as an algebraic ring expression
* `some none` if `eval` would treat `e` as an atom.
* `some (some r)` if `eval` would not process `e` as an algebraic ring expression,
  but `NormNum.derive` can nevertheless simplify `e`, with result `r`.
-/
-- Note this is not the same as whether the result of `eval` is an atom. (e.g. consider `x + 0`.)
def isAtomOrDerivable {u} {α : Q(Type u)} (sα : Q(CommSemiring $α))
    (c : Cache sα) (e : Q($α)) : AtomM (Option (Option (Result (ExSum sα) e))) := do
  let els := try
      pure <| some (evalCast sα (← derive e))
    catch _ => pure (some none)
  let .const n _ := (← withReducible <| whnf e).getAppFn | els
  match n, c.rα, c.dα with
  | ``HAdd.hAdd, _, _ | ``Add.add, _, _
  | ``HMul.hMul, _, _ | ``Mul.mul, _, _
  | ``HSMul.hSMul, _, _
  | ``HPow.hPow, _, _ | ``Pow.pow, _, _
  | ``Neg.neg, some _, _
  | ``HSub.hSub, some _, _ | ``Sub.sub, some _, _
  | ``Inv.inv, _, some _
  | ``HDiv.hDiv, _, some _ | ``Div.div, _, some _ => pure none
  | _, _, _ => els

/--
Evaluates expression `e` of type `α` into a normalized representation as a polynomial.
This is the main driver of `ring`, which calls out to `evalAdd`, `evalMul` etc.
-/
partial def eval {u} {α : Q(Type u)} (sα : Q(CommSemiring $α))
    (c : Cache sα) (e : Q($α)) : AtomM (Result (ExSum sα) e) := Lean.withIncRecDepth do
  let els := do
    try evalCast sα (← derive e)
    catch _ => evalAtom sα e
  let .const n _ := (← withReducible <| whnf e).getAppFn | els
  match n, c.rα, c.dα with
  | ``HAdd.hAdd, _, _ | ``Add.add, _, _ => match e with
    | ~q($a + $b) =>
      let ⟨_, va, pa⟩ ← eval sα c a
      let ⟨_, vb, pb⟩ ← eval sα c b
      let ⟨c, vc, p⟩ := evalAdd sα va vb
      pure ⟨c, vc, (q(add_congr $pa $pb $p) : Expr)⟩
    | _ => els
  | ``HMul.hMul, _, _ | ``Mul.mul, _, _ => match e with
    | ~q($a * $b) =>
      let ⟨_, va, pa⟩ ← eval sα c a
      let ⟨_, vb, pb⟩ ← eval sα c b
      let ⟨c, vc, p⟩ := evalMul sα va vb
      pure ⟨c, vc, (q(mul_congr $pa $pb $p) : Expr)⟩
    | _ => els
  | ``HSMul.hSMul, _, _ => match e with
    | ~q(($a : ℕ) • ($b : «$α»)) =>
      let ⟨_, va, pa⟩ ← eval sℕ .nat a
      let ⟨_, vb, pb⟩ ← eval sα c b
      let ⟨c, vc, p⟩ ← evalNSMul sα va vb
      pure ⟨c, vc, (q(nsmul_congr $pa $pb $p) : Expr)⟩
    | _ => els
  | ``HPow.hPow, _, _ | ``Pow.pow, _, _ => match e with
    | ~q($a ^ $b) =>
      let ⟨_, va, pa⟩ ← eval sα c a
      let ⟨_, vb, pb⟩ ← eval sℕ .nat b
      let ⟨c, vc, p⟩ := evalPow sα va vb
      pure ⟨c, vc, (q(pow_congr $pa $pb $p) : Expr)⟩
    | _ => els
  | ``Neg.neg, some rα, _ => match e with
    | ~q(-$a) =>
      let ⟨_, va, pa⟩ ← eval sα c a
      let ⟨b, vb, p⟩ := evalNeg sα rα va
      pure ⟨b, vb, (q(neg_congr $pa $p) : Expr)⟩
  | ``HSub.hSub, some rα, _ | ``Sub.sub, some rα, _ => match e with
    | ~q($a - $b) => do
      let ⟨_, va, pa⟩ ← eval sα c a
      let ⟨_, vb, pb⟩ ← eval sα c b
      let ⟨c, vc, p⟩ := evalSub sα rα va vb
      pure ⟨c, vc, (q(sub_congr $pa $pb $p) : Expr)⟩
    | _ => els
  | ``Inv.inv, _, some dα => match e with
    | ~q($a⁻¹) =>
      let ⟨_, va, pa⟩ ← eval sα c a
      let ⟨b, vb, p⟩ ← va.evalInv sα dα c.czα
      pure ⟨b, vb, (q(inv_congr $pa $p) : Expr)⟩
  | ``HDiv.hDiv, _, some dα | ``Div.div, _, some dα => match e with
    | ~q($a / $b) => do
      let ⟨_, va, pa⟩ ← eval sα c a
      let ⟨_, vb, pb⟩ ← eval sα c b
      let ⟨c, vc, p⟩ ← evalDiv sα dα c.czα va vb
      pure ⟨c, vc, (q(div_congr $pa $pb $p) : Expr)⟩
    | _ => els
  | _, _, _ => els

open Lean Parser.Tactic Elab Command Elab.Tactic Meta Qq

theorem of_eq (_ : (a : R) = c) (_ : b = c) : a = b := by subst_vars; rfl

/--
This is a routine which is used to clean up the unsolved subgoal
of a failed `ring1` application. It is overridden in `Mathlib.Tactic.Ring.RingNF`
to apply the `ring_nf` simp set to the goal.
-/
initialize ringCleanupRef : IO.Ref (Expr → MetaM Expr) ← IO.mkRef pure

/-- Frontend of `ring1`: attempt to close a goal `g`, assuming it is an equation of semirings. -/
def proveEq (g : MVarId) : AtomM Unit := do
  let some (α, e₁, e₂) := (← whnfR <|← instantiateMVars <|← g.getType).eq?
    | throwError "ring failed: not an equality"
  let .sort (.succ u) ← whnf (← inferType α) | throwError "not a type{indentExpr α}"
  have α : Q(Type u) := α
  have e₁ : Q($α) := e₁; have e₂ : Q($α) := e₂
  let sα ← synthInstanceQ (q(CommSemiring $α) : Q(Type u))
  let c ← mkCache sα
  profileitM Exception "ring" (← getOptions) do
    let ⟨a, va, pa⟩ ← eval sα c e₁
    let ⟨b, vb, pb⟩ ← eval sα c e₂
    unless va.eq vb do
      let g ← mkFreshExprMVar (← (← ringCleanupRef.get) q($a = $b))
      throwError "ring failed, ring expressions not equal\n{g.mvarId!}"
    let pb : Q($e₂ = $a) := pb
    g.assign q(of_eq $pa $pb)

/--
Tactic for solving equations of *commutative* (semi)rings,
allowing variables in the exponent.

* This version of `ring` fails if the target is not an equality.
* The variant `ring1!` will use a more aggressive reducibility setting
  to determine equality of atoms.
-/
elab (name := ring1) "ring1" tk:"!"? : tactic => liftMetaMAtMain fun g ↦ do
  AtomM.run (if tk.isSome then .default else .reducible) (proveEq g)

@[inherit_doc ring1] macro "ring1!" : tactic => `(tactic| ring1 !)