/-
Copyright (c) 2018 Mario Carneiro. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Mario Carneiro, Kenny Lau, Yury Kudryashov
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.data.list.pairwise
import Mathlib.logic.relation
import Mathlib.PostPort

universes u v

namespace Mathlib

namespace list

/- chain relation (conjunction of R a b ∧ R b c ∧ R c d ...) -/

theorem chain_iff {α : Type u} (R : α → α → Prop) :
    ∀ (ᾰ : α) (ᾰ_1 : List α),
        chain R ᾰ ᾰ_1 ↔
          ᾰ_1 = [] ∨
            Exists fun {b : α} => Exists fun {l : List α} => R ᾰ b ∧ chain R b l ∧ ᾰ_1 = b :: l :=
  sorry

theorem rel_of_chain_cons {α : Type u} {R : α → α → Prop} {a : α} {b : α} {l : List α}
    (p : chain R a (b :: l)) : R a b :=
  and.left (iff.mp chain_cons p)

theorem chain_of_chain_cons {α : Type u} {R : α → α → Prop} {a : α} {b : α} {l : List α}
    (p : chain R a (b :: l)) : chain R b l :=
  and.right (iff.mp chain_cons p)

theorem chain.imp' {α : Type u} {R : α → α → Prop} {S : α → α → Prop}
    (HRS : ∀ {a b : α}, R a b → S a b) {a : α} {b : α} (Hab : ∀ {c : α}, R a c → S b c) {l : List α}
    (p : chain R a l) : chain S b l :=
  sorry

theorem chain.imp {α : Type u} {R : α → α → Prop} {S : α → α → Prop}
    (H : ∀ (a b : α), R a b → S a b) {a : α} {l : List α} (p : chain R a l) : chain S a l :=
  chain.imp' H (H a) p

theorem chain.iff {α : Type u} {R : α → α → Prop} {S : α → α → Prop}
    (H : ∀ (a b : α), R a b ↔ S a b) {a : α} {l : List α} : chain R a l ↔ chain S a l :=
  { mp := chain.imp fun (a b : α) => iff.mp (H a b),
    mpr := chain.imp fun (a b : α) => iff.mpr (H a b) }

theorem chain.iff_mem {α : Type u} {R : α → α → Prop} {a : α} {l : List α} :
    chain R a l ↔ chain (fun (x y : α) => x ∈ a :: l ∧ y ∈ l ∧ R x y) a l :=
  sorry

theorem chain_singleton {α : Type u} {R : α → α → Prop} {a : α} {b : α} : chain R a [b] ↔ R a b :=
  sorry

theorem chain_split {α : Type u} {R : α → α → Prop} {a : α} {b : α} {l₁ : List α} {l₂ : List α} :
    chain R a (l₁ ++ b :: l₂) ↔ chain R a (l₁ ++ [b]) ∧ chain R b l₂ :=
  sorry

theorem chain_map {α : Type u} {β : Type v} {R : α → α → Prop} (f : β → α) {b : β} {l : List β} :
    chain R (f b) (map f l) ↔ chain (fun (a b : β) => R (f a) (f b)) b l :=
  sorry

theorem chain_of_chain_map {α : Type u} {β : Type v} {R : α → α → Prop} {S : β → β → Prop}
    (f : α → β) (H : ∀ (a b : α), S (f a) (f b) → R a b) {a : α} {l : List α}
    (p : chain S (f a) (map f l)) : chain R a l :=
  chain.imp H (iff.mp (chain_map f) p)

theorem chain_map_of_chain {α : Type u} {β : Type v} {R : α → α → Prop} {S : β → β → Prop}
    (f : α → β) (H : ∀ (a b : α), R a b → S (f a) (f b)) {a : α} {l : List α} (p : chain R a l) :
    chain S (f a) (map f l) :=
  iff.mpr (chain_map f) (chain.imp H p)

theorem chain_pmap_of_chain {α : Type u} {β : Type v} {R : α → α → Prop} {S : β → β → Prop}
    {p : α → Prop} {f : (a : α) → p a → β}
    (H : ∀ (a b : α) (ha : p a) (hb : p b), R a b → S (f a ha) (f b hb)) {a : α} {l : List α}
    (hl₁ : chain R a l) (ha : p a) (hl₂ : ∀ (a : α), a ∈ l → p a) :
    chain S (f a ha) (pmap f l hl₂) :=
  sorry

theorem chain_of_chain_pmap {α : Type u} {β : Type v} {R : α → α → Prop} {S : β → β → Prop}
    {p : α → Prop} (f : (a : α) → p a → β) {l : List α} (hl₁ : ∀ (a : α), a ∈ l → p a) {a : α}
    (ha : p a) (hl₂ : chain S (f a ha) (pmap f l hl₁))
    (H : ∀ (a b : α) (ha : p a) (hb : p b), S (f a ha) (f b hb) → R a b) : chain R a l :=
  sorry

theorem chain_of_pairwise {α : Type u} {R : α → α → Prop} {a : α} {l : List α}
    (p : pairwise R (a :: l)) : chain R a l :=
  sorry

theorem chain_iff_pairwise {α : Type u} {R : α → α → Prop} (tr : transitive R) {a : α}
    {l : List α} : chain R a l ↔ pairwise R (a :: l) :=
  sorry

theorem chain_iff_nth_le {α : Type u} {R : α → α → Prop} {a : α} {l : List α} :
    chain R a l ↔
        (∀ (h : 0 < length l), R a (nth_le l 0 h)) ∧
          ∀ (i : ℕ) (h : i < length l - 1),
            R (nth_le l i (nat.lt_of_lt_pred h)) (nth_le l (i + 1) (iff.mp nat.lt_pred_iff h)) :=
  sorry

