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

Solve equations in commutative (semi)rings with exponents.
-/
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',
  pure $ ex.coeff ⟨pq_p, pq_p, pq_pf⟩ ⟨p.1 * q.1⟩

/--
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.
-/
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 <$> pps.proof_term
  | (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 <$> ps.proof_term

/--
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
  ps' ← eval ps,
  qs' ← in_exponent $ eval qs,
  psqs ← pow ps' qs',
  psqs_pf ← psqs.proof_term,
  (do has_pow_pf ← match hp_instance with
  | `(monoid.has_pow) := lift $ mk_eq_refl e
  | _ := lift $ fail "has_pow instance must be nat.has_pow or monoid.has_pow"
  end,
  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 `?`: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 `?`: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


/-
Copyright (c) 2018 Chris Hughes. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Chris Hughes, Abhimanyu Pallavi Sudhir, Jean Lo, Calle Sönne, Benjamin Davidson
-/
import analysis.special_functions.complex.log
import analysis.special_functions.exp_deriv

/-!
# Differentiability of the complex `log` function

-/

noncomputable theory

namespace complex

open set filter

open_locale real topology

/-- `complex.exp` as a `local_homeomorph` with `source = {z | -π < im z < π}` and
`target = {z | 0 < re z} ∪ {z | im z ≠ 0}`. This definition is used to prove that `complex.log`
is complex differentiable at all points but the negative real semi-axis. -/
def exp_local_homeomorph : local_homeomorph ℂ ℂ :=
local_homeomorph.of_continuous_open
{ to_fun := exp,
  inv_fun := log,
  source := {z : ℂ | z.im ∈ Ioo (- π) π},
  target := {z : ℂ | 0 < z.re} ∪ {z : ℂ | z.im ≠ 0},
  map_source' :=
    begin
      rintro ⟨x, y⟩ ⟨h₁ : -π < y, h₂ : y < π⟩,
      refine (not_or_of_imp $ λ hz, _).symm,
      obtain rfl : y = 0,
      { rw exp_im at hz,
        simpa [(real.exp_pos _).ne', real.sin_eq_zero_iff_of_lt_of_lt h₁ h₂] using hz },
      rw [mem_set_of_eq, ← of_real_def, exp_of_real_re],
      exact real.exp_pos x
    end,
  map_target' := λ z h,
    suffices 0 ≤ z.re ∨ z.im ≠ 0,
      by simpa [log_im, neg_pi_lt_arg, (arg_le_pi _).lt_iff_ne, arg_eq_pi_iff, not_and_distrib],
    h.imp (λ h, le_of_lt h) id,
  left_inv' := λ x hx, log_exp hx.1 (le_of_lt hx.2),
  right_inv' := λ x hx, exp_log $ by { rintro rfl, simpa [lt_irrefl] using hx } }
continuous_exp.continuous_on is_open_map_exp (is_open_Ioo.preimage continuous_im)

lemma has_strict_deriv_at_log {x : ℂ} (h : 0 < x.re ∨ x.im ≠ 0) :
  has_strict_deriv_at log x⁻¹ x :=
have h0 :  x ≠ 0, by { rintro rfl, simpa [lt_irrefl] using h },
exp_local_homeomorph.has_strict_deriv_at_symm h h0 $
  by simpa [exp_log h0] using has_strict_deriv_at_exp (log x)

lemma has_strict_fderiv_at_log_real {x : ℂ} (h : 0 < x.re ∨ x.im ≠ 0) :
  has_strict_fderiv_at log (x⁻¹ • (1 : ℂ →L[ℝ] ℂ)) x :=
(has_strict_deriv_at_log h).complex_to_real_fderiv

lemma cont_diff_at_log {x : ℂ} (h : 0 < x.re ∨ x.im ≠ 0) {n : ℕ∞} :
  cont_diff_at ℂ n log x :=
exp_local_homeomorph.cont_diff_at_symm_deriv (exp_ne_zero $ log x) h
  (has_deriv_at_exp _) cont_diff_exp.cont_diff_at

end complex

section log_deriv

open complex filter
open_locale topology

variables {α : Type*} [topological_space α] {E : Type*} [normed_add_comm_group E] [normed_space ℂ E]

lemma has_strict_fderiv_at.clog {f : E → ℂ} {f' : E →L[ℂ] ℂ} {x : E}
  (h₁ : has_strict_fderiv_at f f' x) (h₂ : 0 < (f x).re ∨ (f x).im ≠ 0) :
  has_strict_fderiv_at (λ t, log (f t)) ((f x)⁻¹ • f') x :=
(has_strict_deriv_at_log h₂).comp_has_strict_fderiv_at x h₁

lemma has_strict_deriv_at.clog {f : ℂ → ℂ} {f' x : ℂ} (h₁ : has_strict_deriv_at f f' x)
  (h₂ : 0 < (f x).re ∨ (f x).im ≠ 0) :
  has_strict_deriv_at (λ t, log (f t)) (f' / f x) x :=
by { rw div_eq_inv_mul, exact (has_strict_deriv_at_log h₂).comp x h₁ }

lemma has_strict_deriv_at.clog_real {f : ℝ → ℂ} {x : ℝ} {f' : ℂ} (h₁ : has_strict_deriv_at f f' x)
  (h₂ : 0 < (f x).re ∨ (f x).im ≠ 0) :
  has_strict_deriv_at (λ t, log (f t)) (f' / f x) x :=
by simpa only [div_eq_inv_mul]
  using (has_strict_fderiv_at_log_real h₂).comp_has_strict_deriv_at x h₁

lemma has_fderiv_at.clog {f : E → ℂ} {f' : E →L[ℂ] ℂ} {x : E}
  (h₁ : has_fderiv_at f f' x) (h₂ : 0 < (f x).re ∨ (f x).im ≠ 0) :
  has_fderiv_at (λ t, log (f t)) ((f x)⁻¹ • f') x :=
(has_strict_deriv_at_log h₂).has_deriv_at.comp_has_fderiv_at x h₁

lemma has_deriv_at.clog {f : ℂ → ℂ} {f' x : ℂ} (h₁ : has_deriv_at f f' x)
  (h₂ : 0 < (f x).re ∨ (f x).im ≠ 0) :
  has_deriv_at (λ t, log (f t)) (f' / f x) x :=
by { rw div_eq_inv_mul, exact (has_strict_deriv_at_log h₂).has_deriv_at.comp x h₁ }

lemma has_deriv_at.clog_real {f : ℝ → ℂ} {x : ℝ} {f' : ℂ} (h₁ : has_deriv_at f f' x)
  (h₂ : 0 < (f x).re ∨ (f x).im ≠ 0) :
  has_deriv_at (λ t, log (f t)) (f' / f x) x :=
by simpa only [div_eq_inv_mul]
  using (has_strict_fderiv_at_log_real h₂).has_fderiv_at.comp_has_deriv_at x h₁

lemma differentiable_at.clog {f : E → ℂ} {x : E} (h₁ : differentiable_at ℂ f x)
  (h₂ : 0 < (f x).re ∨ (f x).im ≠ 0) :
  differentiable_at ℂ (λ t, log (f t)) x :=
(h₁.has_fderiv_at.clog h₂).differentiable_at

lemma has_fderiv_within_at.clog {f : E → ℂ} {f' : E →L[ℂ] ℂ} {s : set E} {x : E}
  (h₁ : has_fderiv_within_at f f' s x) (h₂ : 0 < (f x).re ∨ (f x).im ≠ 0) :
  has_fderiv_within_at (λ t, log (f t)) ((f x)⁻¹ • f') s x :=
(has_strict_deriv_at_log h₂).has_deriv_at.comp_has_fderiv_within_at x h₁

lemma has_deriv_within_at.clog {f : ℂ → ℂ} {f' x : ℂ} {s : set ℂ}
  (h₁ : has_deriv_within_at f f' s x) (h₂ : 0 < (f x).re ∨ (f x).im ≠ 0) :
  has_deriv_within_at (λ t, log (f t)) (f' / f x) s x :=
by { rw div_eq_inv_mul,
     exact (has_strict_deriv_at_log h₂).has_deriv_at.comp_has_deriv_within_at x h₁ }

lemma has_deriv_within_at.clog_real {f : ℝ → ℂ} {s : set ℝ} {x : ℝ} {f' : ℂ}
  (h₁ : has_deriv_within_at f f' s x) (h₂ : 0 < (f x).re ∨ (f x).im ≠ 0) :
  has_deriv_within_at (λ t, log (f t)) (f' / f x) s x :=
by simpa only [div_eq_inv_mul]
  using (has_strict_fderiv_at_log_real h₂).has_fderiv_at.comp_has_deriv_within_at x h₁

lemma differentiable_within_at.clog {f : E → ℂ} {s : set E} {x : E}
  (h₁ : differentiable_within_at ℂ f s x) (h₂ : 0 < (f x).re ∨ (f x).im ≠ 0) :
  differentiable_within_at ℂ (λ t, log (f t)) s x :=
(h₁.has_fderiv_within_at.clog h₂).differentiable_within_at

lemma differentiable_on.clog {f : E → ℂ} {s : set E}
  (h₁ : differentiable_on ℂ f s) (h₂ : ∀ x ∈ s, 0 < (f x).re ∨ (f x).im ≠ 0) :
  differentiable_on ℂ (λ t, log (f t)) s :=
λ x hx, (h₁ x hx).clog (h₂ x hx)

lemma differentiable.clog {f : E → ℂ} (h₁ : differentiable ℂ f)
  (h₂ : ∀ x, 0 < (f x).re ∨ (f x).im ≠ 0) :
  differentiable ℂ (λ t, log (f t)) :=
λ x, (h₁ x).clog (h₂ x)

end log_deriv


--import finiteness.finset2

import data.set.finite data.fintype.basic

import tactic

universes u v

open_locale classical

open set

def equiv.univ (X : Type u) :
X ≃ (univ : set X) :=
{ to_fun := λ x,  ⟨x, mem_univ x⟩,
  inv_fun := λ cx, cx.1,
  left_inv := by intro x; refl,
  right_inv := by intro cx; cases cx; refl }

def subsingleton.mk_equiv {α β} [subsingleton α] [subsingleton β]
  (f : α → β) (g : β → α) : α ≃ β :=
⟨f, g, λ _, by cc, λ _, by cc⟩

namespace fintype

@[ext] def ext {X : Type u} (a : fintype X) (b : fintype X) :
a = b := subsingleton.elim a b

def equiv_congr {X Y} (e : X ≃ Y) : fintype X ≃ fintype Y :=
subsingleton.mk_equiv (λ fX, @fintype.of_equiv Y X fX e) (λ fY, @fintype.of_equiv X Y fY e.symm)

end fintype

/-! # Relation to fintype -/

def is_finite (X : Type u) : Prop := nonempty (fintype X)

attribute [class] is_finite

namespace is_finite

noncomputable def to_fintype (X : Type u) [is_finite X] : fintype X := classical.choice ‹_›

variable (X : Type u)

-- two concepts of finiteness are EQUIVALENT
theorem nonempty_fintype_iff_finite_univ : is_finite X ↔ finite (univ : set X) :=
begin
  split,
  { unfold finite,
    intro h,
    exact nonempty.map (fintype.equiv_congr (equiv.univ X)) h
  },
  { intro h,
    cases h,
    cases h with S hS,
    let elems : finset X := finset.map (equiv.to_embedding (equiv.univ X).symm) S,
    use { elems := elems, complete := begin
      intro x,
      change x ∈ finset.map (equiv.univ X).symm.to_embedding S,
      rw finset.mem_map,
      use ⟨x, mem_univ x⟩,
      split,
        apply hS,
      refl,
    end},
  }
end

instance set {X : Type u} [is_finite X] (s : set X) : is_finite ↥s :=
begin
  unfold is_finite at *,
  apply nonempty.map _ _inst_1,
  intro useless,
  resetI, -- puts all typeclasses in the local context into the inference system
  exact set_fintype s,
end

instance equiv_congr (X : Type u) {Y : Type v} [is_finite X] [nonempty (X ≃ Y)] :
  is_finite Y :=
begin
  tactic.unfreeze_local_instances,
  cases _inst_1,
  cases _inst_2 with e,
  use fintype.of_equiv X e,
end

instance infinite_prod {X : Type u} {Y : Type v} [infinite X] [nonempty Y] :
  infinite (X × Y) :=
begin
  tactic.unfreeze_local_instances,
  cases _inst_2 with y,
  apply infinite.of_injective (λ x, (x, y) : X → X × Y),
  rintros _ _ ⟨_, _⟩, refl,
end

--lemma not_finite_iff_infinite
lemma iff_not_infinite {X : Type u} : ¬ is_finite X ↔ infinite X :=
not_nonempty_fintype

lemma finite_or_infinite (X : Type u) : is_finite X ∨ infinite X :=
begin
  by_cases h : is_finite X,
    left, assumption,
  right, rwa ←iff_not_infinite,
end

/-! # card -/
-- not sure if this is more or less useful than fincard, but it seems
-- to be handy to have around
/-- ℕ-valued cardinality of an `is_finite` type -/
noncomputable def card (X : Type u) [is_finite X] : ℕ :=
@fintype.card X (to_fintype X)

lemma card_congr' {X : Type u} {Y : Type v} [is_finite X] [nonempty (X ≃ Y)] :
card X = card Y :=
begin
  letI : fintype X := to_fintype X,
  letI : fintype Y := to_fintype Y,
  tactic.unfreeze_local_instances,
  cases _inst_2 with e,
  convert fintype.card_congr e,
end

lemma card_congr {X : Type u} {Y : Type v} [is_finite X] (e : X ≃ Y) :
by haveI : nonempty (X ≃ Y) := ⟨e⟩; exact
card X = card Y :=
begin
  letI : fintype X := to_fintype X,
  haveI : nonempty (X ≃ Y) := ⟨e⟩,
  letI : fintype Y := to_fintype Y,
  convert fintype.card_congr e,
end

lemma card_eq {X : Type u} {Y : Type v} [is_finite X] [is_finite Y] :
  card X = card Y ↔ nonempty (X ≃ Y) :=
begin
  split,
  { intro h,
    letI : fintype X := to_fintype X,
    letI : fintype Y := to_fintype Y,
    rwa ←fintype.card_eq,
  },
  { rintro ⟨e⟩,
    exact card_congr e,
  }
end

instance {X : Type u} {Y : Type v} [is_finite X] [is_finite Y] :
  is_finite (X × Y) :=
begin
  letI : fintype X := to_fintype X,
  letI : fintype Y := to_fintype Y,
  split,
  apply_instance
end

local attribute [instance] to_fintype

lemma card_prod (X : Type u) (Y : Type v) [is_finite X] [is_finite Y] :
card (X × Y) = card X * card Y :=
by { unfold card, convert fintype.card_prod X Y }

end is_finite


/-
Copyright (c) 2021 Shing Tak Lam. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Shing Tak Lam
-/

import topology.unit_interval
import topology.algebra.ordered.proj_Icc
import topology.continuous_function.ordered
import topology.compact_open

/-!
# Homotopy between functions

In this file, we define a homotopy between two functions `f₀` and `f₁`. First we define
`continuous_map.homotopy` between the two functions, with no restrictions on the intermediate
maps. Then, as in the formalisation in HOL-Analysis, we define
`continuous_map.homotopy_with f₀ f₁ P`, for homotopies between `f₀` and `f₁`, where the
intermediate maps satisfy the predicate `P`. Finally, we define
`continuous_map.homotopy_rel f₀ f₁ S`, for homotopies between `f₀` and `f₁` which are fixed
on `S`.

## Definitions

* `continuous_map.homotopy f₀ f₁` is the type of homotopies between `f₀` and `f₁`.
* `continuous_map.homotopy_with f₀ f₁ P` is the type of homotopies between `f₀` and `f₁`, where
  the intermediate maps satisfy the predicate `P`.
* `continuous_map.homotopy_rel f₀ f₁ S` is the type of homotopies between `f₀` and `f₁` which
  are fixed on `S`.

For each of the above, we have

* `refl f`, which is the constant homotopy from `f` to `f`.
* `symm F`, which reverses the homotopy `F`. For example, if `F : continuous_map.homotopy f₀ f₁`,
  then `F.symm : continuous_map.homotopy f₁ f₀`.
* `trans F G`, which concatenates the homotopies `F` and `G`. For example, if
  `F : continuous_map.homotopy f₀ f₁` and `G : continuous_map.homotopy f₁ f₂`, then
  `F.trans G : continuous_map.homotopy f₀ f₂`.

We also define the relations

* `continuous_map.homotopic f₀ f₁` is defined to be `nonempty (continuous_map.homotopy f₀ f₁)`
* `continuous_map.homotopic_with f₀ f₁ P` is defined to be
  `nonempty (continuous_map.homotopy_with f₀ f₁ P)`
* `continuous_map.homotopic_rel f₀ f₁ P` is defined to be
  `nonempty (continuous_map.homotopy_rel f₀ f₁ P)`

and for `continuous_map.homotopic` and `continuous_map.homotopic_rel`, we also define the
`setoid` and `quotient` in `C(X, Y)` by these relations.

## References

- [HOL-Analysis formalisation](https://isabelle.in.tum.de/library/HOL/HOL-Analysis/Homotopy.html)
-/

noncomputable theory

universes u v w

variables {X : Type u} {Y : Type v} {Z : Type w}
variables [topological_space X] [topological_space Y] [topological_space Z]

open_locale unit_interval

namespace continuous_map

/--
The type of homotopies between two functions.
-/
structure homotopy (f₀ f₁ : C(X, Y)) extends C(I × X, Y) :=
(to_fun_zero : ∀ x, to_fun (0, x) = f₀ x)
(to_fun_one : ∀ x, to_fun (1, x) = f₁ x)

namespace homotopy

section

variables {f₀ f₁ : C(X, Y)}

instance : has_coe_to_fun (homotopy f₀ f₁) (λ _, I × X → Y) := ⟨λ F, F.to_fun⟩

lemma coe_fn_injective : @function.injective (homotopy f₀ f₁) (I × X → Y) coe_fn :=
begin
  rintros ⟨⟨F, _⟩, _⟩ ⟨⟨G, _⟩, _⟩ h,
  congr' 2,
end

@[ext]
lemma ext {F G : homotopy f₀ f₁} (h : ∀ x, F x = G x) : F = G :=
coe_fn_injective $ funext h

/-- See Note [custom simps projection]. We need to specify this projection explicitly in this case,
because it is a composition of multiple projections. -/
def simps.apply (F : homotopy f₀ f₁) : I × X → Y := F

initialize_simps_projections homotopy (to_continuous_map_to_fun -> apply, -to_continuous_map)

@[continuity]
protected lemma continuous (F : homotopy f₀ f₁) : continuous F := F.continuous_to_fun

@[simp]
lemma apply_zero (F : homotopy f₀ f₁) (x : X) : F (0, x) = f₀ x := F.to_fun_zero x

@[simp]
lemma apply_one (F : homotopy f₀ f₁) (x : X) : F (1, x) = f₁ x := F.to_fun_one x

@[simp]
lemma coe_to_continuous_map (F : homotopy f₀ f₁) : ⇑F.to_continuous_map = F := rfl

/--
Currying a homotopy to a continuous function fron `I` to `C(X, Y)`.
-/
def curry (F : homotopy f₀ f₁) : C(I, C(X, Y)) := F.to_continuous_map.curry

@[simp]
lemma curry_apply (F : homotopy f₀ f₁) (t : I) (x : X) : F.curry t x = F (t, x) := rfl

/--
Continuously extending a curried homotopy to a function from `ℝ` to `C(X, Y)`.
-/
def extend (F : homotopy f₀ f₁) : C(ℝ, C(X, Y)) := F.curry.Icc_extend zero_le_one

lemma extend_apply_of_le_zero (F : homotopy f₀ f₁) {t : ℝ} (ht : t ≤ 0) (x : X) :
  F.extend t x = f₀ x :=
begin
  rw [←F.apply_zero],
  exact continuous_map.congr_fun (set.Icc_extend_of_le_left (@zero_le_one ℝ _) F.curry ht) x,
end

lemma extend_apply_of_one_le (F : homotopy f₀ f₁) {t : ℝ} (ht : 1 ≤ t) (x : X) :
  F.extend t x = f₁ x :=
begin
  rw [←F.apply_one],
  exact continuous_map.congr_fun (set.Icc_extend_of_right_le (@zero_le_one ℝ _) F.curry ht) x,
end

@[simp]
lemma extend_apply_coe (F : homotopy f₀ f₁) (t : I) (x : X) : F.extend t x = F (t, x) :=
continuous_map.congr_fun (set.Icc_extend_coe (@zero_le_one ℝ _) F.curry t) x

@[simp]
lemma extend_apply_of_mem_I (F : homotopy f₀ f₁) {t : ℝ} (ht : t ∈ I) (x : X) :
  F.extend t x = F (⟨t, ht⟩, x) :=
continuous_map.congr_fun (set.Icc_extend_of_mem (@zero_le_one ℝ _) F.curry ht) x

lemma congr_fun {F G : homotopy f₀ f₁} (h : F = G) (x : I × X) : F x = G x :=
continuous_map.congr_fun (congr_arg _ h) x

lemma congr_arg (F : homotopy f₀ f₁) {x y : I × X} (h : x = y) : F x = F y :=
F.to_continuous_map.congr_arg h

end

/--
Given a continuous function `f`, we can define a `homotopy f f` by `F (t, x) = f x`
-/
@[simps]
def refl (f : C(X, Y)) : homotopy f f :=
{ to_fun := λ x, f x.2,
  to_fun_zero := λ _, rfl,
  to_fun_one := λ _, rfl }

instance : inhabited (homotopy (continuous_map.id : C(X, X)) continuous_map.id) :=
⟨homotopy.refl continuous_map.id⟩

/--
Given a `homotopy f₀ f₁`, we can define a `homotopy f₁ f₀` by reversing the homotopy.
-/
@[simps]
def symm {f₀ f₁ : C(X, Y)} (F : homotopy f₀ f₁) : homotopy f₁ f₀ :=
{ to_fun := λ x, F (σ x.1, x.2),
  to_fun_zero := by norm_num,
  to_fun_one := by norm_num }

@[simp]
lemma symm_symm {f₀ f₁ : C(X, Y)} (F : homotopy f₀ f₁) : F.symm.symm = F :=
by { ext, simp }

/--
Given `homotopy f₀ f₁` and `homotopy f₁ f₂`, we can define a `homotopy f₀ f₂` by putting the first
homotopy on `[0, 1/2]` and the second on `[1/2, 1]`.
-/
def trans {f₀ f₁ f₂ : C(X, Y)} (F : homotopy f₀ f₁) (G : homotopy f₁ f₂) :
  homotopy f₀ f₂ :=
{ to_fun := λ x, if (x.1 : ℝ) ≤ 1/2 then F.extend (2 * x.1) x.2 else G.extend (2 * x.1 - 1) x.2,
  continuous_to_fun := begin
    refine continuous_if_le (continuous_induced_dom.comp continuous_fst) continuous_const
      (F.continuous.comp (by continuity)).continuous_on
      (G.continuous.comp (by continuity)).continuous_on _,
    rintros x hx,
    norm_num [hx],
  end,
  to_fun_zero := λ x, by norm_num,
  to_fun_one := λ x, by norm_num }

lemma trans_apply {f₀ f₁ f₂ : C(X, Y)} (F : homotopy f₀ f₁) (G : homotopy f₁ f₂)
  (x : I × X) : (F.trans G) x =
  if h : (x.1 : ℝ) ≤ 1/2 then
    F (⟨2 * x.1, (unit_interval.mul_pos_mem_iff zero_lt_two).2 ⟨x.1.2.1, h⟩⟩, x.2)
  else
    G (⟨2 * x.1 - 1, unit_interval.two_mul_sub_one_mem_iff.2 ⟨(not_le.1 h).le, x.1.2.2⟩⟩, x.2) :=
show ite _ _ _ = _,
by split_ifs; { rw [extend, continuous_map.coe_Icc_extend, set.Icc_extend_of_mem], refl }

lemma symm_trans {f₀ f₁ f₂ : C(X, Y)} (F : homotopy f₀ f₁) (G : homotopy f₁ f₂) :
  (F.trans G).symm = G.symm.trans F.symm :=
begin
  ext x,
  simp only [symm_apply, trans_apply],
  split_ifs with h₁ h₂,
  { change (x.1 : ℝ) ≤ _ at h₂,
    change (1 : ℝ) - x.1 ≤ _ at h₁,
    have ht : (x.1 : ℝ) = 1/2,
    { linarith },
    norm_num [ht] },
  { congr' 2,
    apply subtype.ext,
    simp only [unit_interval.coe_symm_eq, subtype.coe_mk],
    linarith },
  { congr' 2,
    apply subtype.ext,
    simp only [unit_interval.coe_symm_eq, subtype.coe_mk],
    linarith },
  { change ¬ (x.1 : ℝ) ≤ _ at h,
    change ¬ (1 : ℝ) - x.1 ≤ _ at h₁,
    exfalso, linarith }
end

/--
Casting a `homotopy f₀ f₁` to a `homotopy g₀ g₁` where `f₀ = g₀` and `f₁ = g₁`.
-/
@[simps]
def cast {f₀ f₁ g₀ g₁ : C(X, Y)} (F : homotopy f₀ f₁) (h₀ : f₀ = g₀) (h₁ : f₁ = g₁) :
  homotopy g₀ g₁ :=
{ to_fun := F,
  to_fun_zero := by simp [←h₀],
  to_fun_one := by simp [←h₁] }

/--
If we have a `homotopy f₀ f₁` and a `homotopy g₀ g₁`, then we can compose them and get a
`homotopy (g₀.comp f₀) (g₁.comp f₁)`.
-/
@[simps]
def hcomp {f₀ f₁ : C(X, Y)} {g₀ g₁ : C(Y, Z)} (F : homotopy f₀ f₁) (G : homotopy g₀ g₁) :
  homotopy (g₀.comp f₀) (g₁.comp f₁) :=
{ to_fun := λ x, G (x.1, F x),
  to_fun_zero := by simp,
  to_fun_one := by simp }

end homotopy

/--
Given continuous maps `f₀` and `f₁`, we say `f₀` and `f₁` are homotopic if there exists a
`homotopy f₀ f₁`.
-/
def homotopic (f₀ f₁ : C(X, Y)) : Prop :=
nonempty (homotopy f₀ f₁)

namespace homotopic

@[refl]
lemma refl (f : C(X, Y)) : homotopic f f := ⟨homotopy.refl f⟩

@[symm]
lemma symm ⦃f g : C(X, Y)⦄ (h : homotopic f g) : homotopic g f := h.map homotopy.symm

@[trans]

lemma hcomp {f₀ f₁ : C(X, Y)} {g₀ g₁ : C(Y, Z)} (h₀ : homotopic f₀ f₁) (h₁ : homotopic g₀ g₁) :
  homotopic (g₀.comp f₀) (g₁.comp f₁) :=
h₀.map2 homotopy.hcomp h₁

lemma equivalence : equivalence (@homotopic X Y _ _) := ⟨refl, symm, trans⟩

end homotopic

/--
The type of homotopies between `f₀ f₁ : C(X, Y)`, where the intermediate maps satisfy the predicate
`P : C(X, Y) → Prop`
-/
structure homotopy_with (f₀ f₁ : C(X, Y)) (P : C(X, Y) → Prop) extends homotopy f₀ f₁ :=
(prop' : ∀ t, P ⟨λ x, to_fun (t, x),
  continuous.comp continuous_to_fun (continuous_const.prod_mk continuous_id')⟩)

namespace homotopy_with

section

variables {f₀ f₁ : C(X, Y)} {P : C(X, Y) → Prop}

instance : has_coe_to_fun (homotopy_with f₀ f₁ P) (λ _, I × X → Y) := ⟨λ F, F.to_fun⟩

lemma coe_fn_injective : @function.injective (homotopy_with f₀ f₁ P) (I × X → Y) coe_fn :=
begin
  rintros ⟨⟨⟨F, _⟩, _⟩, _⟩ ⟨⟨⟨G, _⟩, _⟩, _⟩ h,
  congr' 3,
end

@[ext]
lemma ext {F G : homotopy_with f₀ f₁ P} (h : ∀ x, F x = G x) : F = G :=
coe_fn_injective $ funext h

/-- See Note [custom simps projection]. We need to specify this projection explicitly in this case,
because it is a composition of multiple projections. -/
def simps.apply (F : homotopy_with f₀ f₁ P) : I × X → Y := F

initialize_simps_projections homotopy_with
  (to_homotopy_to_continuous_map_to_fun -> apply, -to_homotopy_to_continuous_map)

@[continuity]
protected lemma continuous (F : homotopy_with f₀ f₁ P) : continuous F := F.continuous_to_fun

@[simp]
lemma apply_zero (F : homotopy_with f₀ f₁ P) (x : X) : F (0, x) = f₀ x := F.to_fun_zero x

@[simp]
lemma apply_one (F : homotopy_with f₀ f₁ P) (x : X) : F (1, x) = f₁ x := F.to_fun_one x

@[simp]
lemma coe_to_continuous_map (F : homotopy_with f₀ f₁ P) : ⇑F.to_continuous_map = F := rfl

@[simp]
lemma coe_to_homotopy (F : homotopy_with f₀ f₁ P) : ⇑F.to_homotopy = F := rfl

lemma prop (F : homotopy_with f₀ f₁ P) (t : I) : P (F.to_homotopy.curry t) := F.prop' t

lemma extend_prop (F : homotopy_with f₀ f₁ P) (t : ℝ) : P (F.to_homotopy.extend t) :=
begin
  by_cases ht₀ : 0 ≤ t,
  { by_cases ht₁ : t ≤ 1,
    { convert F.prop ⟨t, ht₀, ht₁⟩,
      ext,
      rw [F.to_homotopy.extend_apply_of_mem_I ⟨ht₀, ht₁⟩, F.to_homotopy.curry_apply] },
    { convert F.prop 1,
      ext,
      rw [F.to_homotopy.extend_apply_of_one_le (le_of_not_le ht₁), F.to_homotopy.curry_apply,
          F.to_homotopy.apply_one] } },
  { convert F.prop 0,
    ext,
    rw [F.to_homotopy.extend_apply_of_le_zero (le_of_not_le ht₀), F.to_homotopy.curry_apply,
        F.to_homotopy.apply_zero] }
end

end

variable {P : C(X, Y) → Prop}

/--
Given a continuous function `f`, and a proof `h : P f`, we can define a `homotopy_with f f P` by
`F (t, x) = f x`
-/
@[simps]
def refl (f : C(X, Y)) (hf : P f) : homotopy_with f f P :=
{ prop' := λ t, by { convert hf, cases f, refl },
  ..homotopy.refl f }

instance : inhabited (homotopy_with (continuous_map.id : C(X, X)) continuous_map.id (λ f, true)) :=
⟨homotopy_with.refl _ trivial⟩

/--
Given a `homotopy_with f₀ f₁ P`, we can define a `homotopy_with f₁ f₀ P` by reversing the homotopy.
-/
@[simps]
def symm {f₀ f₁ : C(X, Y)} (F : homotopy_with f₀ f₁ P) : homotopy_with f₁ f₀ P :=
{ prop' := λ t, by simpa using F.prop (σ t),
  ..F.to_homotopy.symm }

@[simp]
lemma symm_symm {f₀ f₁ : C(X, Y)} (F : homotopy_with f₀ f₁ P) : F.symm.symm = F :=
ext $ homotopy.congr_fun $ homotopy.symm_symm _

/--
Given `homotopy_with f₀ f₁ P` and `homotopy_with f₁ f₂ P`, we can define a `homotopy_with f₀ f₂ P`
by putting the first homotopy on `[0, 1/2]` and the second on `[1/2, 1]`.
-/
def trans {f₀ f₁ f₂ : C(X, Y)} (F : homotopy_with f₀ f₁ P) (G : homotopy_with f₁ f₂ P) :
  homotopy_with f₀ f₂ P :=
{ prop' := λ t, begin
    simp only [homotopy.trans],
    change P ⟨λ _, ite ((t : ℝ) ≤ _) _ _, _⟩,
    split_ifs,
    { exact F.extend_prop _ },
    { exact G.extend_prop _ }
  end,
  ..F.to_homotopy.trans G.to_homotopy }

lemma trans_apply {f₀ f₁ f₂ : C(X, Y)} (F : homotopy_with f₀ f₁ P) (G : homotopy_with f₁ f₂ P)
  (x : I × X) : (F.trans G) x =
  if h : (x.1 : ℝ) ≤ 1/2 then
    F (⟨2 * x.1, (unit_interval.mul_pos_mem_iff zero_lt_two).2 ⟨x.1.2.1, h⟩⟩, x.2)
  else
    G (⟨2 * x.1 - 1, unit_interval.two_mul_sub_one_mem_iff.2 ⟨(not_le.1 h).le, x.1.2.2⟩⟩, x.2) :=
homotopy.trans_apply _ _ _

lemma symm_trans {f₀ f₁ f₂ : C(X, Y)} (F : homotopy_with f₀ f₁ P) (G : homotopy_with f₁ f₂ P) :
  (F.trans G).symm = G.symm.trans F.symm :=
ext $ homotopy.congr_fun $ homotopy.symm_trans _ _

/--
Casting a `homotopy_with f₀ f₁ P` to a `homotopy_with g₀ g₁ P` where `f₀ = g₀` and `f₁ = g₁`.
-/
@[simps]
def cast {f₀ f₁ g₀ g₁ : C(X, Y)} (F : homotopy_with f₀ f₁ P) (h₀ : f₀ = g₀) (h₁ : f₁ = g₁) :
  homotopy_with g₀ g₁ P :=
{ prop' := F.prop,
  ..F.to_homotopy.cast h₀ h₁ }

end homotopy_with

/--
Given continuous maps `f₀` and `f₁`, we say `f₀` and `f₁` are homotopic with respect to the
predicate `P` if there exists a `homotopy_with f₀ f₁ P`.
-/
def homotopic_with (f₀ f₁ : C(X, Y)) (P : C(X, Y) → Prop) : Prop :=
nonempty (homotopy_with f₀ f₁ P)

namespace homotopic_with

variable {P : C(X, Y) → Prop}

@[refl]
lemma refl (f : C(X, Y)) (hf : P f) : homotopic_with f f P :=
⟨homotopy_with.refl f hf⟩

@[symm]
lemma symm ⦃f g : C(X, Y)⦄ (h : homotopic_with f g P) : homotopic_with g f P := ⟨h.some.symm⟩

@[trans]
lemma trans ⦃f g h : C(X, Y)⦄ (h₀ : homotopic_with f g P) (h₁ : homotopic_with g h P) :
  homotopic_with f h P :=
⟨h₀.some.trans h₁.some⟩

end homotopic_with

/--
A `homotopy_rel f₀ f₁ S` is a homotopy between `f₀` and `f₁` which is fixed on the points in `S`.
-/
abbreviation homotopy_rel (f₀ f₁ : C(X, Y)) (S : set X) :=
homotopy_with f₀ f₁ (λ f, ∀ x ∈ S, f x = f₀ x ∧ f x = f₁ x)

namespace homotopy_rel

section

variables {f₀ f₁ : C(X, Y)} {S : set X}

lemma eq_fst (F : homotopy_rel f₀ f₁ S) (t : I) {x : X} (hx : x ∈ S) :
  F (t, x) = f₀ x := (F.prop t x hx).1

lemma eq_snd (F : homotopy_rel f₀ f₁ S) (t : I) {x : X} (hx : x ∈ S) :
  F (t, x) = f₁ x := (F.prop t x hx).2

lemma fst_eq_snd (F : homotopy_rel f₀ f₁ S) {x : X} (hx : x ∈ S) :
  f₀ x = f₁ x := F.eq_fst 0 hx ▸ F.eq_snd 0 hx

end

variables {f₀ f₁ f₂ : C(X, Y)} {S : set X}

/--
Given a map `f : C(X, Y)` and a set `S`, we can define a `homotopy_rel f f S` by setting
`F (t, x) = f x` for all `t`. This is defined using `homotopy_with.refl`, but with the proof
filled in.
-/
@[simps]
def refl (f : C(X, Y)) (S : set X) : homotopy_rel f f S :=
homotopy_with.refl f (λ x hx, ⟨rfl, rfl⟩)

/--
Given a `homotopy_rel f₀ f₁ S`, we can define a `homotopy_rel f₁ f₀ S` by reversing the homotopy.
-/
@[simps]
def symm (F : homotopy_rel f₀ f₁ S) : homotopy_rel f₁ f₀ S :=
{ prop' := λ t x hx, by simp [F.eq_snd _ hx, F.fst_eq_snd hx],
  ..homotopy_with.symm F }

@[simp]
lemma symm_symm (F : homotopy_rel f₀ f₁ S) : F.symm.symm = F :=
homotopy_with.symm_symm F

/--
Given `homotopy_rel f₀ f₁ S` and `homotopy_rel f₁ f₂ S`, we can define a `homotopy_rel f₀ f₂ S`
by putting the first homotopy on `[0, 1/2]` and the second on `[1/2, 1]`.
-/
def trans (F : homotopy_rel f₀ f₁ S) (G : homotopy_rel f₁ f₂ S) : homotopy_rel f₀ f₂ S :=
{ prop' := λ t, begin
    intros x hx,
    simp only [homotopy.trans],
    change (⟨λ _, ite ((t : ℝ) ≤ _) _ _, _⟩ : C(X, Y)) _ = _ ∧ _ = _,
    split_ifs,
    { simp [(homotopy_with.extend_prop F (2 * t) x hx).1, F.fst_eq_snd hx, G.fst_eq_snd hx] },
    { simp [(homotopy_with.extend_prop G (2 * t - 1) x hx).1, F.fst_eq_snd hx, G.fst_eq_snd hx] },
  end,
  ..homotopy.trans F.to_homotopy G.to_homotopy }

lemma trans_apply (F : homotopy_rel f₀ f₁ S) (G : homotopy_rel f₁ f₂ S)
  (x : I × X) : (F.trans G) x =
  if h : (x.1 : ℝ) ≤ 1/2 then
    F (⟨2 * x.1, (unit_interval.mul_pos_mem_iff zero_lt_two).2 ⟨x.1.2.1, h⟩⟩, x.2)
  else
    G (⟨2 * x.1 - 1, unit_interval.two_mul_sub_one_mem_iff.2 ⟨(not_le.1 h).le, x.1.2.2⟩⟩, x.2) :=
homotopy.trans_apply _ _ _

lemma symm_trans (F : homotopy_rel f₀ f₁ S) (G : homotopy_rel f₁ f₂ S) :
  (F.trans G).symm = G.symm.trans F.symm :=
homotopy_with.ext $ homotopy.congr_fun $ homotopy.symm_trans _ _

/--
Casting a `homotopy_rel f₀ f₁ S` to a `homotopy_rel g₀ g₁ S` where `f₀ = g₀` and `f₁ = g₁`.
-/
@[simps]
def cast {f₀ f₁ g₀ g₁ : C(X, Y)} (F : homotopy_rel f₀ f₁ S) (h₀ : f₀ = g₀) (h₁ : f₁ = g₁) :
  homotopy_rel g₀ g₁ S :=
{ prop' := λ t x hx, by { simpa [←h₀, ←h₁] using F.prop t x hx },
  ..homotopy.cast F.to_homotopy h₀ h₁ }

end homotopy_rel

/--
Given continuous maps `f₀` and `f₁`, we say `f₀` and `f₁` are homotopic relative to a set `S` if
there exists a `homotopy_rel f₀ f₁ S`.
-/
def homotopic_rel (f₀ f₁ : C(X, Y)) (S : set X) : Prop :=
nonempty (homotopy_rel f₀ f₁ S)

namespace homotopic_rel

variable {S : set X}

@[refl]
lemma refl (f : C(X, Y)) : homotopic_rel f f S := ⟨homotopy_rel.refl f S⟩

@[symm]
lemma symm ⦃f g : C(X, Y)⦄ (h : homotopic_rel f g S) : homotopic_rel g f S :=
  h.map homotopy_rel.symm

@[trans]
lemma trans ⦃f g h : C(X, Y)⦄ (h₀ : homotopic_rel f g S) (h₁ : homotopic_rel g h S) :
  homotopic_rel f h S :=
h₀.map2 homotopy_rel.trans h₁

lemma equivalence : equivalence (λ f g : C(X, Y), homotopic_rel f g S) :=
⟨refl, symm, trans⟩

end homotopic_rel

end continuous_map


/-
Copyright (c) 2018 Johannes Hölzl. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Johannes Hölzl, Jens Wagemaker

Associated and irreducible elements.
-/
import order.galois_connection algebra.group data.equiv.basic data.multiset data.int.gcd

variables {α : Type*} {β : Type*} {γ : Type*} {δ : Type*}
open lattice

def is_unit [monoid α] (a : α) : Prop := ∃u:units α, a = u

@[simp] theorem not_is_unit_zero [nonzero_comm_ring α] : ¬ is_unit (0 : α)
| ⟨⟨a, b, hab, hba⟩, rfl⟩ := have 0 * b = 1, from hab, by simpa using this

@[simp] theorem is_unit_one [monoid α] : is_unit (1:α) := ⟨1, rfl⟩

theorem units.is_unit_of_mul_one [comm_monoid α] (a b : α) (h : a * b = 1) : is_unit a :=
⟨units.mk_of_mul_eq_one a b h, rfl⟩

@[simp] theorem is_unit_mul_units [monoid α] (a : α) (u : units α) : is_unit (a * u) ↔ is_unit a :=
iff.intro
  (assume ⟨v, hv⟩,
    have is_unit (a * ↑u * ↑u⁻¹), by existsi v * u⁻¹; rw [hv, units.mul_coe],
    by rwa [mul_assoc, units.mul_inv, mul_one] at this)
  (assume ⟨v, hv⟩, hv.symm ▸ ⟨v * u, (units.mul_coe v u).symm⟩)

theorem is_unit_iff_dvd_one {α} [comm_semiring α] {x : α} : is_unit x ↔ x ∣ 1 :=
⟨by rintro ⟨u, rfl⟩; exact ⟨_, u.mul_inv.symm⟩,
 λ ⟨y, h⟩, ⟨⟨x, y, h.symm, by rw [h, mul_comm]⟩, rfl⟩⟩

theorem is_unit_iff_forall_dvd {α} [comm_semiring α] {x : α} :
  is_unit x ↔ ∀ y, x ∣ y :=
is_unit_iff_dvd_one.trans ⟨λ h y, dvd.trans h (one_dvd _), λ h, h _⟩

theorem is_unit_of_dvd_unit {α} [comm_semiring α] {x y : α}
  (xy : x ∣ y) (hu : is_unit y) : is_unit x :=
is_unit_iff_dvd_one.2 $ dvd_trans xy $ is_unit_iff_dvd_one.1 hu

@[simp] theorem is_unit_nat {n : ℕ} : is_unit n ↔ n = 1 :=
iff.intro
  (assume ⟨u, hu⟩, match n, u, hu, nat.units_eq_one u with _, _, rfl, rfl := rfl end)
  (assume h, h.symm ▸ ⟨1, rfl⟩)

/-- `irreducible p` states that `p` is non-unit and only factors into units.

We explicitly avoid stating that `p` is non-zero, this would require a semiring. Assuming only a
monoid allows us to reuse irreducible for associated elements.
-/
@[class] def irreducible [monoid α] (p : α) : Prop :=
¬ is_unit p ∧ ∀a b, p = a * b → is_unit a ∨ is_unit b

@[simp] theorem not_irreducible_one [monoid α] : ¬ irreducible (1 : α) :=
by simp [irreducible]

@[simp] theorem not_irreducible_zero [semiring α] : ¬ irreducible (0 : α)
| ⟨hn0, h⟩ := have is_unit (0:α) ∨ is_unit (0:α), from h 0 0 ((mul_zero 0).symm),
  this.elim hn0 hn0

theorem of_irreducible_mul {α} [monoid α] {x y : α} :
  irreducible (x * y) → is_unit x ∨ is_unit y
| ⟨_, h⟩ := h _ _ rfl

theorem irreducible_or_factor {α} [monoid α] (x : α) (h : ¬ is_unit x) :
  irreducible x ∨ ∃ a b, ¬ is_unit a ∧ ¬ is_unit b ∧ a * b = x :=
begin
  haveI := classical.dec,
  refine or_iff_not_imp_right.2 (λ H, _),
  simp [h, irreducible] at H ⊢,
  refine λ a b h, classical.by_contradiction $ λ o, _,
  simp [not_or_distrib] at o,
  exact H _ o.1 _ o.2 h.symm
end

theorem irreducible_iff_nat_prime : ∀(a : ℕ), irreducible a ↔ nat.prime a
| 0 := by simp [nat.not_prime_zero]
| 1 := by simp [nat.prime, one_lt_two]
| (n + 2) :=
  have h₁ : ¬n + 2 = 1, from dec_trivial,
  begin
    simp [h₁, nat.prime, irreducible, (≥), nat.le_add_left 2 n, (∣)],
    refine forall_congr (assume a, forall_congr $ assume b, forall_congr $ assume hab, _),
    by_cases a = 1; simp [h],
    split,
    { assume hb, simpa [hb] using hab.symm },
    { assume ha, subst ha,
      have : n + 2 > 0, from dec_trivial,
      refine nat.eq_of_mul_eq_mul_left this _,
      rw [← hab, mul_one] }
  end

def associated [monoid α] (x y : α) : Prop := ∃u:units α, x * u = y

local infix ` ~ᵤ ` : 50 := associated

namespace associated

@[refl] protected theorem refl [monoid α] (x : α) : x ~ᵤ x := ⟨1, by simp⟩

@[symm] protected theorem symm [monoid α] : ∀{x y : α}, x ~ᵤ y → y ~ᵤ x
| x _ ⟨u, rfl⟩ := ⟨u⁻¹, by rw [mul_assoc, units.mul_inv, mul_one]⟩

@[trans] protected theorem trans [monoid α] : ∀{x y z : α}, x ~ᵤ y → y ~ᵤ z → x ~ᵤ z
| x _ _ ⟨u, rfl⟩ ⟨v, rfl⟩ := ⟨u * v, by rw [units.mul_coe, mul_assoc]⟩

theorem unit_associated_one [monoid α] {u : units α} : (u : α) ~ᵤ 1 := ⟨u⁻¹, units.mul_inv u⟩

theorem associated_one_iff_is_unit [monoid α] {a : α} : (a : α) ~ᵤ 1 ↔ is_unit a :=
iff.intro
  (assume h, let ⟨c, h⟩ := h.symm in h ▸ ⟨c, one_mul _⟩)
  (assume ⟨c, h⟩, associated.symm ⟨c, by simp [h]⟩)

theorem associated_zero_iff_eq_zero [comm_semiring α] (a : α) : a ~ᵤ 0 ↔ a = 0 :=
iff.intro
  (assume h, let ⟨u, h⟩ := h.symm in by simpa using h.symm)
  (assume h, h ▸ associated.refl a)

theorem associated_one_of_mul_eq_one [comm_monoid α] {a : α} (b : α) (hab : a * b = 1) : a ~ᵤ 1 :=
show (units.mk_of_mul_eq_one a b hab : α) ~ᵤ 1, from unit_associated_one

theorem associated_one_of_associated_mul_one [comm_monoid α] {a b : α} :
  a * b ~ᵤ 1 → a ~ᵤ 1
| ⟨u, h⟩ := associated_one_of_mul_eq_one (b * u) $ by simpa [mul_assoc] using h

theorem associated_of_dvd_dvd [integral_domain α] {a b : α} (hab : a ∣ b) (hba : b ∣ a) : a ~ᵤ b :=
begin
  haveI := classical.dec_eq α,
  rcases hab with ⟨c, rfl⟩,
  rcases hba with ⟨d, a_eq⟩,
  by_cases ha0 : a = 0,
  { simp [*] at * },
  have : a * 1 = a * (c * d),
  { simpa [mul_assoc] using a_eq },
  have : 1 = (c * d), from eq_of_mul_eq_mul_left ha0 this,
  exact ⟨units.mk_of_mul_eq_one c d (this.symm), by rw [units.mk_of_mul_eq_one, units.val_coe]⟩
end

protected def setoid (α : Type*) [monoid α] : setoid α :=
{ r := associated, iseqv := ⟨associated.refl, λa b, associated.symm, λa b c, associated.trans⟩ }

end associated

local attribute [instance] associated.setoid

def associates (α : Type*) [monoid α] : Type* :=
quotient (associated.setoid α)

namespace associates
open associated

protected def mk {α : Type*} [monoid α] (a : α) : associates α :=
⟦ a ⟧

theorem mk_eq_mk_iff_associated [monoid α] {a b : α} :
  associates.mk a = associates.mk b ↔ a ~ᵤ b :=
iff.intro quotient.exact quot.sound

theorem quotient_mk_eq_mk [monoid α] (a : α) : ⟦ a ⟧ = associates.mk a := rfl

theorem quot_mk_eq_mk [monoid α] (a : α) : quot.mk setoid.r a = associates.mk a := rfl

theorem forall_associated [monoid α] {p : associates α → Prop} :
  (∀a, p a) ↔ (∀a, p (associates.mk a)) :=
iff.intro
  (assume h a, h _)
  (assume h a, quotient.induction_on a h)

instance [monoid α] : has_one (associates α) := ⟨⟦ 1 ⟧⟩

theorem one_eq_mk_one [monoid α] : (1 : associates α) = associates.mk 1 := rfl

instance [monoid α] : has_bot (associates α) := ⟨1⟩

section comm_monoid
variable [comm_monoid α]

instance : has_mul (associates α) :=
⟨λa' b', quotient.lift_on₂ a' b' (λa b, ⟦ a * b ⟧) $
  assume a₁ a₂ b₁ b₂ ⟨c₁, h₁⟩ ⟨c₂, h₂⟩,
  quotient.sound $ ⟨c₁ * c₂, by simp [h₁.symm, h₂.symm, mul_assoc, mul_comm, mul_left_comm]⟩⟩

theorem mk_mul_mk {x y : α} : associates.mk x * associates.mk y = associates.mk (x * y) :=
rfl

instance : comm_monoid (associates α) :=
{ one       := 1,
  mul       := (*),
  mul_one   := assume a', quotient.induction_on a' $
    assume a, show ⟦a * 1⟧ = ⟦ a ⟧, by simp,
  one_mul   := assume a', quotient.induction_on a' $
    assume a, show ⟦1 * a⟧ = ⟦ a ⟧, by simp,
  mul_assoc := assume a' b' c', quotient.induction_on₃ a' b' c' $
    assume a b c, show ⟦a * b * c⟧ = ⟦a * (b * c)⟧, by rw [mul_assoc],
  mul_comm  := assume a' b', quotient.induction_on₂ a' b' $
    assume a b, show ⟦a * b⟧ = ⟦b * a⟧, by rw [mul_comm] }

instance : preorder (associates α) :=
{ le := λa b, ∃c, a * c = b,
  le_refl := assume a, ⟨1, by simp⟩,
  le_trans := assume a b c ⟨f₁, h₁⟩ ⟨f₂, h₂⟩, ⟨f₁ * f₂, h₂ ▸ h₁ ▸ (mul_assoc _ _ _).symm⟩}

theorem prod_mk {p : multiset α} : (p.map associates.mk).prod = associates.mk p.prod :=
multiset.induction_on p (by simp; refl) $ assume a s ih, by simp [ih]; refl

theorem rel_associated_iff_map_eq_map {p q : multiset α} :
  multiset.rel associated p q ↔ p.map associates.mk = q.map associates.mk :=
by rw [← multiset.rel_eq];
  simp [multiset.rel_map_left, multiset.rel_map_right, mk_eq_mk_iff_associated]

theorem mul_eq_one_iff {x y : associates α} : x * y = 1 ↔ (x = 1 ∧ y = 1) :=
iff.intro
  (quotient.induction_on₂ x y $ assume a b h,
    have a * b ~ᵤ 1, from quotient.exact h,
    ⟨quotient.sound $ associated_one_of_associated_mul_one this,
      quotient.sound $ associated_one_of_associated_mul_one $ by rwa [mul_comm] at this⟩)
  (by simp {contextual := tt})

theorem prod_eq_one_iff {p : multiset (associates α)} :
  p.prod = 1 ↔ (∀a ∈ p, (a:associates α) = 1) :=
multiset.induction_on p
  (by simp)
  (by simp [mul_eq_one_iff, or_imp_distrib, forall_and_distrib] {contextual := tt})

theorem coe_unit_eq_one : ∀u:units (associates α), (u : associates α) = 1
| ⟨u, v, huv, hvu⟩ := by rw [mul_eq_one_iff] at huv; exact huv.1

theorem is_unit_iff_eq_one (a : associates α) : is_unit a ↔ a = 1 :=
iff.intro
  (assume ⟨u, h⟩, h.symm ▸ coe_unit_eq_one _)
  (assume h, h.symm ▸ is_unit_one)

theorem is_unit_mk {a : α} : is_unit (associates.mk a) ↔ is_unit a :=
calc is_unit (associates.mk a) ↔ a ~ᵤ 1 :
    by rw [is_unit_iff_eq_one, one_eq_mk_one, mk_eq_mk_iff_associated]
  ... ↔ is_unit a : associated_one_iff_is_unit

section order

theorem mul_mono {a b c d : associates α} (h₁ : a ≤ b) (h₂ : c ≤ d) :
  a * c ≤ b * d :=
let ⟨x, hx⟩ := h₁, ⟨y, hy⟩ := h₂ in
⟨x * y, by simp [hx.symm, hy.symm, mul_comm, mul_assoc, mul_left_comm]⟩

theorem one_le {a : associates α} : 1 ≤ a :=
⟨a, one_mul a⟩

theorem prod_le_prod {p q : multiset (associates α)} (h : p ≤ q) : p.prod ≤ q.prod :=
begin
  haveI := classical.dec_eq (associates α),
  haveI := classical.dec_eq α,
  suffices : p.prod ≤ (p + (q - p)).prod, { rwa [multiset.add_sub_of_le h] at this },
  suffices : p.prod * 1 ≤ p.prod * (q - p).prod, { simpa },
  exact mul_mono (le_refl p.prod) one_le
end

theorem le_mul_right {a b : associates α} : a ≤ a * b := ⟨b, rfl⟩

theorem le_mul_left {a b : associates α} : a ≤ b * a :=
by rw [mul_comm]; exact le_mul_right

end order

end comm_monoid

instance [has_zero α] [monoid α] : has_zero (associates α) := ⟨⟦ 0 ⟧⟩
instance [has_zero α] [monoid α] : has_top (associates α) := ⟨0⟩

section comm_semiring
variables [comm_semiring α]

@[simp] theorem mk_zero_eq (a : α) : associates.mk a = 0 ↔ a = 0 :=
⟨assume h, (associated_zero_iff_eq_zero a).1 $ quotient.exact h, assume h, h.symm ▸ rfl⟩

@[simp] theorem mul_zero : ∀(a : associates α), a * 0 = 0 :=
by rintros ⟨a⟩; show associates.mk (a * 0) = associates.mk 0; rw [mul_zero]

@[simp] theorem zero_mul : ∀(a : associates α), 0 * a = 0 :=
by rintros ⟨a⟩; show associates.mk (0 * a) = associates.mk 0; rw [zero_mul]

theorem mk_eq_zero_iff_eq_zero {a : α} : associates.mk a = 0 ↔ a = 0 :=
calc associates.mk a = 0 ↔ (a ~ᵤ 0) :  mk_eq_mk_iff_associated
  ... ↔ a = 0 : associated_zero_iff_eq_zero a

theorem dvd_of_mk_le_mk {a b : α} : associates.mk a ≤ associates.mk b → a ∣ b
| ⟨c', hc'⟩ := (quotient.induction_on c' $ assume c hc,
    let ⟨d, hd⟩ := (quotient.exact hc).symm in
    ⟨(↑d⁻¹) * c,
      calc b = (a * c) * ↑d⁻¹ : by rw [← hd, mul_assoc, units.mul_inv, mul_one]
        ... = a * (↑d⁻¹ * c) : by ac_refl⟩) hc'

theorem mk_le_mk_of_dvd {a b : α} : a ∣ b → associates.mk a ≤ associates.mk b :=
assume ⟨c, hc⟩, ⟨associates.mk c, by simp [hc]; refl⟩

theorem mk_le_mk_iff_dvd_iff {a b : α} : associates.mk a ≤ associates.mk b ↔ a ∣ b :=
iff.intro dvd_of_mk_le_mk mk_le_mk_of_dvd

end comm_semiring

section integral_domain
variable [integral_domain α]

instance : partial_order (associates α) :=
{ le_antisymm := assume a' b',
    quotient.induction_on₂ a' b' $ assume a b ⟨f₁', h₁⟩ ⟨f₂', h₂⟩,
    (quotient.induction_on₂ f₁' f₂' $ assume f₁ f₂ h₁ h₂,
      let ⟨c₁, h₁⟩ := quotient.exact h₁, ⟨c₂, h₂⟩ := quotient.exact h₂ in
      quotient.sound $ associated_of_dvd_dvd
        (h₁ ▸ dvd_mul_of_dvd_left (dvd_mul_right _ _) _)
        (h₂ ▸ dvd_mul_of_dvd_left (dvd_mul_right _ _) _)) h₁ h₂
  .. associates.preorder }

instance : lattice.order_bot (associates α) :=
{ bot := 1,
  bot_le := assume a, one_le,
  .. associates.partial_order }

instance : lattice.order_top (associates α) :=
{ top := 0,
  le_top := assume a, ⟨0, mul_zero a⟩,
  .. associates.partial_order }

theorem zero_ne_one : (0 : associates α) ≠ 1 :=
assume h,
have (0 : α) ~ᵤ 1, from quotient.exact h,
have (0 : α) = 1, from ((associated_zero_iff_eq_zero 1).1 this.symm).symm,
zero_ne_one this

theorem mul_eq_zero_iff {x y : associates α} : x * y = 0 ↔ x = 0 ∨ y = 0 :=
iff.intro
  (quotient.induction_on₂ x y $ assume a b h,
    have a * b = 0, from (associated_zero_iff_eq_zero _).1 (quotient.exact h),
    have a = 0 ∨ b = 0, from mul_eq_zero_iff_eq_zero_or_eq_zero.1 this,
    this.imp (assume h, h.symm ▸ rfl) (assume h, h.symm ▸ rfl))
  (by simp [or_imp_distrib] {contextual := tt})

theorem prod_eq_zero_iff {s : multiset (associates α)} :
  s.prod = 0 ↔ (0 : associates α) ∈ s :=
multiset.induction_on s (by simp; exact zero_ne_one.symm) $
  assume a s, by simp [mul_eq_zero_iff, @eq_comm _ 0 a] {contextual := tt}

theorem irreducible_mk_iff (a : α) : irreducible (associates.mk a) ↔ irreducible a :=
begin
  simp [irreducible, is_unit_mk],
  apply and_congr (iff.refl _),
  split,
  { assume h x y eq,
    have : is_unit (associates.mk x) ∨ is_unit (associates.mk y),
      from h _ _ (by rw [eq]; refl),
    simpa [is_unit_mk] },
  { refine assume h x y, quotient.induction_on₂ x y (assume x y eq, _),
    rcases quotient.exact eq.symm with ⟨u, eq⟩,
    have : a = x * (y * u), by rwa [mul_assoc, eq_comm] at eq,
    show is_unit (associates.mk x) ∨ is_unit (associates.mk y),
    simpa [is_unit_mk] using h _ _ this }
end

end integral_domain

section normalization_domain
variable [normalization_domain α]

protected def out : associates α → α :=
begin
  refine quotient.lift (λa, a * ↑(norm_unit a)) _,
  letI := classical.dec_eq α,
  rintros a _ ⟨u, rfl⟩,
  by_cases a = 0, { simp [h] },
  calc a * ↑(norm_unit a) = a * ↑(u * norm_unit a * u⁻¹) :
      by rw [mul_comm u, mul_assoc, mul_inv_self, mul_one]
    ... = a * ↑u * ↑(norm_unit (a * ↑u)) :
      by simp [h, norm_unit_mul, units.mul_coe, units.inv_coe, mul_assoc]
end

lemma out_mk (a : α) : (associates.mk a).out = a * ↑(norm_unit a) :=
rfl

@[simp] lemma out_one : (1 : associates α).out = 1 :=
calc (1 : associates α).out = 1 * ↑(norm_unit (1 : α)) : out_mk _
  ... = 1 : by simp

lemma out_mul (a b : associates α) : (a * b).out = a.out * b.out :=
begin
  refine quotient.induction_on₂ a b (assume a b, _),
  simp [associates.quotient_mk_eq_mk, out_mk, mk_mul_mk],
  letI := classical.dec_eq α,
  by_cases a = 0; by_cases b = 0; simp [*, mul_assoc, mul_comm, mul_left_comm]
end

lemma dvd_out_iff (a : α) (b : associates α) : a ∣ b.out ↔ associates.mk a ≤ b :=
quotient.induction_on b $ by simp [associates.out_mk, associates.quotient_mk_eq_mk, mk_le_mk_iff_dvd_iff]

lemma out_dvd_iff (a : α) (b : associates α) : b.out ∣ a ↔ b ≤ associates.mk a :=
quotient.induction_on b $ by simp [associates.out_mk, associates.quotient_mk_eq_mk, mk_le_mk_iff_dvd_iff]

@[simp] lemma out_top : (⊤ : associates α).out = 0 :=
calc (⊤ : associates α).out = 0 * ↑(norm_unit (0:α)) : out_mk _
  ... = 0 : by simp

@[simp] lemma norm_unit_out (a : associates α) : norm_unit a.out = 1 :=
quotient.induction_on a $ assume a,
  by rw [associates.quotient_mk_eq_mk, associates.out_mk, norm_unit_mul_norm_unit]

end normalization_domain

end associates

def associates_int_equiv_nat : (associates ℤ) ≃ ℕ :=
begin
  refine ⟨λz, z.out.nat_abs, λn, associates.mk n, _, _⟩,
  { refine (assume a, quotient.induction_on a $ assume a,
      associates.mk_eq_mk_iff_associated.2 $ associated.symm $ ⟨norm_unit a, _⟩),
    simp [associates.out_mk, associates.quotient_mk_eq_mk, associated,
      int.coe_nat_abs_eq_mul_norm_unit.symm] },
  { assume n, simp [associates.out_mk, int.coe_nat_abs_eq_mul_norm_unit.symm] }
end