theorem chain'.imp {α : Type u} {R : α → α → Prop} {S : α → α → Prop}
    (H : ∀ (a b : α), R a b → S a b) {l : List α} (p : chain' R l) : chain' S l :=
  list.cases_on l (fun (p : chain' R []) => trivial)
    (fun (l_hd : α) (l_tl : List α) (p : chain' R (l_hd :: l_tl)) => chain.imp H p) p

theorem chain'.iff {α : Type u} {R : α → α → Prop} {S : α → α → Prop}
    (H : ∀ (a b : α), R a b ↔ S a b) {l : List α} : chain' R l ↔ chain' S l :=
  { mp := chain'.imp fun (a b : α) => iff.mp (H a b),
    mpr := chain'.imp fun (a b : α) => iff.mpr (H a b) }

theorem chain'.iff_mem {α : Type u} {R : α → α → Prop} {l : List α} :
    chain' R l ↔ chain' (fun (x y : α) => x ∈ l ∧ y ∈ l ∧ R x y) l :=
  sorry

@[simp] theorem chain'_nil {α : Type u} {R : α → α → Prop} : chain' R [] := trivial

@[simp] theorem chain'_singleton {α : Type u} {R : α → α → Prop} (a : α) : chain' R [a] := chain.nil

theorem chain'_split {α : Type u} {R : α → α → Prop} {a : α} {l₁ : List α} {l₂ : List α} :
    chain' R (l₁ ++ a :: l₂) ↔ chain' R (l₁ ++ [a]) ∧ chain' R (a :: l₂) :=
  sorry

theorem chain'_map {α : Type u} {β : Type v} {R : α → α → Prop} (f : β → α) {l : List β} :
    chain' R (map f l) ↔ chain' (fun (a b : β) => R (f a) (f b)) l :=
  list.cases_on l (iff.refl (chain' R (map f []))) fun (l_hd : β) (l_tl : List β) => chain_map f

theorem chain'_of_chain'_map {α : Type u} {β : Type v} {R : α → α → Prop} {S : β → β → Prop}
    (f : α → β) (H : ∀ (a b : α), S (f a) (f b) → R a b) {l : List α} (p : chain' S (map f l)) :
    chain' R l :=
  chain'.imp H (iff.mp (chain'_map f) p)

theorem chain'_map_of_chain' {α : Type u} {β : Type v} {R : α → α → Prop} {S : β → β → Prop}
    (f : α → β) (H : ∀ (a b : α), R a b → S (f a) (f b)) {l : List α} (p : chain' R l) :
    chain' S (map f l) :=
  iff.mpr (chain'_map f) (chain'.imp H p)

theorem pairwise.chain' {α : Type u} {R : α → α → Prop} {l : List α} : pairwise R l → chain' R l :=
  sorry

theorem chain'_iff_pairwise {α : Type u} {R : α → α → Prop} (tr : transitive R) {l : List α} :
    chain' R l ↔ pairwise R l :=
  list.cases_on l (idRhs (True ↔ pairwise R []) (iff.symm (iff_true_intro pairwise.nil)))
    fun (l_hd : α) (l_tl : List α) =>
      idRhs (chain R l_hd l_tl ↔ pairwise R (l_hd :: l_tl)) (chain_iff_pairwise tr)

@[simp] theorem chain'_cons {α : Type u} {R : α → α → Prop} {x : α} {y : α} {l : List α} :
    chain' R (x :: y :: l) ↔ R x y ∧ chain' R (y :: l) :=
  chain_cons

theorem chain'.cons {α : Type u} {R : α → α → Prop} {x : α} {y : α} {l : List α} (h₁ : R x y)
    (h₂ : chain' R (y :: l)) : chain' R (x :: y :: l) :=
  iff.mpr chain'_cons { left := h₁, right := h₂ }

theorem chain'.tail {α : Type u} {R : α → α → Prop} {l : List α} (h : chain' R l) :
    chain' R (tail l) :=
  sorry

theorem chain'.rel_head {α : Type u} {R : α → α → Prop} {x : α} {y : α} {l : List α}
    (h : chain' R (x :: y :: l)) : R x y :=
  rel_of_chain_cons h

theorem chain'.rel_head' {α : Type u} {R : α → α → Prop} {x : α} {l : List α}
    (h : chain' R (x :: l)) {y : α} (hy : y ∈ head' l) : R x y :=
  chain'.rel_head
    (eq.mp (Eq._oldrec (Eq.refl (chain' R (x :: l))) (Eq.symm (cons_head'_tail hy))) h)

theorem chain'.cons' {α : Type u} {R : α → α → Prop} {x : α} {l : List α} :
    chain' R l → (∀ (y : α), y ∈ head' l → R x y) → chain' R (x :: l) :=
  sorry

theorem chain'_cons' {α : Type u} {R : α → α → Prop} {x : α} {l : List α} :
    chain' R (x :: l) ↔ (∀ (y : α), y ∈ head' l → R x y) ∧ chain' R l :=
  sorry

theorem chain'.append {α : Type u} {R : α → α → Prop} {l₁ : List α} {l₂ : List α} (h₁ : chain' R l₁)
    (h₂ : chain' R l₂) (h : ∀ (x : α), x ∈ last' l₁ → ∀ (y : α), y ∈ head' l₂ → R x y) :
    chain' R (l₁ ++ l₂) :=
  sorry

theorem chain'_pair {α : Type u} {R : α → α → Prop} {x : α} {y : α} : chain' R [x, y] ↔ R x y :=
  sorry

theorem chain'.imp_head {α : Type u} {R : α → α → Prop} {x : α} {y : α}
    (h : ∀ {z : α}, R x z → R y z) {l : List α} (hl : chain' R (x :: l)) : chain' R (y :: l) :=
  chain'.cons' (chain'.tail hl)
    fun (z : α) (hz : z ∈ head' (tail (x :: l))) => h (chain'.rel_head' hl hz)

theorem chain'_reverse {α : Type u} {R : α → α → Prop} {l : List α} :
    chain' R (reverse l) ↔ chain' (flip R) l :=
  sorry

theorem chain'_iff_nth_le {α : Type u} {R : α → α → Prop} {l : List α} :
    chain' R l ↔
        ∀ (i : ℕ) (h : i < length l - 1),
          R (nth_le l i (nat.lt_of_lt_pred h)) (nth_le l (i + 1) (iff.mp nat.lt_pred_iff h)) :=
  sorry

/-- If `l₁ l₂` and `l₃` are lists and `l₁ ++ l₂` and `l₂ ++ l₃` both satisfy
  `chain' R`, then so does `l₁ ++ l₂ ++ l₃` provided `l₂ ≠ []` -/
theorem chain'.append_overlap {α : Type u} {R : α → α → Prop} {l₁ : List α} {l₂ : List α}
    {l₃ : List α} (h₁ : chain' R (l₁ ++ l₂)) (h₂ : chain' R (l₂ ++ l₃)) (hn : l₂ ≠ []) :
    chain' R (l₁ ++ l₂ ++ l₃) :=
  sorry

/--
If `a` and `b` are related by the reflexive transitive closure of `r`, then there is a `r`-chain
starting from `a` and ending on `b`.
The converse of `relation_refl_trans_gen_of_exists_chain`.
-/
theorem exists_chain_of_relation_refl_trans_gen {α : Type u} {r : α → α → Prop} {a : α} {b : α}
    (h : relation.refl_trans_gen r a b) :
    ∃ (l : List α), chain r a l ∧ last (a :: l) (cons_ne_nil a l) = b :=
  sorry

/--
Given a chain from `a` to `b`, and a predicate true at `b`, if `r x y → p y → p x` then
the predicate is true everywhere in the chain and at `a`.
That is, we can propagate the predicate up the chain.
-/
theorem chain.induction {α : Type u} {r : α → α → Prop} {a : α} {b : α} (p : α → Prop) (l : List α)
    (h : chain r a l) (hb : last (a :: l) (cons_ne_nil a l) = b)
    (carries : ∀ {x y : α}, r x y → p y → p x) (final : p b) (i : α) (H : i ∈ a :: l) : p i :=
  sorry

/--
Given a chain from `a` to `b`, and a predicate true at `b`, if `r x y → p y → p x` then
the predicate is true at `a`.
That is, we can propagate the predicate all the way up the chain.
-/
theorem chain.induction_head {α : Type u} {r : α → α → Prop} {a : α} {b : α} (p : α → Prop)
    (l : List α) (h : chain r a l) (hb : last (a :: l) (cons_ne_nil a l) = b)
    (carries : ∀ {x y : α}, r x y → p y → p x) (final : p b) : p a :=
  chain.induction p l h hb carries final a (mem_cons_self a l)

/--
If there is an `r`-chain starting from `a` and ending at `b`, then `a` and `b` are related by the
reflexive transitive closure of `r`. The converse of `exists_chain_of_relation_refl_trans_gen`.
-/
theorem relation_refl_trans_gen_of_exists_chain {α : Type u} {r : α → α → Prop} {a : α} {b : α}
    (l : List α) (hl₁ : chain r a l) (hl₂ : last (a :: l) (cons_ne_nil a l) = b) :
    relation.refl_trans_gen r a b :=
  chain.induction_head (fun (_x : α) => relation.refl_trans_gen r _x b) l hl₁ hl₂
    (fun (x y : α) => relation.refl_trans_gen.head) relation.refl_trans_gen.refl

end Mathlib


import .global
universes  u

local notation `Ring` := CommRing.{u}
local notation `Set` :=  Type u

namespace Spec
variables (R : Ring)

def Spec   : Ring  ⥤ Set  :=
{
  obj :=  λ A : Ring ,   R ⟶  A,
  map :=  λ A B : Ring, λ ψ : A ⟶ B, λ ζ :  R ⟶ A,  ζ ≫ ψ,
}
lemma Spec.obj.ext (A : Ring) : (Spec R).obj A = (R ⟶ A) := rfl
lemma Spec.map.ext (A B : Ring)(ψ : A ⟶ B) (ζ : R ⟶ A): (Spec R).map ψ ζ =  ring_hom.comp ψ  ζ  := rfl

end Spec


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

! This file was ported from Lean 3 source module tactic.derive_fintype
! leanprover-community/mathlib commit 6ca1a09bc9aa75824bf97388c9e3b441fc4ccf3f
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.Data.Fintype.Basic

/-!
# Derive handler for `fintype` instances

This file introduces a derive handler to automatically generate `fintype`
instances for structures and inductives.

## Implementation notes

To construct a fintype instance, we need 3 things:

  1. A list `l` of elements
  2. A proof that `l` has no duplicates
  3. A proof that every element in the type is in `l`

Now fintype is defined as a finset which enumerates all elements, so steps (1) and (2) are
bundled together. It is possible to use finset operations that remove duplicates to avoid the need
to prove (2), but this adds unnecessary functions to the constructed term, which makes it more
expensive to compute the list, and it also adds a dependence on decidable equality for the type,
which we want to avoid.

Because we will rely on fintype instances for constructor arguments, we can't actually build a list
directly, so (1) and (2) are necessarily somewhat intertwined. The inductive types we will be
proving instances for look something like this:

```
@[derive fintype]
inductive foo
| zero : foo
| one : bool → foo
| two : ∀ x : fin 3, bar x → foo
```

The list of elements that we generate is
```
{foo.zero}
∪ (finset.univ : bool).map (λ b, finset.one b)
∪ (finset.univ : Σ' x : fin 3, bar x).map (λ ⟨x, y⟩, finset.two x y)
```
except that instead of `∪`, that is `finset.union`, we use `finset.disj_union` which doesn't
require any deduplication, but does require a proof that the two parts of the union are disjoint.
We use `finset.cons` to append singletons like `foo.zero`.

The proofs of disjointness would be somewhat expensive since there are quadratically many of them,
so instead we use a "discriminant" function. Essentially, we define
```
def foo.enum : foo → ℕ
| foo.zero := 0
| (foo.one _) := 1
| (foo.two _ _) := 2
```
and now the existence of this function implies that foo.zero is not foo.two and so on because they
map to different natural numbers. We can prove that sets of natural numbers are mutually disjoint
more easily because they have a linear order: `0 < 1 < 2` so `0 ≠ 2`.

To package this argument up, we define `finset_above foo foo.enum n` to be a finset `s` together
with a proof that all elements `a ∈ s` have `n ≤ enum a`. Now we only have to prove that
`enum foo.zero = 0`, `enum (foo.one _) = 1`, etc. (linearly many proofs, all `rfl`) in order to
prove that all variants are mutually distinct.

We mirror the `finset.cons` and `finset.disj_union` functions into `finset_above.cons` and
`finset_above.union`, and this forms the main part of the finset construction.

This only handles distinguishing variants of a finset. Now we must enumerate the elements of a
variant, for example `{foo.one ff, foo.one tt}`, while at the same time proving that all these
elements have discriminant `1` in this case. To do that, we use the `finset_in` type, which
is a finset satisfying a property `P`, here `λ a, foo.enum a = 1`.

We could use `finset.bind` many times to construct the finset but it turns out to be somewhat
complicated to get good side goals for a naturally nodup version of `finset.bind` in the same way
as we did with `finset.cons` and `finset.union`. Instead, we tuple up all arguments into one type,
leveraging the `fintype` instance on `psigma`, and then define a map from this type to the
inductive type that untuples them and applies the constructor. The injectivity property of the
constructor ensures that this function is injective, so we can use `finset.map` to apply it. This
is the content of the constructor `finset_in.mk`.

That completes the proofs of (1) and (2). To prove (3), we perform one case analysis over the
inductive type, proving theorems like
```
foo.one a ∈ {foo.zero}
  ∪ (finset.univ : bool).map (λ b, finset.one b)
  ∪ (finset.univ : Σ' x : fin 3, bar x).map (λ ⟨x, y⟩, finset.two x y)
```
by seeking to the relevant disjunct and then supplying the constructor arguments. This part of the
proof is quadratic, but quite simple. (We could do it in `O(n log n)` if we used a balanced tree
for the unions.)

The tactics perform the following parts of this proof scheme:
* `mk_sigma` constructs the type `Γ` in `finset_in.mk`
* `mk_sigma_elim` constructs the function `f` in `finset_in.mk`
* `mk_sigma_elim_inj` proves that `f` is injective
* `mk_sigma_elim_eq` proves that `∀ a, enum (f a) = k`
* `mk_finset` constructs the finset `S = {foo.zero} ∪ ...` by recursion on the variants
* `mk_finset_total` constructs the proof `|- foo.zero ∈ S; |- foo.one a ∈ S; |- foo.two a b ∈ S`
  by recursion on the subgoals coming out of the initial `cases`
* `mk_fintype_instance` puts it all together to produce a proof of `fintype foo`.
  The construction of `foo.enum` is also done in this function.

-/

namespace DeriveFintype

/-- A step in the construction of `finset.univ` for a finite inductive type.
We will set `enum` to the discriminant of the inductive type, so a `finset_above`
represents a finset that enumerates all elements in a tail of the constructor list. -/
def FinsetAbove (α) (enum : α → ℕ) (n : ℕ) :=
  { s : Finset α // ∀ x ∈ s, n ≤ enum x }
#align derive_fintype.finset_above DeriveFintype.FinsetAbove

/-- Construct a fintype instance from a completed `finset_above`. -/
def mkFintype {α} (enum : α → ℕ) (s : FinsetAbove α enum 0) (H : ∀ x, x ∈ s.1) : Fintype α :=
  ⟨s.1, H⟩
#align derive_fintype.mk_fintype DeriveFintype.mkFintype

/-- This is the case for a simple variant (no arguments) in an inductive type. -/
def FinsetAbove.cons {α} {enum : α → ℕ} (n) (a : α) (h : enum a = n)
    (s : FinsetAbove α enum (n + 1)) : FinsetAbove α enum n :=
  by
  refine' ⟨Finset.cons a s.1 _, _⟩
  · intro h'
    have := s.2 _ h'
    rw [h] at this
    exact Nat.not_succ_le_self n this
  · intro x h'
    rcases Finset.mem_cons.1 h' with (rfl | h')
    · exact ge_of_eq h
    · exact Nat.le_of_succ_le (s.2 _ h')
#align derive_fintype.finset_above.cons DeriveFintype.FinsetAbove.cons

theorem FinsetAbove.mem_cons_self {α} {enum : α → ℕ} {n a h s} :
    a ∈ (@FinsetAbove.cons α enum n a h s).1 :=
  Multiset.mem_cons_self _ _
#align derive_fintype.finset_above.mem_cons_self DeriveFintype.FinsetAbove.mem_cons_self

theorem FinsetAbove.mem_cons_of_mem {α} {enum : α → ℕ} {n a h s b} :
    b ∈ (s : FinsetAbove _ _ _).1 → b ∈ (@FinsetAbove.cons α enum n a h s).1 :=
  Multiset.mem_cons_of_mem
#align derive_fintype.finset_above.mem_cons_of_mem DeriveFintype.FinsetAbove.mem_cons_of_mem

/-- The base case is when we run out of variants; we just put an empty finset at the end. -/
def FinsetAbove.nil {α} {enum : α → ℕ} (n) : FinsetAbove α enum n :=
  ⟨∅, by rintro _ ⟨⟩⟩
#align derive_fintype.finset_above.nil DeriveFintype.FinsetAbove.nil

instance (α enum n) : Inhabited (FinsetAbove α enum n) :=
  ⟨FinsetAbove.nil _⟩

/-- This is a finset covering a nontrivial variant (with one or more constructor arguments).
The property `P` here is `λ a, enum a = n` where `n` is the discriminant for the current
variant. -/
@[nolint has_nonempty_instance]
def FinsetIn {α} (P : α → Prop) :=
  { s : Finset α // ∀ x ∈ s, P x }
#align derive_fintype.finset_in DeriveFintype.FinsetIn

/-- To construct the finset, we use an injective map from the type `Γ`, which will be the
sigma over all constructor arguments. We use sigma instances and existing fintype instances
to prove that `Γ` is a fintype, and construct the function `f` that maps `⟨a, b, c, ...⟩`
to `C_n a b c ...` where `C_n` is the nth constructor, and `mem` asserts
`enum (C_n a b c ...) = n`. -/
def FinsetIn.mk {α} {P : α → Prop} (Γ) [Fintype Γ] (f : Γ → α) (inj : Function.Injective f)
    (mem : ∀ x, P (f x)) : FinsetIn P :=
  ⟨Finset.univ.map ⟨f, inj⟩, fun x h => by
    rcases Finset.mem_map.1 h with ⟨x, _, rfl⟩ <;> exact mem x⟩
#align derive_fintype.finset_in.mk DeriveFintype.FinsetIn.mk

theorem FinsetIn.mem_mk {α} {P : α → Prop} {Γ} {s : Fintype Γ} {f : Γ → α} {inj mem a} (b)
    (H : f b = a) : a ∈ (@FinsetIn.mk α P Γ s f inj mem).1 :=
  Finset.mem_map.2 ⟨_, Finset.mem_univ _, H⟩
#align derive_fintype.finset_in.mem_mk DeriveFintype.FinsetIn.mem_mk

/-- For nontrivial variants, we split the constructor list into a `finset_in` component for the
current constructor and a `finset_above` for the rest. -/
def FinsetAbove.union {α} {enum : α → ℕ} (n) (s : FinsetIn fun a => enum a = n)
    (t : FinsetAbove α enum (n + 1)) : FinsetAbove α enum n :=
  by
  refine' ⟨Finset.disjUnion s.1 t.1 _, _⟩
  · rw [Finset.disjoint_left]
    intro a hs ht
    have := t.2 _ ht
    rw [s.2 _ hs] at this
    exact Nat.not_succ_le_self n this
  · intro x h'
    rcases Finset.mem_disjUnion.1 h' with (h' | h')
    · exact ge_of_eq (s.2 _ h')
    · exact Nat.le_of_succ_le (t.2 _ h')
#align derive_fintype.finset_above.union DeriveFintype.FinsetAbove.union

theorem FinsetAbove.mem_union_left {α} {enum : α → ℕ} {n s t a} (H : a ∈ (s : FinsetIn _).1) :
    a ∈ (@FinsetAbove.union α enum n s t).1 :=
  Multiset.mem_add.2 (Or.inl H)
#align derive_fintype.finset_above.mem_union_left DeriveFintype.FinsetAbove.mem_union_left

theorem FinsetAbove.mem_union_right {α} {enum : α → ℕ} {n s t a}
    (H : a ∈ (t : FinsetAbove _ _ _).1) : a ∈ (@FinsetAbove.union α enum n s t).1 :=
  Multiset.mem_add.2 (Or.inr H)
#align derive_fintype.finset_above.mem_union_right DeriveFintype.FinsetAbove.mem_union_right

end DeriveFintype

namespace Tactic

open DeriveFintype Tactic Expr

namespace DeriveFintype

/-- Construct the term `Σ' (a:A) (b:B a) (c:C a b), unit` from
`Π (a:A) (b:B a), C a b → T` (the type of a constructor). -/
unsafe def mk_sigma : expr → tactic expr
  | expr.pi n bi d b => do
    let p ← mk_local' n bi d
    let e ← mk_sigma (expr.instantiate_var b p)
    tactic.mk_app `` PSigma [d, bind_lambda e p]
  | _ => pure q(Unit)
#align tactic.derive_fintype.mk_sigma tactic.derive_fintype.mk_sigma

/-- Prove the goal `(Σ' (a:A) (b:B a) (c:C a b), unit) → T`
(this is the function `f` in `finset_in.mk`) using recursive `psigma.elim`,
finishing with the constructor. The two arguments are the type of the constructor,
and the constructor term itself; as we recurse we add arguments
to the constructor application and destructure the pi type of the constructor. We return the number
of `psigma.elim` applications constructed, which is the number of constructor arguments. -/
unsafe def mk_sigma_elim : expr → expr → tactic ℕ
  | expr.pi n bi d b, c => do
    refine ``(@PSigma.elim $(d) _ _ _)
    let i ← intro_fresh n
    (· + 1) <$> mk_sigma_elim (expr.instantiate_var b i) (c i)
  | _, c => do
    intro1
    exact c $> 0
#align tactic.derive_fintype.mk_sigma_elim tactic.derive_fintype.mk_sigma_elim

/-- Prove the goal `a, b |- f a = f b → g a = g b` where `f` is the function we constructed in
`mk_sigma_elim`, and `g` is some other term that gets built up and eventually closed by
reflexivity. Here `a` and `b` have sigma types so the proof approach is to case on `a` and `b`
until the goal reduces to `C_n a1 ... am = C_n b1 ... bm → ⟨a1, ..., am⟩ = ⟨b1, ..., bm⟩`, at which
point cases on the equality reduces the problem to reflexivity.

The arguments are the number `m` returned from `mk_sigma_elim`, and the hypotheses `a,b` that we
need to case on. -/
unsafe def mk_sigma_elim_inj : ℕ → expr → expr → tactic Unit
  | m + 1, x, y => do
    let [(_, [x1, x2])] ← cases x
    let [(_, [y1, y2])] ← cases y
    mk_sigma_elim_inj m x2 y2
  | 0, x, y => do
    cases x
    cases y
    let is ← intro1 >>= injection
    is cases
    reflexivity
#align tactic.derive_fintype.mk_sigma_elim_inj tactic.derive_fintype.mk_sigma_elim_inj

/-- Prove the goal `a |- enum (f a) = n`, where `f` is the function constructed in `mk_sigma_elim`,
and `enum` is a function that reduces to `n` on the constructor `C_n`. Here we just have to case on
`a` `m` times, and then `reflexivity` finishes the proof. -/
unsafe def mk_sigma_elim_eq : ℕ → expr → tactic Unit
  | n + 1, x => do
    let [(_, [x1, x2])] ← cases x
    mk_sigma_elim_eq n x2
  | 0, x => reflexivity
#align tactic.derive_fintype.mk_sigma_elim_eq tactic.derive_fintype.mk_sigma_elim_eq

/-- Prove the goal `|- finset_above T enum k`, where `T` is the inductive type and `enum` is the
discriminant function. The arguments are `args`, the parameters to the inductive type (and all
constructors), `k`, the index of the current variant, and `cs`, the list of constructor names.
This uses `finset_above.cons` for basic variants and `finset_above.union` for variants with
arguments, using the auxiliary functions `mk_sigma`, `mk_sigma_elim`, `mk_sigma_elim_inj`,
`mk_sigma_elim_eq` to close subgoals. -/
unsafe def mk_finset (ls : List level) (args : List expr) : ℕ → List Name → tactic Unit
  | k, c :: cs => do
    let e := (expr.const c ls).mk_app args
    let t ← infer_type e
    if is_pi t then do
        to_expr ``(FinsetAbove.union $(reflect k)) tt ff >>= fun c =>
            apply c { NewGoals := new_goals.all }
        let Γ ← mk_sigma t
        to_expr ``(FinsetIn.mk $(Γ)) tt ff >>= fun c => apply c { NewGoals := new_goals.all }
        let n ← mk_sigma_elim t e
        intro1 >>= fun x => intro1 >>= mk_sigma_elim_inj n x
        intro1 >>= mk_sigma_elim_eq n
        mk_finset (k + 1) cs
      else do
        let c ← to_expr ``(FinsetAbove.cons $(reflect k) $(e)) tt ff
        apply c { NewGoals := new_goals.all }
        reflexivity
        mk_finset (k + 1) cs
  | k, [] => applyc `` finset_above.nil
#align tactic.derive_fintype.mk_finset tactic.derive_fintype.mk_finset

/-- Prove the goal `|- Σ' (a:A) (b: B a) (c:C a b), unit` given a list of terms `a, b, c`. -/
unsafe def mk_sigma_mem : List expr → tactic Unit
  | x :: xs => (fconstructor >> exact x) >> mk_sigma_mem xs
  | [] => fconstructor $> ()
#align tactic.derive_fintype.mk_sigma_mem tactic.derive_fintype.mk_sigma_mem

/-- This function is called to prove `a : T |- a ∈ S.1` where `S` is the `finset_above` constructed
by `mk_finset`, after the initial cases on `a : T`, producing a list of subgoals. For each case,
we have to navigate past all the variants that don't apply (which is what the `tac` input tactic
does), and then call either `finset_above.mem_cons_self` for trivial variants or
`finset_above.mem_union_left` and `finset_in.mem_mk` for nontrivial variants. Either way the proof
is quite simple. -/
unsafe def mk_finset_total : tactic Unit → List (Name × List expr) → tactic Unit
  | tac, [] => done
  | tac, (_, xs) :: gs => do
    tac
    let b ← succeeds (applyc `` finset_above.mem_cons_self)
    if b then mk_finset_total (tac >> applyc `` finset_above.mem_cons_of_mem) gs
      else do
        applyc `` finset_above.mem_union_left
        applyc `` finset_in.mem_mk { NewGoals := new_goals.all }
        mk_sigma_mem xs
        reflexivity
        mk_finset_total (tac >> applyc `` finset_above.mem_union_right) gs
#align tactic.derive_fintype.mk_finset_total tactic.derive_fintype.mk_finset_total

end DeriveFintype

open Tactic.DeriveFintype

/-- Proves `|- fintype T` where `T` is a non-recursive inductive type with no indices,
where all arguments to all constructors are fintypes. -/
unsafe def mk_fintype_instance : tactic Unit := do
  intros
  let q(Fintype $(e)) ← target >>= whnf
  let (const I ls, args) ← pure (get_app_fn_args e)
  let env ← get_env
  let cs := env.constructors_of I
  guard (env I = 0) <|> fail "@[derive fintype]: inductive indices are not supported"
  guard ¬env I <|>
      fail
        ("@[derive fintype]: recursive inductive types are " ++
          "not supported (they are also usually infinite)")
  applyc `` mk_fintype { NewGoals := new_goals.all }
  intro1 >>= cases >>= fun gs => gs fun ⟨i, _⟩ => exact (reflect i)
  mk_finset ls args 0 cs
  intro1 >>= cases >>= mk_finset_total skip
#align tactic.mk_fintype_instance tactic.mk_fintype_instance

/-- Tries to derive a `fintype` instance for inductives and structures.

For example:
```
@[derive fintype]
inductive foo (n m : ℕ)
| zero : foo
| one : bool → foo
| two : fin n → fin m → foo
```
Here, `@[derive fintype]` adds the instance `foo.fintype`. The underlying finset
definitionally unfolds to a list that enumerates the elements of the inductive in
lexicographic order.

If the structure/inductive has a type parameter `α`, then the generated instance will have an
argument `fintype α`, even if it is not used.  (This is due to the implementation using
`instance_derive_handler`.)
-/
@[derive_handler]
unsafe def fintype_instance : derive_handler :=
  instance_derive_handler `` Fintype mk_fintype_instance
#align tactic.fintype_instance tactic.fintype_instance

end Tactic


/-
Copyright (c) 2019 Tim Baanen. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Tim Baanen
-/
import tactic.norm_num
import control.traversable.basic

/-!
# `ring_exp` tactic

A tactic for solving equations in commutative (semi)rings,
where the exponents can also contain variables.

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
- exponentiation of expressions (the exponent must have type `ℕ`)
- subtraction and negation of expressions (if the base is a full ring)

The motivating example is proving `2 * 2^n * b = b * 2^(n+1)`,
something that the `ring` tactic cannot do, but `ring_exp` can.

## 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 `ex` at the meta level,
together with a proof (at the base level) that the original value is equal to
the normalised version.
The normalised version and normalisation proofs are also stored in the `ex` type.

The outline of the file:
- Define an inductive family of types `ex`, parametrised over `ex_type`,
  which can represent expressions with `+`, `*`, `^` and rational numerals.
  The parametrisation over `ex_type` 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 `ex` type,
  thus allowing us to map expressions to `ex` (the `eval` function drives this).
  We apply associativity and distributivity of the operators here (helped by `ex_type`)
  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.
- In the tactic, a normalized expression `ps : ex` lives in the meta-world,
  but the normalization proofs live in the real world.
  Thus, we cannot directly say `ps.orig = ps.pretty` anywhere,
  but we have to carefully construct the proof when we compute `ps`.
  This was a major source of bugs in development!
- 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.
  This is accomplished by the `in_exponent` function and is relatively painless since
  we work in a `reader` monad.
- 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 `ex.simp`.

## Caveats and future work

Subtraction cancels out identical terms, but division does not.
That is: `a - a = 0 := by ring_exp` solves the goal,
but `a / a := 1 by ring_exp` 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_exp` could be implemented
in a similar way that `2 * a + 2 * a = 4 * a := by ring_exp` already works.
This feature wasn't needed yet, so it's not implemented yet.

## Tags

ring, semiring, exponent, power
-/

-- The base ring `α` will have a universe level `u`.
-- We do not introduce `α` as a variable yet,
-- in order to make it explicit or implicit as required.
universes u

namespace tactic.ring_exp
open nat

/--
The `atom` structure is used to represent atomic expressions:
those which `ring_exp` cannot parse any further.

For instance, `a + (a % b)` has `a` and `(a % b)` as atoms.
The `ring_exp_eq` tactic does not normalize the subexpressions in atoms,
but `ring_exp` does if `ring_exp_eq` was not sufficient.

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.
-/
meta structure atom : Type := (value : expr) (index : ℕ)

namespace atom

/--
The `eq` operation on `atom`s works modulo definitional equality,
ignoring their `value`s.
The invariants on `atom` ensure indices are unique per value.
Thus, `eq` indicates equality as long as the `atom`s come from the same context.
-/
meta def eq (a b : atom) : bool := a.index = b.index

/--
We order `atom`s on the order of appearance in the main expression.
-/
meta def lt (a b : atom) : bool := a.index < b.index

meta instance : has_repr atom := ⟨λ x, "(atom " ++ repr x.2 ++ ")"⟩

end atom

section expression
/-!
### `expression` section

In this section, we define the `ex` type and its basic operations.

First, we introduce the supporting types `coeff`, `ex_type` and `ex_info`.
For understanding the code, it's easier to check out `ex` itself first,
then refer back to the supporting types.

The arithmetic operations on `ex` need additional definitions,
so they are defined in a later section.
-/

/--
Coefficients in the expression are stored in a wrapper structure,
allowing for easier modification of the data structures.
The modifications might be caching of the result of `expr.of_rat`,
or using a different meta representation of numerals.
-/
@[derive decidable_eq, derive inhabited]
structure coeff : Type := (value : ℚ)

/-- The values in `ex_type` are used as parameters to `ex` to control the expression's structure. -/
@[derive decidable_eq, derive inhabited]
inductive ex_type : Type
| base : ex_type
| sum : ex_type
| prod : ex_type
| exp : ex_type
open ex_type

/--
Each `ex` stores information for its normalization proof.

The `orig` expression is the expression that was passed to `eval`.

The `pretty` expression is the normalised form that the `ex` represents.
(I didn't call this something like `norm`, because there are already
too many things called `norm` in mathematics!)

The field `proof` contains an optional proof term of type `%%orig = %%pretty`.
The value `none` for the proof indicates that everything reduces to reflexivity.
(Which saves space in quite a lot of cases.)
-/
meta structure ex_info : Type :=
(orig : expr) (pretty : expr) (proof : option expr)

/--
The `ex` type is an abstract representation of an expression with `+`, `*` and `^`.
Those operators are mapped to the `sum`, `prod` and `exp` constructors respectively.

The `zero` constructor is the base case for `ex sum`, e.g. `1 + 2` is represented
by (something along the lines of) `sum 1 (sum 2 zero)`.

The `coeff` constructor is the base case for `ex prod`, and is used for numerals.
The code maintains the invariant that the coefficient is never `0`.

The `var` constructor is the base case for `ex exp`, and is used for atoms.

The `sum_b` constructor allows for addition in the base of an exponentiation;
it serves a similar purpose as the parentheses in `(a + b)^c`.
The code maintains the invariant that the argument to `sum_b` is not `zero`
or `sum _ zero`.

All of the constructors contain an `ex_info` field,
used to carry around (arguments to) proof terms.

While the `ex_type` parameter enforces some simplification invariants,
the following ones must be manually maintained at the risk of insufficient power:
- the argument to `coeff` must be nonzero (to ensure `0 = 0 * 1`)
- the argument to `sum_b` must be of the form `sum a (sum b bs)` (to ensure `(a + 0)^n = a^n`)
- normalisation proofs of subexpressions must be `refl ps.pretty`
- if we replace `sum` with `cons` and `zero` with `nil`, the resulting list is sorted
  according to the `lt` relation defined further down; similarly for `prod` and `coeff`
  (to ensure `a + b = b + a`).

The first two invariants could be encoded in a subtype of `ex`,
but aren't (yet) to spare some implementation burden.
The other invariants cannot be encoded because we need the `tactic` monad to check them.
(For example, the correct equality check of `expr` is `is_def_eq : expr → expr → tactic unit`.)
-/
meta inductive ex : ex_type → Type
| zero  (info : ex_info) : ex sum
| sum   (info : ex_info) : ex prod → ex sum → ex sum
| coeff (info : ex_info) : coeff → ex prod
| prod  (info : ex_info) : ex exp → ex prod → ex prod
| var   (info : ex_info) : atom → ex base
| sum_b (info : ex_info) : ex sum → ex base
| exp   (info : ex_info) : ex base → ex prod → ex exp

/--
Return the proof information associated to the `ex`.
-/
meta def ex.info : Π {et : ex_type} (ps : ex et), ex_info
| sum  (ex.zero  i)     := i
| sum  (ex.sum   i _ _) := i
| prod (ex.coeff i _)   := i
| prod (ex.prod  i _ _) := i
| base (ex.var   i _)   := i
| base (ex.sum_b i _)   := i
| exp  (ex.exp   i _ _) := i

/--
Return the original, non-normalized version of this `ex`.

Note that arguments to another `ex` are always "pre-normalized":
their `orig` and `pretty` are equal, and their `proof` is reflexivity.
-/
meta def ex.orig {et : ex_type} (ps : ex et) : expr := ps.info.orig

/--
Return the normalized version of this `ex`.
-/
meta def ex.pretty {et : ex_type} (ps : ex et) : expr := ps.info.pretty

/--
Return the normalisation proof of the given expression.
If the proof is `refl`, we give `none` instead,
which helps to control the size of proof terms.
To get an actual term, use `ex.proof_term`,
or use `mk_proof` with the correct set of arguments.
-/
meta def ex.proof {et : ex_type} (ps : ex et) : option expr := ps.info.proof

/--
Update the `orig` and `proof` fields of the `ex_info`.
Intended for use in `ex.set_info`.
-/
meta def ex_info.set (i : ex_info) (o : option expr) (pf : option expr) : ex_info :=
{orig := o.get_or_else i.pretty, proof := pf, .. i}

/--
Update the `ex_info` of the given expression.

We use this to combine intermediate normalisation proofs.
Since `pretty` only depends on the subexpressions,
which do not change, we do not set `pretty`.
-/
meta def ex.set_info : Π {et : ex_type} (ps : ex et), option expr → option expr → ex et
| sum  (ex.zero  i)      o pf := ex.zero  (i.set o pf)
| sum  (ex.sum   i p ps) o pf := ex.sum   (i.set o pf) p ps
| prod (ex.coeff i x)    o pf := ex.coeff (i.set o pf) x
| prod (ex.prod  i p ps) o pf := ex.prod  (i.set o pf) p ps
| base (ex.var   i x)    o pf := ex.var   (i.set o pf) x
| base (ex.sum_b i ps)   o pf := ex.sum_b (i.set o pf) ps
| exp  (ex.exp   i p ps) o pf := ex.exp   (i.set o pf) p ps

instance coeff_has_repr : has_repr coeff := ⟨λ x, repr x.1⟩

/-- Convert an `ex` to a `string`. -/
meta def ex.repr : Π {et : ex_type}, ex et → string
| sum  (ex.zero _)      := "0"
| sum  (ex.sum _ p ps)  := ex.repr p ++ " + " ++ ex.repr ps
| prod (ex.coeff _ x)   := repr x
| prod (ex.prod _ p ps) := ex.repr p ++ " * " ++ ex.repr ps
| base (ex.var _ x)     := repr x
| base (ex.sum_b _ ps)  := "(" ++ ex.repr ps ++ ")"
| exp  (ex.exp _ p ps)  := ex.repr p ++ " ^ " ++ ex.repr ps
meta instance {et : ex_type} : has_repr (ex et) := ⟨ex.repr⟩

/--
Equality test for expressions.

Since equivalence of `atom`s is not the same as equality,
we cannot make a true `(=)` operator for `ex` either.
-/
meta def ex.eq : Π {et : ex_type}, ex et → ex et → bool
| sum  (ex.zero _)      (ex.zero _)      := tt
| sum  (ex.zero _)      (ex.sum _ _ _)   := ff
| sum  (ex.sum _ _ _)   (ex.zero _)      := ff
| sum  (ex.sum _ p ps)  (ex.sum _ q qs)  := p.eq q && ps.eq qs
| prod (ex.coeff _  x)  (ex.coeff _ y)   := x = y
| prod (ex.coeff _ _)   (ex.prod _ _ _)  := ff
| prod (ex.prod _ _ _)  (ex.coeff _ _)   := ff
| prod (ex.prod _ p ps) (ex.prod _ q qs) := p.eq q && ps.eq qs
| base (ex.var _ x)     (ex.var _ y)     := x.eq y
| base (ex.var _ _)     (ex.sum_b _ _)   := ff
| base (ex.sum_b _ _)   (ex.var _ _)     := ff
| base (ex.sum_b _ ps)  (ex.sum_b _ qs)  := ps.eq qs
| exp  (ex.exp _ p ps)  (ex.exp _ q qs)  := p.eq q && ps.eq qs

/--
The ordering on expressions.

As for `ex.eq`, this is a linear order only in one context.
-/
meta def ex.lt : Π {et : ex_type}, ex et → ex et → bool
| sum  _                (ex.zero _)      := ff
| sum  (ex.zero _)      _                := tt
| sum  (ex.sum _ p ps)  (ex.sum _ q qs)  := p.lt q || (p.eq q && ps.lt qs)
| prod (ex.coeff _ x)   (ex.coeff _ y)   := x.1 < y.1
| prod (ex.coeff _ _)   _                := tt
| prod _                (ex.coeff _ _)   := ff
| prod (ex.prod _ p ps) (ex.prod _ q qs) := p.lt q || (p.eq q && ps.lt qs)
| base (ex.var _ x)     (ex.var _ y)     := x.lt y
| base (ex.var _ _)     (ex.sum_b _ _)   := tt
| base (ex.sum_b _ _)   (ex.var _ _)     := ff
| base (ex.sum_b _ ps)  (ex.sum_b _ qs)  := ps.lt qs
| exp  (ex.exp _ p ps)  (ex.exp _ q qs)  := p.lt q || (p.eq q && ps.lt qs)

end expression

section operations
/-!
### `operations` section

This section defines the operations (on `ex`) that use tactics.
They live in the `ring_exp_m` monad,
which adds a cache and a list of encountered atoms to the `tactic` monad.

Throughout this section, we will be constructing proof terms.
The lemmas used in the construction are all defined over a commutative semiring α.
-/
variables {α : Type u} [comm_semiring α]

open tactic
open ex_type

/--
Stores the information needed in the `eval` function and its dependencies,
so they can (re)construct expressions.

The `eval_info` structure stores this information for one type,
and the `context` combines the two types, one for bases and one for exponents.
-/
meta structure eval_info :=
(α : expr) (univ : level)
-- Cache the instances for optimization and consistency
(csr_instance : expr) (ha_instance : expr) (hm_instance : expr) (hp_instance : expr)
-- Optional instances (only required for (-) and (/) respectively)
(ring_instance : option expr) (dr_instance : option expr)
-- Cache common constants.
(zero : expr) (one : expr)

/--
The `context` contains the full set of information needed for the `eval` function.

This structure has two copies of `eval_info`:
one is for the base (typically some semiring `α`) and another for the exponent (always `ℕ`).
When evaluating an exponent, we put `info_e` in `info_b`.
-/
meta structure context :=
(info_b : eval_info) (info_e : eval_info) (transp : transparency)

/--
The `ring_exp_m` monad is used instead of `tactic` to store the context.
-/
@[derive [monad, alternative]]
meta def ring_exp_m (α : Type) : Type := reader_t context (state_t (list atom) tactic) α

/--
Access the instance cache.
-/
meta def get_context : ring_exp_m context := reader_t.read

/--
Lift an operation in the `tactic` monad to the `ring_exp_m` monad.

This operation will not access the cache.
-/
meta def lift {α} (m : tactic α) : ring_exp_m α := reader_t.lift (state_t.lift m)

/--
Change the context of the given computation,
so that expressions are evaluated in the exponent ring,
instead of the base ring.
-/
meta def in_exponent {α} (mx : ring_exp_m α) : ring_exp_m α := do
  ctx ← get_context,
  reader_t.lift $ mx.run ⟨ctx.info_e, ctx.info_e, ctx.transp⟩

/--
Specialized version of `mk_app` where the first two arguments are `{α}` `[some_class α]`.
Should be faster because it can use the cached instances.
-/
meta def mk_app_class (f : name) (inst : expr) (args : list expr) : ring_exp_m expr := do
  ctx ← get_context,
  pure $ (@expr.const tt f [ctx.info_b.univ] ctx.info_b.α inst).mk_app args

/--
Specialized version of `mk_app` where the first two arguments are `{α}` `[comm_semiring α]`.
Should be faster because it can use the cached instances.
 -/
meta def mk_app_csr (f : name) (args : list expr) : ring_exp_m expr := do
  ctx ← get_context,
  mk_app_class f (ctx.info_b.csr_instance) args

/--
Specialized version of `mk_app ``has_add.add`.
Should be faster because it can use the cached instances.
-/
meta def mk_add (args : list expr) : ring_exp_m expr := do
  ctx ← get_context,
  mk_app_class ``has_add.add ctx.info_b.ha_instance args

/--
Specialized version of `mk_app ``has_mul.mul`.
Should be faster because it can use the cached instances.
-/
meta def mk_mul (args : list expr) : ring_exp_m expr := do
  ctx ← get_context,
  mk_app_class ``has_mul.mul ctx.info_b.hm_instance args

/--
Specialized version of `mk_app ``has_pow.pow`.
Should be faster because it can use the cached instances.
-/
meta def mk_pow (args : list expr) : ring_exp_m expr := do
  ctx ← get_context,
  pure $ (@expr.const tt ``has_pow.pow
    [ctx.info_b.univ, ctx.info_e.univ]
    ctx.info_b.α ctx.info_e.α
    ctx.info_b.hp_instance).mk_app args

/-- Construct a normalization proof term or return the cached one. -/
meta def ex_info.proof_term (ps : ex_info) : ring_exp_m expr :=
match ps.proof with
| none := lift $ tactic.mk_eq_refl ps.pretty
| (some p) := pure p
end
/-- Construct a normalization proof term or return the cached one. -/
meta def ex.proof_term {et : ex_type} (ps : ex et) : ring_exp_m expr := ps.info.proof_term

/--
If all `ex_info` have trivial proofs, return a trivial proof.
Otherwise, construct all proof terms.

Useful in applications where trivial proofs combine to another trivial proof,
most importantly to pass to `mk_proof_or_refl`.
-/
meta def none_or_proof_term : list ex_info → ring_exp_m (option (list expr))
| [] := pure none
| (x :: xs) := do
  xs_pfs ← none_or_proof_term xs,
  match (x.proof, xs_pfs) with
  | (none, none) := pure none
  | (some x_pf, none) := do
    xs_pfs ← traverse ex_info.proof_term xs,
    pure (some (x_pf :: xs_pfs))
  | (_, some xs_pfs) := do
    x_pf ← x.proof_term,
    pure (some (x_pf :: xs_pfs))
  end

/--
Use the proof terms as arguments to the given lemma.
If the lemma could reduce to reflexivity, consider using `mk_proof_or_refl.`
-/
meta def mk_proof (lem : name) (args : list expr) (hs : list ex_info) : ring_exp_m expr := do
  hs' ← traverse ex_info.proof_term hs,
  mk_app_csr lem (args ++ hs')

/--
Use the proof terms as arguments to the given lemma.
Often, we construct a proof term using congruence where reflexivity suffices.
To solve this, the following function tries to get away with reflexivity.
-/
meta def mk_proof_or_refl (term : expr) (lem : name) (args : list expr) (hs : list ex_info) :
ring_exp_m expr := do
  hs_full ← none_or_proof_term hs,
  match hs_full with
  | none := lift $ mk_eq_refl term
  | (some hs') := mk_app_csr lem (args ++ hs')
  end

/-- A shortcut for adding the original terms of two expressions. -/
meta def add_orig {et et'} (ps : ex et) (qs : ex et') : ring_exp_m expr :=
mk_add [ps.orig, qs.orig]

/-- A shortcut for multiplying the original terms of two expressions. -/
meta def mul_orig {et et'} (ps : ex et) (qs : ex et') : ring_exp_m expr :=
mk_mul [ps.orig, qs.orig]

/-- A shortcut for exponentiating the original terms of two expressions. -/
meta def pow_orig {et et'} (ps : ex et) (qs : ex et') : ring_exp_m expr :=
mk_pow [ps.orig, qs.orig]

/-- Congruence lemma for constructing `ex.sum`. -/
lemma sum_congr {p p' ps ps' : α} : p = p' → ps = ps' → p + ps = p' + ps' := by cc

/-- Congruence lemma for constructing `ex.prod`. -/
lemma prod_congr {p p' ps ps' : α} : p = p' → ps = ps' → p * ps = p' * ps' := by cc

/-- Congruence lemma for constructing `ex.exp`. -/
lemma exp_congr {p p' : α} {ps ps' : ℕ} : p = p' → ps = ps' → p ^ ps = p' ^ ps' := by cc

/-- Constructs `ex.zero` with the correct arguments. -/
meta def ex_zero : ring_exp_m (ex sum) := do
  ctx ← get_context,
  pure $ ex.zero ⟨ctx.info_b.zero, ctx.info_b.zero, none⟩

/-- Constructs `ex.sum` with the correct arguments. -/
meta def ex_sum (p : ex prod) (ps : ex sum) : ring_exp_m (ex sum) := do
  pps_o ← add_orig p ps,
  pps_p ← mk_add [p.pretty, ps.pretty],
  pps_pf ← mk_proof_or_refl pps_p ``sum_congr
    [p.orig, p.pretty, ps.orig, ps.pretty]
    [p.info, ps.info],
  pure (ex.sum ⟨pps_o, pps_p, pps_pf⟩ (p.set_info none none) (ps.set_info none none))

/--
Constructs `ex.coeff` with the correct arguments.

There are more efficient constructors for specific numerals:
if `x = 0`, you should use `ex_zero`; if `x = 1`, use `ex_one`.
-/
meta def ex_coeff (x : rat) : ring_exp_m (ex prod) := do
  ctx ← get_context,
  x_p ← lift $ expr.of_rat ctx.info_b.α x,
  pure (ex.coeff ⟨x_p, x_p, none⟩ ⟨x⟩)

/--
Constructs `ex.coeff 1` with the correct arguments.
This is a special case for optimization purposes.
-/
meta def ex_one : ring_exp_m (ex prod) := do
  ctx ← get_context,
  pure $ ex.coeff ⟨ctx.info_b.one, ctx.info_b.one, none⟩ ⟨1⟩

/-- Constructs `ex.prod` with the correct arguments. -/
meta def ex_prod (p : ex exp) (ps : ex prod) : ring_exp_m (ex prod) := do
  pps_o ← mul_orig p ps,
  pps_p ← mk_mul [p.pretty, ps.pretty],
  pps_pf ← mk_proof_or_refl pps_p ``prod_congr
    [p.orig, p.pretty, ps.orig, ps.pretty]
    [p.info, ps.info],
  pure (ex.prod ⟨pps_o, pps_p, pps_pf⟩ (p.set_info none none) (ps.set_info none none))

/-- Constructs `ex.var` with the correct arguments. -/
meta def ex_var (p : atom) : ring_exp_m (ex base) := pure (ex.var ⟨p.1, p.1, none⟩ p)

/-- Constructs `ex.sum_b` with the correct arguments. -/
meta def ex_sum_b (ps : ex sum) : ring_exp_m (ex base) :=
pure (ex.sum_b ps.info (ps.set_info none none))

/-- Constructs `ex.exp` with the correct arguments. -/
meta def ex_exp (p : ex base) (ps : ex prod) : ring_exp_m (ex exp) := do
  ctx ← get_context,
  pps_o ← pow_orig p ps,
  pps_p ← mk_pow [p.pretty, ps.pretty],
  pps_pf ← mk_proof_or_refl pps_p ``exp_congr
    [p.orig, p.pretty, ps.orig, ps.pretty]
    [p.info, ps.info],
  pure (ex.exp ⟨pps_o, pps_p, pps_pf⟩ (p.set_info none none) (ps.set_info none none))

lemma base_to_exp_pf {p p' : α} : p = p' → p = p' ^ 1 := by simp

/-- Conversion from `ex base` to `ex exp`. -/
meta def base_to_exp (p : ex base) : ring_exp_m (ex exp) := do
  o ← in_exponent $ ex_one,
  ps ← ex_exp p o,
  pf ← mk_proof ``base_to_exp_pf [p.orig, p.pretty] [p.info],
  pure $ ps.set_info p.orig pf

lemma exp_to_prod_pf {p p' : α} : p = p' → p = p' * 1 := by simp

/-- Conversion from `ex exp` to `ex prod`. -/
meta def exp_to_prod (p : ex exp) : ring_exp_m (ex prod) := do
  o ← ex_one,
  ps ← ex_prod p o,
  pf ← mk_proof ``exp_to_prod_pf [p.orig, p.pretty] [p.info],
  pure $ ps.set_info p.orig pf

lemma prod_to_sum_pf {p p' : α} : p = p' → p = p' + 0 := by simp

/-- Conversion from `ex prod` to `ex sum`. -/
meta def prod_to_sum (p : ex prod) : ring_exp_m (ex sum) := do
  z ← ex_zero,
  ps ← ex_sum p z,
  pf ← mk_proof ``prod_to_sum_pf [p.orig, p.pretty] [p.info],
  pure $ ps.set_info p.orig pf

lemma atom_to_sum_pf (p : α) : p = p ^ 1 * 1 + 0 := by simp
/--
A more efficient conversion from `atom` to `ex sum`.

The result should be the same as `ex_var p >>= base_to_exp >>= exp_to_prod >>= prod_to_sum`,
except we need to calculate less intermediate steps.
-/
meta def atom_to_sum (p : atom) : ring_exp_m (ex sum) := do
  p' ← ex_var p,
  o ← in_exponent $ ex_one,
  p' ← ex_exp p' o,
  o ← ex_one,
  p' ← ex_prod p' o,
  z ← ex_zero,
  p' ← ex_sum p' z,
  pf ← mk_proof ``atom_to_sum_pf [p.1] [],
  pure $ p'.set_info p.1 pf

/--
Compute the sum of two coefficients.
Note that the result might not be a valid expression:
if `p = -q`, then the result should be `ex.zero : ex sum` instead.
The caller must detect when this happens!

The returned value is of the form `ex.coeff _ (p + q)`,
with the proof of `expr.of_rat p + expr.of_rat q = expr.of_rat (p + q)`.
-/
meta def add_coeff (p_p q_p : expr) (p q : coeff) : ring_exp_m (ex prod) := do
  ctx ← get_context,
  pq_o ← mk_add [p_p, q_p],
  (pq_p, pq_pf) ← lift $ norm_num.eval_field pq_o,
  pure $ ex.coeff ⟨pq_o, pq_p, pq_pf⟩ ⟨p.1 + q.1⟩

lemma mul_coeff_pf_one_mul (q : α) : 1 * q = q := one_mul q
lemma mul_coeff_pf_mul_one (p : α) : p * 1 = p := mul_one p

/--
Compute the product of two coefficients.

The returned value is of the form `ex.coeff _ (p * q)`,
with the proof of `expr.of_rat p * expr.of_rat q = expr.of_rat (p * q)`.
-/
meta def mul_coeff (p_p q_p : expr) (p q : coeff) : ring_exp_m (ex prod) :=
match p.1, q.1 with -- Special case to speed up multiplication with 1.
| ⟨1, 1, _, _⟩, _ := do
  ctx ← get_context,
  pq_o ← mk_mul [p_p, q_p],
  pf ← mk_app_csr ``mul_coeff_pf_one_mul [q_p],
  pure $ ex.coeff ⟨pq_o, q_p, pf⟩ ⟨q.1⟩
| _, ⟨1, 1, _, _⟩ := do
  ctx ← get_context,
  pq_o ← mk_mul [p_p, q_p],
  pf ← mk_app_csr ``mul_coeff_pf_mul_one [p_p],
  pure $ ex.coeff ⟨pq_o, p_p, pf⟩ ⟨p.1⟩
| _, _ := do
  ctx ← get_context,
  pq' ← mk_mul [p_p, q_p],
  (pq_p, pq_pf) ← lift $ norm_num.eval_field pq',
  pure $ ex.coeff ⟨pq_p, pq_p, pq_pf⟩ ⟨p.1 * q.1⟩
end

section rewrite

/-! ### `rewrite` section

In this section we deal with rewriting terms to fit in the basic grammar of `eval`.
For example, `nat.succ n` is rewritten to `n + 1` before it is evaluated further.
-/

/-- Given a proof that the expressions `ps_o` and `ps'.orig` are equal,
show that `ps_o` and `ps'.pretty` are equal.

Useful to deal with aliases in `eval`. For instance, `nat.succ p` can be handled
as an alias of `p + 1` as follows:
```
| ps_o@`(nat.succ %%p_o) := do
  ps' ← eval `(%%p_o + 1),
  pf ← lift $ mk_app ``nat.succ_eq_add_one [p_o],
  rewrite ps_o ps' pf
```
-/
meta def rewrite (ps_o : expr) (ps' : ex sum) (pf : expr) : ring_exp_m (ex sum) :=
do
  ps'_pf ← ps'.info.proof_term,
  pf ← lift $ mk_eq_trans pf ps'_pf,
  pure $ ps'.set_info ps_o pf

end rewrite

/--
Represents the way in which two products are equal except coefficient.

This type is used in the function `add_overlap`.
In order to deal with equations of the form `a * 2 + a = 3 * a`,
the `add` function will add up overlapping products,
turning `a * 2 + a` into `a * 3`.
We need to distinguish `a * 2 + a` from `a * 2 + b` in order to do this,
and the `overlap` type carries the information on how it overlaps.

The case `none` corresponds to non-overlapping products, e.g. `a * 2 + b`;
the case `nonzero` to overlapping products adding to non-zero, e.g. `a * 2 + a`
(the `ex prod` field will then look like `a * 3` with a proof that `a * 2 + a = a * 3`);
the case `zero` to overlapping products adding to zero, e.g. `a * 2 + a * -2`.
We distinguish those two cases because in the second, the whole product reduces to `0`.

A potential extension to the tactic would also do this for the base of exponents,
e.g. to show `2^n * 2^n = 4^n`.
-/
meta inductive overlap : Type
| none : overlap
| nonzero : ex prod → overlap
| zero : ex sum → overlap

lemma add_overlap_pf {ps qs pq} (p : α) : ps + qs = pq → p * ps + p * qs = p * pq := λ pq_pf, calc
  p * ps + p * qs = p * (ps + qs) : symm (mul_add _ _ _)
  ... = p * pq : by rw pq_pf

lemma add_overlap_pf_zero {ps qs} (p : α) : ps + qs = 0 → p * ps + p * qs = 0 := λ pq_pf, calc
  p * ps + p * qs = p * (ps + qs) : symm (mul_add _ _ _)
  ... = p * 0 : by rw pq_pf
  ... = 0 : mul_zero _

/--
Given arguments `ps`, `qs` of the form `ps' * x` and `ps' * y` respectively
return `ps + qs = ps' * (x + y)` (with `x` and `y` arbitrary coefficients).
For other arguments, return `overlap.none`.
-/
meta def add_overlap : ex prod → ex prod → ring_exp_m overlap
| (ex.coeff x_i x) (ex.coeff y_i y) := do
  xy@(ex.coeff _ xy_c) ← add_coeff x_i.pretty y_i.pretty x y
    | lift $ fail "internal error: add_coeff should return ex.coeff",
  if xy_c.1 = 0
  then do
    z ← ex_zero,
    pure $ overlap.zero (z.set_info xy.orig xy.proof)
  else pure $ overlap.nonzero xy
| (ex.prod _ _ _) (ex.coeff _ _) := pure overlap.none
| (ex.coeff _ _) (ex.prod _ _ _) := pure overlap.none
| pps@(ex.prod _ p ps) qqs@(ex.prod _ q qs) := if p.eq q
  then do
    pq_ol ← add_overlap ps qs,
    pqs_o ← add_orig pps qqs,
    match pq_ol with
    | overlap.none := pure overlap.none
    | (overlap.nonzero pq) := do
      pqs ← ex_prod p pq,
      pf ← mk_proof ``add_overlap_pf
        [ps.pretty, qs.pretty, pq.pretty, p.pretty]
        [pq.info],
      pure $ overlap.nonzero (pqs.set_info pqs_o pf)
    | (overlap.zero pq) := do
      z ← ex_zero,
      pf ← mk_proof ``add_overlap_pf_zero
        [ps.pretty, qs.pretty, p.pretty]
        [pq.info],
      pure $ overlap.zero (z.set_info pqs_o pf)
    end
  else pure overlap.none

section addition

lemma add_pf_z_sum {ps qs qs' : α} : ps = 0 → qs = qs' → ps + qs = qs' := λ ps_pf qs_pf, calc
  ps + qs = 0 + qs' : by rw [ps_pf, qs_pf]
  ... = qs' : zero_add _

lemma add_pf_sum_z {ps ps' qs : α} : ps = ps' → qs = 0 → ps + qs = ps' := λ ps_pf qs_pf, calc
  ps + qs = ps' + 0 : by rw [ps_pf, qs_pf]
  ... = ps' : add_zero _

lemma add_pf_sum_overlap {pps p ps qqs q qs pq pqs : α} :
  pps = p + ps → qqs = q + qs → p + q = pq → ps + qs = pqs → pps + qqs = pq + pqs := by cc

lemma add_pf_sum_overlap_zero {pps p ps qqs q qs pqs : α} :
  pps = p + ps → qqs = q + qs → p + q = 0 → ps + qs = pqs → pps + qqs = pqs :=
λ pps_pf qqs_pf pq_pf pqs_pf, calc
  pps + qqs = (p + ps) + (q + qs) : by rw [pps_pf, qqs_pf]
  ... = (p + q) + (ps + qs) : by cc
  ... = 0 + pqs : by rw [pq_pf, pqs_pf]
  ... = pqs : zero_add _

lemma add_pf_sum_lt {pps p ps qqs pqs : α} :
  pps = p + ps → ps + qqs = pqs → pps + qqs = p + pqs := by cc

lemma add_pf_sum_gt {pps qqs q qs pqs : α} :
  qqs = q + qs → pps + qs = pqs → pps + qqs = q + pqs := by cc

/--
Add two expressions.

* `0 + qs = 0`
* `ps + 0 = 0`
* `ps * x + ps * y = ps * (x + y)` (for `x`, `y` coefficients; uses `add_overlap`)
* `(p + ps) + (q + qs) = p + (ps + (q + qs))` (if `p.lt q`)
* `(p + ps) + (q + qs) = q + ((p + ps) + qs)` (if not `p.lt q`)
-/
meta def add : ex sum → ex sum → ring_exp_m (ex sum)
| ps@(ex.zero ps_i) qs := do
  pf ← mk_proof ``add_pf_z_sum [ps.orig, qs.orig, qs.pretty] [ps.info, qs.info],
  pqs_o ← add_orig ps qs,
  pure $ qs.set_info pqs_o pf
| ps qs@(ex.zero qs_i) := do
  pf ← mk_proof ``add_pf_sum_z [ps.orig, ps.pretty, qs.orig] [ps.info, qs.info],
  pqs_o ← add_orig ps qs,
  pure $ ps.set_info pqs_o pf
| pps@(ex.sum pps_i p ps) qqs@(ex.sum qqs_i q qs) := do
  ol ← add_overlap p q,
  ppqqs_o ← add_orig pps qqs,
  match ol with
  | (overlap.nonzero pq) := do
    pqs ← add ps qs,
    pqqs ← ex_sum pq pqs,
    qqs_pf ← qqs.proof_term,
    pf ← mk_proof ``add_pf_sum_overlap
      [pps.orig, p.pretty, ps.pretty, qqs.orig, q.pretty, qs.pretty, pq.pretty, pqs.pretty]
      [pps.info, qqs.info, pq.info, pqs.info],
    pure $ pqqs.set_info ppqqs_o pf
  | (overlap.zero pq) := do
    pqs ← add ps qs,
    pf ← mk_proof ``add_pf_sum_overlap_zero
      [pps.orig, p.pretty, ps.pretty, qqs.orig, q.pretty, qs.pretty, pqs.pretty]
      [pps.info, qqs.info, pq.info, pqs.info],
    pure $ pqs.set_info ppqqs_o pf
  | overlap.none := if p.lt q
  then do
    pqs ← add ps qqs,
    ppqs ← ex_sum p pqs,
    pf ← mk_proof ``add_pf_sum_lt
      [pps.orig, p.pretty, ps.pretty, qqs.orig, pqs.pretty]
      [pps.info, pqs.info],
    pure $ ppqs.set_info ppqqs_o pf
  else do
    pqs ← add pps qs,
    pqqs ← ex_sum q pqs,
    pf ← mk_proof ``add_pf_sum_gt
      [pps.orig, qqs.orig, q.pretty, qs.pretty, pqs.pretty]
      [qqs.info, pqs.info],
    pure $ pqqs.set_info ppqqs_o pf
  end

end addition

section multiplication
lemma mul_pf_c_c {ps ps' qs qs' pq : α} :
  ps = ps' → qs = qs' → ps' * qs' = pq → ps * qs = pq := by cc

lemma mul_pf_c_prod {ps qqs q qs pqs : α} :
  qqs = q * qs → ps * qs = pqs → ps * qqs = q * pqs := by cc

lemma mul_pf_prod_c {pps p ps qs pqs : α} :
  pps = p * ps → ps * qs = pqs → pps * qs = p * pqs := by cc

lemma mul_pp_pf_overlap {pps p_b ps qqs qs psqs : α} {p_e q_e : ℕ} :
  pps = p_b ^ p_e * ps → qqs = p_b ^ q_e * qs →
  p_b ^ (p_e + q_e) * (ps * qs) = psqs → pps * qqs = psqs
:= λ ps_pf qs_pf psqs_pf, by simp [symm psqs_pf, pow_add, ps_pf, qs_pf]; ac_refl

lemma mul_pp_pf_prod_lt {pps p ps qqs pqs : α} :
  pps = p * ps → ps * qqs = pqs → pps * qqs = p * pqs := by cc

lemma mul_pp_pf_prod_gt {pps qqs q qs pqs : α} :
  qqs = q * qs → pps * qs = pqs → pps * qqs = q * pqs := by cc

/--
Multiply two expressions.

* `x * y = (x * y)` (for `x`, `y` coefficients)
* `x * (q * qs) = q * (qs * x)` (for `x` coefficient)
* `(p * ps) * y = p * (ps * y)` (for `y` coefficient)
* `(p_b^p_e * ps) * (p_b^q_e * qs) = p_b^(p_e + q_e) * (ps * qs)`
    (if `p_e` and `q_e` are identical except coefficient)
* `(p * ps) * (q * qs) = p * (ps * (q * qs))` (if `p.lt q`)
* `(p * ps) * (q * qs) = q * ((p * ps) * qs)` (if not `p.lt q`)
-/
meta def mul_pp : ex prod → ex prod → ring_exp_m (ex prod)
| ps@(ex.coeff _ x) qs@(ex.coeff _ y) := do
  pq ← mul_coeff ps.pretty qs.pretty x y,
  pq_o ← mul_orig ps qs,
  pf ← mk_proof_or_refl pq.pretty ``mul_pf_c_c
    [ps.orig, ps.pretty, qs.orig, qs.pretty, pq.pretty]
    [ps.info, qs.info, pq.info],
  pure $ pq.set_info pq_o pf
| ps@(ex.coeff _ x) qqs@(ex.prod _ q qs) := do
  pqs ← mul_pp ps qs,
  pqqs ← ex_prod q pqs,
  pqqs_o ← mul_orig ps qqs,
  pf ← mk_proof ``mul_pf_c_prod
    [ps.orig, qqs.orig, q.pretty, qs.pretty, pqs.pretty]
    [qqs.info, pqs.info],
  pure $ pqqs.set_info pqqs_o pf
| pps@(ex.prod _ p ps) qs@(ex.coeff _ y) := do
  pqs ← mul_pp ps qs,
  ppqs ← ex_prod p pqs,
  ppqs_o ← mul_orig pps qs,
  pf ← mk_proof ``mul_pf_prod_c
    [pps.orig, p.pretty, ps.pretty, qs.orig, pqs.pretty]
    [pps.info, pqs.info],
  pure $ ppqs.set_info ppqs_o pf
  | pps@(ex.prod _ p@(ex.exp _ p_b p_e) ps) qqs@(ex.prod _ q@(ex.exp _ q_b q_e) qs) := do
  ppqqs_o ← mul_orig pps qqs,
  pq_ol ← in_exponent $ add_overlap p_e q_e,
  match pq_ol, p_b.eq q_b with
  | (overlap.nonzero pq_e), tt := do
    psqs ← mul_pp ps qs,
    pq ← ex_exp p_b pq_e,
    ppsqqs ← ex_prod pq psqs,
    pf ← mk_proof ``mul_pp_pf_overlap
      [pps.orig, p_b.pretty, ps.pretty, qqs.orig, qs.pretty, ppsqqs.pretty, p_e.pretty, q_e.pretty]
      [pps.info, qqs.info, ppsqqs.info],
    pure $ ppsqqs.set_info ppqqs_o pf
  | _, _ := if p.lt q  then do
    pqs ← mul_pp ps qqs,
    ppqs ← ex_prod p pqs,
    pf ← mk_proof ``mul_pp_pf_prod_lt
      [pps.orig, p.pretty, ps.pretty, qqs.orig, pqs.pretty]
      [pps.info, pqs.info],
    pure $ ppqs.set_info ppqqs_o pf
  else do
    pqs ← mul_pp pps qs,
    pqqs ← ex_prod q pqs,
    pf ← mk_proof ``mul_pp_pf_prod_gt
      [pps.orig, qqs.orig, q.pretty, qs.pretty, pqs.pretty]
      [qqs.info, pqs.info],
    pure $ pqqs.set_info ppqqs_o pf
  end

lemma mul_p_pf_zero {ps qs : α} : ps = 0 → ps * qs = 0 :=
λ ps_pf, by rw [ps_pf, zero_mul]

lemma mul_p_pf_sum {pps p ps qs ppsqs : α} : pps = p + ps →
  p * qs + ps * qs = ppsqs → pps * qs = ppsqs := λ pps_pf ppsqs_pf, calc
  pps * qs = (p + ps) * qs : by rw [pps_pf]
  ... = p * qs + ps * qs : add_mul _ _ _
  ... = ppsqs : ppsqs_pf

/--
Multiply two expressions.

* `0 * qs = 0`
* `(p + ps) * qs = (p * qs) + (ps * qs)`
-/
meta def mul_p : ex sum → ex prod → ring_exp_m (ex sum)
| ps@(ex.zero ps_i) qs := do
  z ← ex_zero,
  z_o ← mul_orig ps qs,
  pf ← mk_proof ``mul_p_pf_zero [ps.orig, qs.orig] [ps.info],
  pure $ z.set_info z_o pf
| pps@(ex.sum pps_i p ps) qs := do
  pqs ← mul_pp p qs >>= prod_to_sum,
  psqs ← mul_p ps qs,
  ppsqs ← add pqs psqs,
  pps_pf ← pps.proof_term,
  ppsqs_o ← mul_orig pps qs,
  ppsqs_pf ← ppsqs.proof_term,
  pf ← mk_proof ``mul_p_pf_sum
    [pps.orig, p.pretty, ps.pretty, qs.orig, ppsqs.pretty]
    [pps.info, ppsqs.info],
  pure $ ppsqs.set_info ppsqs_o pf

lemma mul_pf_zero {ps qs : α} : qs = 0 → ps * qs = 0 :=
λ qs_pf, by rw [qs_pf, mul_zero]

lemma mul_pf_sum {ps qqs q qs psqqs : α} : qqs = q + qs → ps * q + ps * qs = psqqs →
  ps * qqs = psqqs := λ qs_pf psqqs_pf, calc
  ps * qqs = ps * (q + qs) : by rw [qs_pf]
  ... = ps * q + ps * qs : mul_add _ _ _
  ... = psqqs : psqqs_pf

/--
Multiply two expressions.

* `ps * 0 = 0`
* `ps * (q + qs) = (ps * q) + (ps * qs)`
-/
meta def mul : ex sum → ex sum → ring_exp_m (ex sum)
| ps qs@(ex.zero qs_i) := do
  z ← ex_zero,
  z_o ← mul_orig ps qs,
  pf ← mk_proof ``mul_pf_zero [ps.orig, qs.orig] [qs.info],
  pure $ z.set_info z_o pf
| ps qqs@(ex.sum qqs_i q qs) := do
  psq ← mul_p ps q,
  psqs ← mul ps qs,
  psqqs ← add psq psqs,
  psqqs_o ← mul_orig ps qqs,
  pf ← mk_proof ``mul_pf_sum
    [ps.orig, qqs.orig, q.orig, qs.orig, psqqs.pretty]
    [qqs.info, psqqs.info],
  pure $ psqqs.set_info psqqs_o pf
end multiplication

section exponentiation
lemma pow_e_pf_exp {pps p : α} {ps qs psqs : ℕ} :
  pps = p ^ ps → ps * qs = psqs → pps ^ qs = p ^ psqs :=
λ pps_pf psqs_pf, calc
  pps ^ qs = (p ^ ps) ^ qs : by rw [pps_pf]
  ... = p ^ (ps * qs) : symm (pow_mul _ _ _)
  ... = p ^ psqs : by rw [psqs_pf]

/--
Compute the exponentiation of two coefficients.

The returned value is of the form `ex.coeff _ (p ^ q)`,
with the proof of `expr.of_rat p ^ expr.of_rat q = expr.of_rat (p ^ q)`.
-/
meta def pow_coeff (p_p q_p : expr) (p q : coeff) : ring_exp_m (ex prod) := do
  ctx ← get_context,
  pq' ← mk_pow [p_p, q_p],
  (pq_p, pq_pf) ← lift $ norm_num.eval_pow pq',
  if q.value.denom ≠ 1 then lift $ fail!"Only integer powers are supported, not {q.value}."
  else pure $ ex.coeff ⟨pq_p, pq_p, pq_pf⟩ ⟨p.1 ^ q.value.num⟩

/--
Exponentiate two expressions.

* `(p ^ ps) ^ qs = p ^ (ps * qs)`
-/
meta def pow_e : ex exp → ex prod → ring_exp_m (ex exp)
| pps@(ex.exp pps_i p ps) qs := do
  psqs ← in_exponent $ mul_pp ps qs,
  ppsqs ← ex_exp p psqs,
  ppsqs_o ← pow_orig pps qs,
  pf ← mk_proof ``pow_e_pf_exp
    [pps.orig, p.pretty, ps.pretty, qs.orig, psqs.pretty]
    [pps.info, psqs.info],
  pure $ ppsqs.set_info ppsqs_o pf

lemma pow_pf_c_c {ps ps' pq : α} {qs qs' : ℕ} :
  ps = ps' → qs = qs' → ps' ^ qs' = pq → ps ^ qs = pq := by cc

lemma pow_pp_pf_c {ps ps' pqs : α} {qs qs' : ℕ} :
  ps = ps' → qs = qs' → ps' ^ qs' = pqs → ps ^ qs = pqs * 1 :=
by simp; cc

lemma pow_pp_pf_prod {pps p ps pqs psqs : α} {qs : ℕ} : pps = p * ps →
  p ^ qs = pqs → ps ^ qs = psqs → pps ^ qs = pqs * psqs :=
λ pps_pf pqs_pf psqs_pf, calc
    pps ^ qs = (p * ps) ^ qs : by rw [pps_pf]
    ... = p ^ qs * ps ^ qs : mul_pow _ _ _
    ... = pqs * psqs : by rw [pqs_pf, psqs_pf]

/--
Exponentiate two expressions.

* `1 ^ qs = 1`
* `x ^ qs = x ^ qs` (for `x` coefficient)
* `(p * ps) ^ qs = p ^ qs + ps ^ qs`
-/
meta def pow_pp : ex prod → ex prod → ring_exp_m (ex prod)
| ps@(ex.coeff ps_i ⟨⟨1, 1, _, _⟩⟩) qs := do
  o ← ex_one,
  o_o ← pow_orig ps qs,
  pf ← mk_proof ``pow_pp_pf_one [ps.orig, qs.orig] [ps.info],
  pure $ o.set_info o_o pf
| ps@(ex.coeff ps_i x) qs@(ex.coeff qs_i y) := do
  pq ← pow_coeff ps.pretty qs.pretty x y,
  pq_o ← pow_orig ps qs,
  pf ← mk_proof_or_refl pq.pretty ``pow_pf_c_c
    [ps.orig, ps.pretty, pq.pretty, qs.orig, qs.pretty]
    [ps.info, qs.info, pq.info],
  pure $ pq.set_info pq_o pf
| ps@(ex.coeff ps_i x) qs := do
  ps'' ← pure ps >>= prod_to_sum >>= ex_sum_b,
  pqs ← ex_exp ps'' qs,
  pqs_o ← pow_orig ps qs,
  pf ← mk_proof_or_refl pqs.pretty ``pow_pp_pf_c
    [ps.orig, ps.pretty, pqs.pretty, qs.orig, qs.pretty]
    [ps.info, qs.info, pqs.info],
  pqs' ← exp_to_prod pqs,
  pure $ pqs'.set_info pqs_o pf
| pps@(ex.prod pps_i p ps) qs := do
  pqs ← pow_e p qs,
  psqs ← pow_pp ps qs,
  ppsqs ← ex_prod pqs psqs,
  ppsqs_o ← pow_orig pps qs,
  pf ← mk_proof ``pow_pp_pf_prod
    [pps.orig, p.pretty, ps.pretty, pqs.pretty, psqs.pretty, qs.orig]
    [pps.info, pqs.info, psqs.info],
  pure $ ppsqs.set_info ppsqs_o pf

lemma pow_p_pf_one {ps ps' : α} {qs : ℕ} : ps = ps' → qs = succ zero → ps ^ qs = ps' :=
λ ps_pf qs_pf, calc
  ps ^ qs = ps' ^ 1 : by rw [ps_pf, qs_pf]
  ... = ps' : pow_one _

lemma pow_p_pf_zero {ps : α} {qs qs' : ℕ} : ps = 0 → qs = succ qs' → ps ^ qs = 0 :=
λ ps_pf qs_pf, calc
  ps ^ qs = 0 ^ (succ qs') : by rw [ps_pf, qs_pf]
  ... = 0 : zero_pow (succ_pos qs')

lemma pow_p_pf_succ {ps pqqs : α} {qs qs' : ℕ} :
  qs = succ qs' → ps * ps ^ qs' = pqqs → ps ^ qs = pqqs :=
λ qs_pf pqqs_pf, calc
  ps ^ qs = ps ^ succ qs' : by rw [qs_pf]
  ... = ps * ps ^ qs' : pow_succ _ _
  ... = pqqs : by rw [pqqs_pf]

lemma pow_p_pf_singleton {pps p pqs : α} {qs : ℕ} :
  pps = p + 0 → p ^ qs = pqs → pps ^ qs = pqs :=
λ pps_pf pqs_pf, by rw [pps_pf, add_zero, pqs_pf]

lemma pow_p_pf_cons {ps ps' : α} {qs qs' : ℕ} :
  ps = ps' → qs = qs' → ps ^ qs = ps' ^ qs' := by cc
/--
Exponentiate two expressions.

* `ps ^ 1 = ps`
* `0 ^ qs = 0` (note that this is handled *after* `ps ^ 0 = 1`)
* `(p + 0) ^ qs = p ^ qs`
* `ps ^ (qs + 1) = ps * ps ^ qs` (note that this is handled *after* `p + 0 ^ qs = p ^ qs`)
* `ps ^ qs = ps ^ qs` (otherwise)
-/
meta def pow_p : ex sum → ex prod → ring_exp_m (ex sum)
| ps qs@(ex.coeff qs_i ⟨⟨1, 1, _, _⟩⟩) := do
  ps_o ← pow_orig ps qs,
  pf ← mk_proof ``pow_p_pf_one [ps.orig, ps.pretty, qs.orig] [ps.info, qs.info],
  pure $ ps.set_info ps_o pf
| ps@(ex.zero ps_i) qs@(ex.coeff qs_i ⟨⟨succ y, 1, _, _⟩⟩) := do
  ctx ← get_context,
  z ← ex_zero,
  qs_pred ← lift $ expr.of_nat ctx.info_e.α y,
  pf ← mk_proof ``pow_p_pf_zero [ps.orig, qs.orig, qs_pred] [ps.info, qs.info],
  z_o ← pow_orig ps qs,
  pure $ z.set_info z_o pf
| pps@(ex.sum pps_i p (ex.zero _)) qqs := do
  pqs ← pow_pp p qqs,
  pqs_o ← pow_orig pps qqs,
  pf ← mk_proof ``pow_p_pf_singleton
    [pps.orig, p.pretty, pqs.pretty, qqs.orig]
    [pps.info, pqs.info],
  prod_to_sum $ pqs.set_info pqs_o pf
| ps qs@(ex.coeff qs_i ⟨⟨int.of_nat (succ n), 1, den_pos, _⟩⟩) := do
  qs' ← in_exponent $ ex_coeff ⟨int.of_nat n, 1, den_pos, coprime_one_right _⟩,
  pqs ← pow_p ps qs',
  pqqs ← mul ps pqs,
  pqqs_o ← pow_orig ps qs,
  pf ← mk_proof ``pow_p_pf_succ
    [ps.orig, pqqs.pretty, qs.orig, qs'.pretty]
    [qs.info, pqqs.info],
  pure $ pqqs.set_info pqqs_o pf
| pps qqs := do -- fallback: treat them as atoms
  pps' ← ex_sum_b pps,
  psqs ← ex_exp pps' qqs,
  psqs_o ← pow_orig pps qqs,
  pf ← mk_proof_or_refl psqs.pretty ``pow_p_pf_cons
    [pps.orig, pps.pretty, qqs.orig, qqs.pretty]
    [pps.info, qqs.info],
  exp_to_prod (psqs.set_info psqs_o pf) >>= prod_to_sum

lemma pow_pf_zero {ps : α} {qs : ℕ} : qs = 0 → ps ^ qs = 1 := λ qs_pf, calc
  ps ^ qs = ps ^ 0 : by rw [qs_pf]
  ... = 1 : pow_zero _

lemma pow_pf_sum {ps psqqs : α} {qqs q qs : ℕ} : qqs = q + qs →
  ps ^ q * ps ^ qs = psqqs → ps ^ qqs = psqqs := λ qqs_pf psqqs_pf, calc
    ps ^ qqs = ps ^ (q + qs) : by rw [qqs_pf]
    ... = ps ^ q * ps ^ qs : pow_add _ _ _
    ... = psqqs : psqqs_pf
/--
Exponentiate two expressions.

* `ps ^ 0 = 1`
* `ps ^ (q + qs) = ps ^ q * ps ^ qs`
-/
meta def pow : ex sum → ex sum → ring_exp_m (ex sum)
| ps qs@(ex.zero qs_i) := do
  o ← ex_one,
  o_o ← pow_orig ps qs,
  pf ← mk_proof ``pow_pf_zero [ps.orig, qs.orig] [qs.info],
  prod_to_sum $ o.set_info o_o pf
| ps qqs@(ex.sum qqs_i q qs) := do
  psq ← pow_p ps q,
  psqs ← pow ps qs,
  psqqs ← mul psq psqs,
  psqqs_o ← pow_orig ps qqs,
  pf ← mk_proof ``pow_pf_sum
    [ps.orig, psqqs.pretty, qqs.orig, q.pretty, qs.pretty]
    [qqs.info, psqqs.info],
  pure $ psqqs.set_info psqqs_o pf
 end exponentiation

lemma simple_pf_sum_zero {p p' : α} : p = p' → p + 0 = p' := by simp

lemma simple_pf_prod_one {p p' : α} : p = p' → p * 1 = p' := by simp

lemma simple_pf_prod_neg_one {α} [ring α] {p p' : α} : p = p' → p * -1 = - p' := by simp

lemma simple_pf_var_one (p : α) : p ^ 1 = p := by simp

lemma simple_pf_exp_one {p p' : α} : p = p' → p ^ 1 = p' := by simp

/--
Give a simpler, more human-readable representation of the normalized expression.

Normalized expressions might have the form `a^1 * 1 + 0`,
since the dummy operations reduce special cases in pattern-matching.
Humans prefer to read `a` instead.
This tactic gets rid of the dummy additions, multiplications and exponentiations.

Returns a normalized expression `e'` and a proof that `e.pretty = e'`.
-/
meta def ex.simple : Π {et : ex_type}, ex et → ring_exp_m (expr × expr)
| sum pps@(ex.sum pps_i p (ex.zero _)) := do
  (p_p, p_pf) ← p.simple,
  prod.mk p_p <$> mk_app_csr ``simple_pf_sum_zero [p.pretty, p_p, p_pf]
| sum (ex.sum pps_i p ps) := do
  (p_p, p_pf) ← p.simple,
  (ps_p, ps_pf) ← ps.simple,
  prod.mk
    <$> mk_add [p_p, ps_p]
    <*> mk_app_csr ``sum_congr [p.pretty, p_p, ps.pretty, ps_p, p_pf, ps_pf]
| prod (ex.prod pps_i p (ex.coeff _ ⟨⟨1, 1, _, _⟩⟩)) := do
  (p_p, p_pf) ← p.simple,
  prod.mk p_p <$> mk_app_csr ``simple_pf_prod_one [p.pretty, p_p, p_pf]
| prod pps@(ex.prod pps_i p (ex.coeff _ ⟨⟨-1, 1, _, _⟩⟩)) := do
  ctx ← get_context,
  match ctx.info_b.ring_instance with
  | none := prod.mk pps.pretty <$> lift (mk_eq_refl pps.pretty)
  | (some ringi) := do
    (p_p, p_pf) ← p.simple,
    prod.mk
      <$> lift (mk_app ``has_neg.neg [p_p])
      <*> mk_app_class ``simple_pf_prod_neg_one ringi [p.pretty, p_p, p_pf]
  end
| prod (ex.prod pps_i p ps) := do
  (p_p, p_pf) ← p.simple,
  (ps_p, ps_pf) ← ps.simple,
  prod.mk
    <$> mk_mul [p_p, ps_p]
    <*> mk_app_csr ``prod_congr [p.pretty, p_p, ps.pretty, ps_p, p_pf, ps_pf]
| base (ex.sum_b pps_i ps) := ps.simple
| exp (ex.exp pps_i p (ex.coeff _ ⟨⟨1, 1, _, _⟩⟩)) := do
  (p_p, p_pf) ← p.simple,
  prod.mk p_p <$> mk_app_csr ``simple_pf_exp_one [p.pretty, p_p, p_pf]
| exp (ex.exp pps_i p ps) := do
  (p_p, p_pf) ← p.simple,
  (ps_p, ps_pf) ← in_exponent $ ps.simple,
  prod.mk
    <$> mk_pow [p_p, ps_p]
    <*> mk_app_csr ``exp_congr [p.pretty, p_p, ps.pretty, ps_p, p_pf, ps_pf]
| et ps := prod.mk ps.pretty <$> lift (mk_eq_refl ps.pretty)

/--
Performs a lookup of the atom `a` in the list of known atoms,
or allocates a new one.

If `a` is not definitionally equal to any of the list's entries,
a new atom is appended to the list and returned.
The index of this atom is kept track of in the second inductive argument.

This function is mostly useful in `resolve_atom`,
which updates the state with the new list of atoms.
-/
meta def resolve_atom_aux (a : expr) : list atom → ℕ → ring_exp_m (atom × list atom)
| [] n := let atm : atom := ⟨a, n⟩ in pure (atm, [atm])
| bas@(b :: as) n := do
  ctx ← get_context,
  (lift $ is_def_eq a b.value ctx.transp >> pure (b , bas)) <|> do
  (atm, as') ← resolve_atom_aux as (succ n),
  pure (atm, b :: as')

/--
Convert the expression to an atom:
either look up a definitionally equal atom,
or allocate it as a new atom.

You probably want to use `eval_base` if `eval` doesn't work
instead of directly calling `resolve_atom`,
since `eval_base` can also handle numerals.
-/
meta def resolve_atom (a : expr) : ring_exp_m atom := do
  atoms ← reader_t.lift $ state_t.get,
  (atm, atoms') ← resolve_atom_aux a atoms 0,
  reader_t.lift $ state_t.put atoms',
  pure atm

/--
Treat the expression atomically: as a coefficient or atom.

Handles cases where `eval` cannot treat the expression as a known operation
because it is just a number or single variable.
-/
meta def eval_base (ps : expr) : ring_exp_m (ex sum) :=
match ps.to_rat with
| some ⟨0, 1, _, _⟩ := ex_zero
| some x := ex_coeff x >>= prod_to_sum
| none := do
  a ← resolve_atom ps,
  atom_to_sum a
end

lemma negate_pf {α} [ring α] {ps ps' : α} : (-1) * ps = ps' → -ps = ps' := by simp

/--
Negate an expression by multiplying with `-1`.

Only works if there is a `ring` instance; otherwise it will `fail`.
-/
meta def negate (ps : ex sum) : ring_exp_m (ex sum) := do
  ctx ← get_context,
  match ctx.info_b.ring_instance with
  | none := lift $ fail "internal error: negate called in semiring"
  | (some ring_instance) := do
    minus_one ← ex_coeff (-1) >>= prod_to_sum,
    ps' ← mul minus_one ps,
    ps_pf ← ps'.proof_term,
    pf ← mk_app_class ``negate_pf ring_instance [ps.orig, ps'.pretty, ps_pf],
    ps'_o ← lift $ mk_app ``has_neg.neg [ps.orig],
    pure $ ps'.set_info ps'_o pf
  end

lemma inverse_pf {α} [division_ring α] {ps ps_u ps_p e' e'' : α} :
  ps = ps_u → ps_u = ps_p → ps_p ⁻¹ = e' → e' = e'' → ps ⁻¹ = e'' :=
by cc

/--
Invert an expression by simplifying, applying `has_inv.inv` and treating the result as an atom.

Only works if there is a `division_ring` instance; otherwise it will `fail`.
-/
meta def inverse (ps : ex sum) : ring_exp_m (ex sum) := do
  ctx ← get_context,
  dri ← match ctx.info_b.dr_instance with
  | none := lift $ fail "division is only supported in a division ring"
  | (some dri) := pure dri
  end,
  (ps_simple, ps_simple_pf) ← ps.simple,
  e ← lift $ mk_app ``has_inv.inv [ps_simple],
  (e', e_pf) ← lift (norm_num.derive e) <|> ((λ e_pf, (e, e_pf)) <$> lift (mk_eq_refl e)),
  e'' ← eval_base e',
  ps_pf ← ps.proof_term,
  e''_pf ← e''.proof_term,
  pf ← mk_app_class ``inverse_pf dri
    [ ps.orig, ps.pretty, ps_simple, e', e''.pretty,
      ps_pf, ps_simple_pf, e_pf, e''_pf],
  e''_o ← lift $ mk_app ``has_inv.inv [ps.orig],
  pure $ e''.set_info e''_o pf

lemma sub_pf {α} [ring α] {ps qs psqs : α} (h : ps + -qs = psqs) : ps - qs = psqs :=
by rwa sub_eq_add_neg

lemma div_pf {α} [division_ring α] {ps qs psqs : α} (h : ps * qs⁻¹ = psqs) : ps / qs = psqs :=
by rwa div_eq_mul_inv

end operations

section wiring
/-!
### `wiring` section

This section deals with going from `expr` to `ex` and back.

The main attraction is `eval`, which uses `add`, `mul`, etc.
to calculate an `ex` from a given `expr`.
Other functions use `ex`es to produce `expr`s together with a proof,
or produce the context to run `ring_exp_m` from an `expr`.
-/

open tactic
open ex_type

/--
Compute a normalized form (of type `ex`) from an expression (of type `expr`).

This is the main driver of the `ring_exp` tactic,
calling out to `add`, `mul`, `pow`, etc. to parse the `expr`.
-/
meta def eval : expr → ring_exp_m (ex sum)
| e@`(%%ps + %%qs) := do
  ps' ← eval ps,
  qs' ← eval qs,
  add ps' qs'
| ps_o@`(nat.succ %%p_o) := do
  ps' ← eval `(%%p_o + 1),
  pf ← lift $ mk_app ``nat.succ_eq_add_one [p_o],
  rewrite ps_o ps' pf
| e@`(%%ps - %%qs) := (do
  ctx ← get_context,
  ri ← match ctx.info_b.ring_instance with
  | none := lift $ fail "subtraction is not directly supported in a semiring"
  | (some ri) := pure ri
  end,
  ps' ← eval ps,
  qs' ← eval qs >>= negate,
  psqs ← add ps' qs',
  psqs_pf ← psqs.proof_term,
  pf ← mk_app_class ``sub_pf ri [ps, qs, psqs.pretty, psqs_pf],
  pure (psqs.set_info e pf)) <|> eval_base e
| e@`(- %%ps) := do
  ps' ← eval ps,
  negate ps' <|> eval_base e
| e@`(%%ps * %%qs) := do
  ps' ← eval ps,
  qs' ← eval qs,
  mul ps' qs'
| e@`(has_inv.inv %%ps) := do
  ps' ← eval ps,
  inverse ps' <|> eval_base e
| e@`(%%ps / %%qs) := do
  ctx ← get_context,
  dri ← match ctx.info_b.dr_instance with
  | none := lift $ fail "division is only directly supported in a division ring"
  | (some dri) := pure dri
  end,
  ps' ← eval ps,
  qs' ← eval qs,
  (do qs'' ← inverse qs',
  psqs ← mul ps' qs'',
  psqs_pf ← psqs.proof_term,
  pf ← mk_app_class ``div_pf dri [ps, qs, psqs.pretty, psqs_pf],
  pure (psqs.set_info e pf)) <|> eval_base e
| e@`(@has_pow.pow _ _ %%hp_instance %%ps %%qs) := do
  ctx ← get_context,
  ps' ← eval ps,
  qs' ← in_exponent $ eval qs,
  psqs ← pow ps' qs',
  psqs_pf ← psqs.proof_term,
  (do
    lift (is_def_eq hp_instance ctx.info_b.hp_instance
          <|> fail "has_pow instance must be nat.has_pow or monoid.has_pow"),
    has_pow_pf ← lift $ mk_eq_refl e,
    pf ← lift $ mk_eq_trans has_pow_pf psqs_pf,
    pure $ psqs.set_info e pf) <|> eval_base e
| ps := eval_base ps

/--
Run `eval` on the expression and return the result together with normalization proof.

See also `eval_simple` if you want something that behaves like `norm_num`.
-/
meta def eval_with_proof (e : expr) : ring_exp_m (ex sum × expr) := do
  e' ← eval e,
  prod.mk e' <$> e'.proof_term

/--
Run `eval` on the expression and simplify the result.

Returns a simplified normalized expression, together with an equality proof.

See also `eval_with_proof` if you just want to check the equality of two expressions.
-/
meta def eval_simple (e : expr) : ring_exp_m (expr × expr) := do
  (complicated, complicated_pf) ← eval_with_proof e,
  (simple, simple_pf) ← complicated.simple,
  prod.mk simple <$> lift (mk_eq_trans complicated_pf simple_pf)

/-- Compute the `eval_info` for a given type `α`. -/
meta def make_eval_info (α : expr) : tactic eval_info := do
  u ← mk_meta_univ,
  infer_type α >>= unify (expr.sort (level.succ u)),
  u ← get_univ_assignment u,
  csr_instance ← mk_app ``comm_semiring [α] >>= mk_instance,
  ring_instance ← (some <$> (mk_app ``ring [α] >>= mk_instance) <|> pure none),
  dr_instance ← (some <$> (mk_app ``division_ring [α] >>= mk_instance) <|> pure none),
  ha_instance ← mk_app ``has_add [α] >>= mk_instance,
  hm_instance ← mk_app ``has_mul [α] >>= mk_instance,
  hp_instance ← mk_mapp ``monoid.has_pow [some α, none],
  z ← mk_mapp ``has_zero.zero [α, none],
  o ← mk_mapp ``has_one.one [α, none],
  pure ⟨α, u, csr_instance, ha_instance, hm_instance, hp_instance, ring_instance, dr_instance, z, o⟩

/-- Use `e` to build the context for running `mx`. -/
meta def run_ring_exp {α} (transp : transparency) (e : expr) (mx : ring_exp_m α) : tactic α := do
  info_b ← infer_type e >>= make_eval_info,
  info_e ← mk_const ``nat >>= make_eval_info,
  (λ x : (_ × _), x.1) <$> (state_t.run (reader_t.run mx ⟨info_b, info_e, transp⟩) [])

/-- Repeatedly apply `eval_simple` on (sub)expressions. -/
meta def normalize (transp : transparency) (e : expr) : tactic (expr × expr) := do
  (_, e', pf') ← ext_simplify_core () {}
  simp_lemmas.mk (λ _, failed) (λ _ _ _ _ e, do
    (e'', pf) ← run_ring_exp transp e $ eval_simple e,
    guard (¬ e'' =ₐ e),
    return ((), e'', some pf, ff))
  (λ _ _ _ _ _, failed) `eq e,
  pure (e', pf')
end wiring
end tactic.ring_exp

namespace tactic.interactive
open interactive interactive.types lean.parser tactic tactic.ring_exp

local postfix (name := parser.optional) `?`:9001 := optional

/--
Tactic for solving equations of *commutative* (semi)rings,
allowing variables in the exponent.
This version of `ring_exp` fails if the target is not an equality.

The variant `ring_exp_eq!` will use a more aggressive reducibility setting
to determine equality of atoms.
-/
meta def ring_exp_eq (red : parse (tk "!")?) : tactic unit := do
  `(eq %%ps %%qs) ← target >>= whnf,

  let transp := if red.is_some then semireducible else reducible,

  ((ps', ps_pf), (qs', qs_pf)) ← run_ring_exp transp ps $
    prod.mk <$> eval_with_proof ps <*> eval_with_proof qs,

  if ps'.eq qs'
  then do
    qs_pf_inv ← mk_eq_symm qs_pf,
    pf ← mk_eq_trans ps_pf qs_pf_inv,
    tactic.interactive.exact ``(%%pf)
  else fail "ring_exp failed to prove equality"

/--
Tactic for evaluating expressions in *commutative* (semi)rings, allowing for variables in the
exponent.

This tactic extends `ring`: it should solve every goal that `ring` can solve.
Additionally, it knows how to evaluate expressions with complicated exponents
(where `ring` only understands constant exponents).
The variants `ring_exp!` and `ring_exp_eq!` use a more aggessive reducibility setting to determine
equality of atoms.

For example:
```lean
example (n : ℕ) (m : ℤ) : 2^(n+1) * m = 2 * 2^n * m := by ring_exp
example (a b : ℤ) (n : ℕ) : (a + b)^(n + 2) = (a^2 + b^2 + a * b + b * a) * (a + b)^n := by ring_exp
example (x y : ℕ) : x + id y = y + id x := by ring_exp!
```
-/
meta def ring_exp (red : parse (tk "!")?) (loc : parse location) : tactic unit :=
  match loc with
  | interactive.loc.ns [none] := ring_exp_eq red
  | _ := failed
  end <|>
  do ns ← loc.get_locals,
  let transp := if red.is_some then semireducible else reducible,
  tt ← tactic.replace_at (normalize transp) ns loc.include_goal
  | fail "ring_exp failed to simplify",
  when loc.include_goal $ try tactic.reflexivity

add_tactic_doc
{ name        := "ring_exp",
  category    := doc_category.tactic,
  decl_names  := [`tactic.interactive.ring_exp],
  tags        := ["arithmetic", "simplification", "decision procedure"] }

end tactic.interactive

namespace conv.interactive
open conv interactive
open tactic tactic.interactive (ring_exp_eq)
open tactic.ring_exp (normalize)

local postfix (name := parser.optional) `?`:9001 := optional

/--
Normalises expressions in commutative (semi-)rings inside of a `conv` block using the tactic
`ring_exp`.
-/
meta def ring_exp (red : parse (lean.parser.tk "!")?) : conv unit :=
let transp := if red.is_some then semireducible else reducible in
discharge_eq_lhs (ring_exp_eq red)
<|> replace_lhs (normalize transp)
<|> fail "ring_exp failed to simplify"

end conv.interactive