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

/-!
# `ring`

Evaluate expressions in the language of commutative (semi)rings.
Based on <http://www.cs.ru.nl/~freek/courses/tt-2014/read/10.1.1.61.3041.pdf> .
-/

namespace tactic
namespace ring

/-- The normal form that `ring` uses is mediated by the function `horner a x n b := a * x ^ n + b`.
The reason we use a definition rather than the (more readable) expression on the right is because
this expression contains a number of typeclass arguments in different positions, while `horner`
contains only one `comm_semiring` instance at the top level. See also `horner_expr` for a
description of normal form. -/
def horner {α} [comm_semiring α] (a x : α) (n : ℕ) (b : α) := a * x ^ n + b

/-- This cache contains data required by the `ring` tactic during execution. -/
meta structure cache :=
(α : expr)
(univ : level)
(comm_semiring_inst : expr)
(red : transparency)
(ic : ref instance_cache)
(nc : ref instance_cache)
(atoms : ref (buffer expr))

/-- The monad that `ring` works in. This is a reader monad containing a mutable cache (using `ref`
for mutability), as well as the list of atoms-up-to-defeq encountered thus far, used for atom
sorting. -/
@[derive [monad, alternative]]
meta def ring_m (α : Type) : Type :=
reader_t cache tactic α

/-- Get the `ring` data from the monad. -/
meta def get_cache : ring_m cache := reader_t.read

/-- Get an already encountered atom by its index. -/
meta def get_atom (n : ℕ) : ring_m expr :=
⟨λ c, do es ← read_ref c.atoms, pure (es.read' n)⟩

/-- Get the index corresponding to an atomic expression, if it has already been encountered, or
put it in the list of atoms and return the new index, otherwise. -/
meta def add_atom (e : expr) : ring_m ℕ :=
⟨λ c, do
  let red := c.red,
  es ← read_ref c.atoms,
  es.iterate failed (λ n e' t, t <|> (is_def_eq e e' red $> n)) <|>
  (es.size <$ write_ref c.atoms (es.push_back e))⟩

/-- Lift a tactic into the `ring_m` monad. -/
@[inline] meta def lift {α} (m : tactic α) : ring_m α := reader_t.lift m

/-- Run a `ring_m` tactic in the tactic monad. This version of `ring_m.run` uses an external
atoms ref, so that subexpressions can be named across multiple `ring_m` calls. -/
meta def ring_m.run' (red : transparency) (atoms : ref (buffer expr))
  (e : expr) {α} (m : ring_m α) : tactic α :=
do α ← infer_type e,
   u ← mk_meta_univ,
   infer_type α >>= unify (expr.sort (level.succ u)),
   u ← get_univ_assignment u,
   ic ← mk_instance_cache α,
   (ic, c) ← ic.get ``comm_semiring,
   nc ← mk_instance_cache `(ℕ),
   using_new_ref ic $ λ r,
   using_new_ref nc $ λ nr,
   reader_t.run m ⟨α, u, c, red, r, nr, atoms⟩

/-- Run a `ring_m` tactic in the tactic monad. -/
meta def ring_m.run (red : transparency) (e : expr) {α} (m : ring_m α) : tactic α :=
using_new_ref mk_buffer $ λ atoms, ring_m.run' red atoms e m

/-- Lift an instance cache tactic (probably from `norm_num`) to the `ring_m` monad. This version
is abstract over the instance cache in question (either the ring `α`, or `ℕ` for exponents). -/
@[inline] meta def ic_lift' (icf : cache → ref instance_cache) {α}
  (f : instance_cache → tactic (instance_cache × α)) : ring_m α :=
⟨λ c, do
  let r := icf c,
  ic ← read_ref r,
  (ic', a) ← f ic,
  a <$ write_ref r ic'⟩

/-- Lift an instance cache tactic (probably from `norm_num`) to the `ring_m` monad. This uses
the instance cache corresponding to the ring `α`. -/
@[inline] meta def ic_lift {α} : (instance_cache → tactic (instance_cache × α)) → ring_m α :=
ic_lift' cache.ic

/-- Lift an instance cache tactic (probably from `norm_num`) to the `ring_m` monad. This uses
the instance cache corresponding to `ℕ`, which is used for computations in the exponent. -/
@[inline] meta def nc_lift {α} : (instance_cache → tactic (instance_cache × α)) → ring_m α :=
ic_lift' cache.nc

/-- Apply a theorem that expects a `comm_semiring` instance. This is a special case of
`ic_lift mk_app`, but it comes up often because `horner` and all its theorems have this assumption;
it also does not require the tactic monad which improves access speed a bit. -/
meta def cache.cs_app (c : cache) (n : name) : list expr → expr :=
(@expr.const tt n [c.univ] c.α c.comm_semiring_inst).mk_app

/-- Every expression in the language of commutative semirings can be viewed as a sum of monomials,
where each monomial is a product of powers of atoms. We fix a global order on atoms (up to
definitional equality), and then separate the terms according to their smallest atom. So the top
level expression is `a * x^n + b` where `x` is the smallest atom and `n > 0` is a numeral, and
`n` is maximal (so `a` contains at least one monomial not containing an `x`), and `b` contains no
monomials with an `x` (hence all atoms in `b` are larger than `x`).

If there is no `x` satisfying these constraints, then the expression must be a numeral. Even though
we are working over rings, we allow rational constants when these can be interpreted in the ring,
so we can solve problems like `x / 3 = 1 / 3 * x` even though these are not technically in the
language of rings.

These constraints ensure that there is a unique normal form for each ring expression, and so the
algorithm is simply to calculate the normal form of each side and compare for equality.

To allow us to efficiently pattern match on normal forms, we maintain this inductive type that
holds a normalized expression together with its structure. All the `expr`s in this type could be
removed without loss of information, and conversely the `horner_expr` structure and the `ℕ` and
`ℚ` values can be recovered from the top level `expr`, but we keep both in order to keep proof
 producing normalization functions efficient. -/
meta inductive horner_expr : Type
| const (e : expr) (coeff : ℚ) : horner_expr
| xadd (e : expr) (a : horner_expr) (x : expr × ℕ) (n : expr × ℕ) (b : horner_expr) : horner_expr

/-- Get the expression corresponding to a `horner_expr`. This can be calculated recursively from
the structure, but we cache the exprs in all subterms so that this function can be computed in
constant time. -/
meta def horner_expr.e : horner_expr → expr
| (horner_expr.const e _) := e
| (horner_expr.xadd e _ _ _ _) := e

/-- Is this expr the constant `0`? -/
meta def horner_expr.is_zero : horner_expr → bool
| (horner_expr.const _ c) := c = 0
| _ := ff

meta instance : has_coe horner_expr expr := ⟨horner_expr.e⟩
meta instance : has_coe_to_fun horner_expr (λ _, expr → expr) := ⟨λ e, ⇑(e : expr)⟩

/-- Construct a `xadd` node, generating the cached expr using the input cache. -/
meta def horner_expr.xadd' (c : cache) (a : horner_expr)
  (x : expr × ℕ) (n : expr × ℕ) (b : horner_expr) : horner_expr :=
horner_expr.xadd (c.cs_app ``horner [a, x.1, n.1, b]) a x n b

open horner_expr

/-- Pretty printer for `horner_expr`. -/
meta def horner_expr.to_string : horner_expr → string
| (const e c) := to_string (e, c)
| (xadd e a x (_, n) b) :=
    "(" ++ a.to_string ++ ") * (" ++ to_string x.1 ++ ")^"
        ++ to_string n ++ " + " ++ b.to_string

/-- Pretty printer for `horner_expr`. -/
meta def horner_expr.pp : horner_expr → tactic format
| (const e c) := pp (e, c)
| (xadd e a x (_, n) b) := do
  pa ← a.pp, pb ← b.pp, px ← pp x.1,
  return $ "(" ++ pa ++ ") * (" ++ px ++ ")^" ++ to_string n ++ " + " ++ pb

meta instance : has_to_tactic_format horner_expr := ⟨horner_expr.pp⟩

/-- Reflexivity conversion for a `horner_expr`. -/
meta def horner_expr.refl_conv (e : horner_expr) : ring_m (horner_expr × expr) :=
do p ← lift $ mk_eq_refl e, return (e, p)

theorem zero_horner {α} [comm_semiring α] (x n b) :
  @horner α _ 0 x n b = b :=
by simp [horner]

theorem horner_horner {α} [comm_semiring α] (a₁ x n₁ n₂ b n')
  (h : n₁ + n₂ = n') :
  @horner α _ (horner a₁ x n₁ 0) x n₂ b = horner a₁ x n' b :=
by simp [h.symm, horner, pow_add, mul_assoc]

/-- Evaluate `horner a n x b` where `a` and `b` are already in normal form. -/
meta def eval_horner : horner_expr → expr × ℕ → expr × ℕ → horner_expr → ring_m (horner_expr × expr)
| ha@(const a coeff) x n b := do
  c ← get_cache,
  if coeff = 0 then
    return (b, c.cs_app ``zero_horner [x.1, n.1, b])
  else (xadd' c ha x n b).refl_conv
| ha@(xadd a a₁ x₁ n₁ b₁) x n b := do
  c ← get_cache,
  if x₁.2 = x.2 ∧ b₁.e.to_nat = some 0 then do
    (n', h) ← nc_lift $ λ nc, norm_num.prove_add_nat' nc n₁.1 n.1,
    return (xadd' c a₁ x (n', n₁.2 + n.2) b,
      c.cs_app ``horner_horner [a₁, x.1, n₁.1, n.1, b, n', h])
  else (xadd' c ha x n b).refl_conv

theorem const_add_horner {α} [comm_semiring α] (k a x n b b') (h : k + b = b') :
  k + @horner α _ a x n b = horner a x n b' :=
by simp [h.symm, horner]; cc

theorem horner_add_const {α} [comm_semiring α] (a x n b k b') (h : b + k = b') :
  @horner α _ a x n b + k = horner a x n b' :=
by simp [h.symm, horner, add_assoc]

theorem horner_add_horner_lt {α} [comm_semiring α] (a₁ x n₁ b₁ a₂ n₂ b₂ k a' b')
  (h₁ : n₁ + k = n₂) (h₂ : (a₁ + horner a₂ x k 0 : α) = a') (h₃ : b₁ + b₂ = b') :
  @horner α _ a₁ x n₁ b₁ + horner a₂ x n₂ b₂ = horner a' x n₁ b' :=
by simp [h₂.symm, h₃.symm, h₁.symm, horner, pow_add, mul_add, mul_comm, mul_left_comm]; cc

theorem horner_add_horner_gt {α} [comm_semiring α] (a₁ x n₁ b₁ a₂ n₂ b₂ k a' b')
  (h₁ : n₂ + k = n₁) (h₂ : (horner a₁ x k 0 + a₂ : α) = a') (h₃ : b₁ + b₂ = b') :
  @horner α _ a₁ x n₁ b₁ + horner a₂ x n₂ b₂ = horner a' x n₂ b' :=
by simp [h₂.symm, h₃.symm, h₁.symm, horner, pow_add, mul_add, mul_comm, mul_left_comm]; cc

theorem horner_add_horner_eq {α} [comm_semiring α] (a₁ x n b₁ a₂ b₂ a' b' t)
  (h₁ : a₁ + a₂ = a') (h₂ : b₁ + b₂ = b') (h₃ : horner a' x n b' = t) :
  @horner α _ a₁ x n b₁ + horner a₂ x n b₂ = t :=
by simp [h₃.symm, h₂.symm, h₁.symm, horner, add_mul, mul_comm (x ^ n)]; cc

/-- Evaluate `a + b` where `a` and `b` are already in normal form. -/
meta def eval_add : horner_expr → horner_expr → ring_m (horner_expr × expr)
| (const e₁ c₁) (const e₂ c₂) := ic_lift $ λ ic, do
  let n := c₁ + c₂,
  (ic, e) ← ic.of_rat n,
  (ic, p) ← norm_num.prove_add_rat ic e₁ e₂ e c₁ c₂ n,
  return (ic, const e n, p)
| he₁@(const e₁ c₁) he₂@(xadd e₂ a x n b) := do
  c ← get_cache,
  if c₁ = 0 then ic_lift $ λ ic, do
    (ic, p) ← ic.mk_app ``zero_add [e₂],
    return (ic, he₂, p)
  else do
    (b', h) ← eval_add he₁ b,
    return (xadd' c a x n b',
      c.cs_app ``const_add_horner [e₁, a, x.1, n.1, b, b', h])
| he₁@(xadd e₁ a x n b) he₂@(const e₂ c₂) := do
  c ← get_cache,
  if c₂ = 0 then ic_lift $ λ ic, do
    (ic, p) ← ic.mk_app ``add_zero [e₁],
    return (ic, he₁, p)
  else do
    (b', h) ← eval_add b he₂,
    return (xadd' c a x n b',
      c.cs_app ``horner_add_const [a, x.1, n.1, b, e₂, b', h])
| he₁@(xadd e₁ a₁ x₁ n₁ b₁) he₂@(xadd e₂ a₂ x₂ n₂ b₂) := do
  c ← get_cache,
  if x₁.2 < x₂.2 then do
    (b', h) ← eval_add b₁ he₂,
    return (xadd' c a₁ x₁ n₁ b',
      c.cs_app ``horner_add_const [a₁, x₁.1, n₁.1, b₁, e₂, b', h])
  else if x₁.2 ≠ x₂.2 then do
    (b', h) ← eval_add he₁ b₂,
    return (xadd' c a₂ x₂ n₂ b',
      c.cs_app ``const_add_horner [e₁, a₂, x₂.1, n₂.1, b₂, b', h])
  else if n₁.2 < n₂.2 then do
    let k := n₂.2 - n₁.2,
    (ek, h₁) ← nc_lift (λ nc, do
      (nc, ek) ← nc.of_nat k,
      (nc, h₁) ← norm_num.prove_add_nat nc n₁.1 ek n₂.1,
      return (nc, ek, h₁)),
    α0 ← ic_lift $ λ ic, ic.mk_app ``has_zero.zero [],
    (a', h₂) ← eval_add a₁ (xadd' c a₂ x₁ (ek, k) (const α0 0)),
    (b', h₃) ← eval_add b₁ b₂,
    return (xadd' c a' x₁ n₁ b',
      c.cs_app ``horner_add_horner_lt [a₁, x₁.1, n₁.1, b₁, a₂, n₂.1, b₂, ek, a', b', h₁, h₂, h₃])
  else if n₁.2 ≠ n₂.2 then do
    let k := n₁.2 - n₂.2,
    (ek, h₁) ← nc_lift (λ nc, do
      (nc, ek) ← nc.of_nat k,
      (nc, h₁) ← norm_num.prove_add_nat nc n₂.1 ek n₁.1,
      return (nc, ek, h₁)),
    α0 ← ic_lift $ λ ic, ic.mk_app ``has_zero.zero [],
    (a', h₂) ← eval_add (xadd' c a₁ x₁ (ek, k) (const α0 0)) a₂,
    (b', h₃) ← eval_add b₁ b₂,
    return (xadd' c a' x₁ n₂ b',
      c.cs_app ``horner_add_horner_gt [a₁, x₁.1, n₁.1, b₁, a₂, n₂.1, b₂, ek, a', b', h₁, h₂, h₃])
  else do
    (a', h₁) ← eval_add a₁ a₂,
    (b', h₂) ← eval_add b₁ b₂,
    (t, h₃) ← eval_horner a' x₁ n₁ b',
    return (t, c.cs_app ``horner_add_horner_eq
      [a₁, x₁.1, n₁.1, b₁, a₂, b₂, a', b', t, h₁, h₂, h₃])

theorem horner_neg {α} [comm_ring α] (a x n b a' b')
  (h₁ : -a = a') (h₂ : -b = b') :
  -@horner α _ a x n b = horner a' x n b' :=
by simp [h₂.symm, h₁.symm, horner]; cc

/-- Evaluate `-a` where `a` is already in normal form. -/
meta def eval_neg : horner_expr → ring_m (horner_expr × expr)
| (const e coeff) := do
  (e', p) ← ic_lift $ λ ic, norm_num.prove_neg ic e,
  return (const e' (-coeff), p)
| (xadd e a x n b) := do
  c ← get_cache,
  (a', h₁) ← eval_neg a,
  (b', h₂) ← eval_neg b,
  p ← ic_lift $ λ ic, ic.mk_app ``horner_neg [a, x.1, n.1, b, a', b', h₁, h₂],
  return (xadd' c a' x n b', p)

theorem horner_const_mul {α} [comm_semiring α] (c a x n b a' b')
  (h₁ : c * a = a') (h₂ : c * b = b') :
  c * @horner α _ a x n b = horner a' x n b' :=
by simp [h₂.symm, h₁.symm, horner, mul_add, mul_assoc]

theorem horner_mul_const {α} [comm_semiring α] (a x n b c a' b')
  (h₁ : a * c = a') (h₂ : b * c = b') :
  @horner α _ a x n b * c = horner a' x n b' :=
by simp [h₂.symm, h₁.symm, horner, add_mul, mul_right_comm]

/-- Evaluate `k * a` where `k` is a rational numeral and `a` is in normal form. -/
meta def eval_const_mul (k : expr × ℚ) :
  horner_expr → ring_m (horner_expr × expr)
| (const e coeff) := do
  (e', p) ← ic_lift $ λ ic, norm_num.prove_mul_rat ic k.1 e k.2 coeff,
  return (const e' (k.2 * coeff), p)
| (xadd e a x n b) := do
  c ← get_cache,
  (a', h₁) ← eval_const_mul a,
  (b', h₂) ← eval_const_mul b,
  return (xadd' c a' x n b',
    c.cs_app ``horner_const_mul [k.1, a, x.1, n.1, b, a', b', h₁, h₂])

theorem horner_mul_horner_zero {α} [comm_semiring α] (a₁ x n₁ b₁ a₂ n₂ aa t)
  (h₁ : @horner α _ a₁ x n₁ b₁ * a₂ = aa)
  (h₂ : horner aa x n₂ 0 = t) :
  horner a₁ x n₁ b₁ * horner a₂ x n₂ 0 = t :=
by rw [← h₂, ← h₁];
   simp [horner, mul_add, mul_comm, mul_left_comm, mul_assoc]

theorem horner_mul_horner {α} [comm_semiring α]
  (a₁ x n₁ b₁ a₂ n₂ b₂ aa haa ab bb t)
  (h₁ : @horner α _ a₁ x n₁ b₁ * a₂ = aa)
  (h₂ : horner aa x n₂ 0 = haa)
  (h₃ : a₁ * b₂ = ab) (h₄ : b₁ * b₂ = bb)
  (H : haa + horner ab x n₁ bb = t) :
  horner a₁ x n₁ b₁ * horner a₂ x n₂ b₂ = t :=
by rw [← H, ← h₂, ← h₁, ← h₃, ← h₄];
   simp [horner, mul_add, mul_comm, mul_left_comm, mul_assoc]

/-- Evaluate `a * b` where `a` and `b` are in normal form. -/
meta def eval_mul : horner_expr → horner_expr → ring_m (horner_expr × expr)
| (const e₁ c₁) (const e₂ c₂) := do
  (e', p) ← ic_lift $ λ ic, norm_num.prove_mul_rat ic e₁ e₂ c₁ c₂,
  return (const e' (c₁ * c₂), p)
| (const e₁ c₁) e₂ :=
  if c₁ = 0 then do
    c ← get_cache,
    α0 ← ic_lift $ λ ic, ic.mk_app ``has_zero.zero [],
    p ← ic_lift $ λ ic, ic.mk_app ``zero_mul [e₂],
    return (const α0 0, p)
  else if c₁ = 1 then do
    p ← ic_lift $ λ ic, ic.mk_app ``one_mul [e₂],
    return (e₂, p)
  else eval_const_mul (e₁, c₁) e₂
| e₁ he₂@(const e₂ c₂) := do
  p₁ ← ic_lift $ λ ic, ic.mk_app ``mul_comm [e₁, e₂],
  (e', p₂) ← eval_mul he₂ e₁,
  p ← lift $ mk_eq_trans p₁ p₂, return (e', p)
| he₁@(xadd e₁ a₁ x₁ n₁ b₁) he₂@(xadd e₂ a₂ x₂ n₂ b₂) := do
  c ← get_cache,
  if x₁.2 < x₂.2 then do
    (a', h₁) ← eval_mul a₁ he₂,
    (b', h₂) ← eval_mul b₁ he₂,
    return (xadd' c a' x₁ n₁ b',
      c.cs_app ``horner_mul_const [a₁, x₁.1, n₁.1, b₁, e₂, a', b', h₁, h₂])
  else if x₁.2 ≠ x₂.2 then do
    (a', h₁) ← eval_mul he₁ a₂,
    (b', h₂) ← eval_mul he₁ b₂,
    return (xadd' c a' x₂ n₂ b',
      c.cs_app ``horner_const_mul [e₁, a₂, x₂.1, n₂.1, b₂, a', b', h₁, h₂])
  else do
    (aa, h₁) ← eval_mul he₁ a₂,
    α0 ← ic_lift $ λ ic, ic.mk_app ``has_zero.zero [],
    (haa, h₂) ← eval_horner aa x₁ n₂ (const α0 0),
    if b₂.is_zero then
      return (haa, c.cs_app ``horner_mul_horner_zero
        [a₁, x₁.1, n₁.1, b₁, a₂, n₂.1, aa, haa, h₁, h₂])
    else do
      (ab, h₃) ← eval_mul a₁ b₂,
      (bb, h₄) ← eval_mul b₁ b₂,
      (t, H) ← eval_add haa (xadd' c ab x₁ n₁ bb),
      return (t, c.cs_app ``horner_mul_horner
        [a₁, x₁.1, n₁.1, b₁, a₂, n₂.1, b₂, aa, haa, ab, bb, t, h₁, h₂, h₃, h₄, H])

theorem horner_pow {α} [comm_semiring α] (a x n m n' a') (h₁ : n * m = n') (h₂ : a ^ m = a') :
  @horner α _ a x n 0 ^ m = horner a' x n' 0 :=
by simp [h₁.symm, h₂.symm, horner, mul_pow, pow_mul]

theorem pow_succ {α} [comm_semiring α] (a n b c)
  (h₁ : (a:α) ^ n = b) (h₂ : b * a = c) : a ^ (n + 1) = c :=
by rw [← h₂, ← h₁, pow_succ']

/-- Evaluate `a ^ n` where `a` is in normal form and `n` is a natural numeral. -/
meta def eval_pow : horner_expr → expr × ℕ → ring_m (horner_expr × expr)
| e (_, 0) := do
  c ← get_cache,
  α1 ← ic_lift $ λ ic, ic.mk_app ``has_one.one [],
  p ← ic_lift $ λ ic, ic.mk_app ``pow_zero [e],
  return (const α1 1, p)
| e (_, 1) := do
  p ← ic_lift $ λ ic, ic.mk_app ``pow_one [e],
  return (e, p)
| (const e coeff) (e₂, m) := ic_lift $ λ ic, do
  (ic, e', p) ← norm_num.prove_pow e coeff ic e₂,
  return (ic, const e' (coeff ^ m), p)
| he@(xadd e a x n b) m := do
  c ← get_cache,
  match b.e.to_nat with
  | some 0 := do
    (n', h₁) ← nc_lift $ λ nc, norm_num.prove_mul_rat nc n.1 m.1 n.2 m.2,
    (a', h₂) ← eval_pow a m,
    α0 ← ic_lift $ λ ic, ic.mk_app ``has_zero.zero [],
    return (xadd' c a' x (n', n.2 * m.2) (const α0 0),
      c.cs_app ``horner_pow [a, x.1, n.1, m.1, n', a', h₁, h₂])
  | _ := do
    e₂ ← nc_lift $ λ nc, nc.of_nat (m.2-1),
    (tl, hl) ← eval_pow he (e₂, m.2-1),
    (t, p₂) ← eval_mul tl he,
    return (t, c.cs_app ``pow_succ [e, e₂, tl, t, hl, p₂])
  end

theorem horner_atom {α} [comm_semiring α] (x : α) : x = horner 1 x 1 0 :=
by simp [horner]

/-- Evaluate `a` where `a` is an atom. -/
meta def eval_atom (e : expr) : ring_m (horner_expr × expr) :=
do c ← get_cache,
  i ← add_atom e,
  α0 ← ic_lift $ λ ic, ic.mk_app ``has_zero.zero [],
  α1 ← ic_lift $ λ ic, ic.mk_app ``has_one.one [],
  return (xadd' c (const α1 1) (e, i) (`(1), 1) (const α0 0),
    c.cs_app ``horner_atom [e])

lemma subst_into_pow {α} [monoid α] (l r tl tr t)
  (prl : (l : α) = tl) (prr : (r : ℕ) = tr) (prt : tl ^ tr = t) : l ^ r = t :=
by rw [prl, prr, prt]

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

lemma unfold_div {α} [division_ring α] (a b c : α)
  (h : a * b⁻¹ = c) : a / b = c :=
by rw [div_eq_mul_inv, h]

/-- Evaluate a ring expression `e` recursively to normal form, together with a proof of
equality. -/
meta def eval : expr → ring_m (horner_expr × expr)
| `(%%e₁ + %%e₂) := do
  (e₁', p₁) ← eval e₁,
  (e₂', p₂) ← eval e₂,
  (e', p') ← eval_add e₁' e₂',
  p ← ic_lift $ λ ic, ic.mk_app ``norm_num.subst_into_add [e₁, e₂, e₁', e₂', e', p₁, p₂, p'],
  return (e', p)
| e@`(@has_sub.sub %%α %%inst %%e₁ %%e₂) :=
  mcond (succeeds (lift $ mk_app ``comm_ring [α] >>= mk_instance))
    (do
      e₂' ← ic_lift $ λ ic, ic.mk_app ``has_neg.neg [e₂],
      e ← ic_lift $ λ ic, ic.mk_app ``has_add.add [e₁, e₂'],
      (e', p) ← eval e,
      p' ← ic_lift $ λ ic, ic.mk_app ``unfold_sub [e₁, e₂, e', p],
      return (e', p'))
    (eval_atom e)
| `(- %%e) := do
  (e₁, p₁) ← eval e,
  (e₂, p₂) ← eval_neg e₁,
  p ← ic_lift $ λ ic, ic.mk_app ``norm_num.subst_into_neg [e, e₁, e₂, p₁, p₂],
  return (e₂, p)
| `(%%e₁ * %%e₂) := do
  (e₁', p₁) ← eval e₁,
  (e₂', p₂) ← eval e₂,
  (e', p') ← eval_mul e₁' e₂',
  p ← ic_lift $ λ ic, ic.mk_app ``norm_num.subst_into_mul [e₁, e₂, e₁', e₂', e', p₁, p₂, p'],
  return (e', p)
| e@`(has_inv.inv %%_) := (do
    (e', p) ← lift $ norm_num.derive e <|> refl_conv e,
    n ← lift $ e'.to_rat,
    return (const e' n, p)) <|> eval_atom e
| e@`(@has_div.div _ %%inst %%e₁ %%e₂) := mcond
  (succeeds (do
    inst' ← ic_lift $ λ ic, ic.mk_app ``div_inv_monoid.to_has_div [],
    lift $ is_def_eq inst inst'))
  (do
    e₂' ← ic_lift $ λ ic, ic.mk_app ``has_inv.inv [e₂],
    e ← ic_lift $ λ ic, ic.mk_app ``has_mul.mul [e₁, e₂'],
    (e', p) ← eval e,
    p' ← ic_lift $ λ ic, ic.mk_app ``unfold_div [e₁, e₂, e', p],
    return (e', p'))
  (eval_atom e)
| e@`(@has_pow.pow _ _ %%P %%e₁ %%e₂) := do
  (e₂', p₂) ← lift $ norm_num.derive e₂ <|> refl_conv e₂,
  match e₂'.to_nat, P with
  | some k, `(monoid.has_pow) := do
    (e₁', p₁) ← eval e₁,
    (e', p') ← eval_pow e₁' (e₂, k),
    p ← ic_lift $ λ ic, ic.mk_app ``subst_into_pow [e₁, e₂, e₁', e₂', e', p₁, p₂, p'],
    return (e', p)
  | _, _ := eval_atom e
  end
| e := match e.to_nat with
  | some n := (const e (rat.of_int n)).refl_conv
  | none := eval_atom e
  end

/-- Evaluate a ring expression `e` recursively to normal form, together with a proof of
equality. -/
meta def eval' (red : transparency) (atoms : ref (buffer expr))
  (e : expr) : tactic (expr × expr) :=
ring_m.run' red atoms e $ do (e', p) ← eval e, return (e', p)

theorem horner_def' {α} [comm_semiring α] (a x n b) : @horner α _ a x n b = x ^ n * a + b :=
by simp [horner, mul_comm]

theorem mul_assoc_rev {α} [semigroup α] (a b c : α) : a * (b * c) = a * b * c :=
by simp [mul_assoc]

theorem pow_add_rev {α} [monoid α] (a : α) (m n : ℕ) : a ^ m * a ^ n = a ^ (m + n) :=
by simp [pow_add]

theorem pow_add_rev_right {α} [monoid α] (a b : α) (m n : ℕ) :
  b * a ^ m * a ^ n = b * a ^ (m + n) :=
by simp [pow_add, mul_assoc]

theorem add_neg_eq_sub {α} [add_group α] (a b : α) : a + -b = a - b := (sub_eq_add_neg a b).symm

/-- If `ring` fails to close the goal, it falls back on normalizing the expression to a "pretty"
form so that you can see why it failed. This setting adjusts the resulting form:

  * `raw` is the form that `ring` actually uses internally, with iterated applications of `horner`.
    Not very readable but useful if you don't want any postprocessing.
    This results in terms like `horner (horner (horner 3 y 1 0) x 2 1) x 1 (horner 1 y 1 0)`.
  * `horner` maintains the Horner form structure, but it unfolds the `horner` definition itself,
    and tries to otherwise minimize parentheses.
    This results in terms like `(3 * x ^ 2 * y + 1) * x + y`.
  * `SOP` means sum of products form, expanding everything to monomials.
    This results in terms like `3 * x ^ 3 * y + x + y`. -/
@[derive [has_reflect, decidable_eq]]
inductive normalize_mode | raw | SOP | horner

instance : inhabited normalize_mode := ⟨normalize_mode.horner⟩

/-- A `ring`-based normalization simplifier that rewrites ring expressions into the specified mode.
  See `normalize`. This version takes a list of atoms to persist across multiple calls. -/
meta def normalize' (atoms : ref (buffer expr))
  (red : transparency) (mode := normalize_mode.horner) (e : expr) : tactic (expr × expr) :=
do
  pow_lemma ← simp_lemmas.mk.add_simp ``pow_one,
  let lemmas := match mode with
  | normalize_mode.SOP :=
    [``horner_def', ``add_zero, ``mul_one, ``mul_add, ``mul_sub,
    ``mul_assoc_rev, ``pow_add_rev, ``pow_add_rev_right,
    ``mul_neg_eq_neg_mul_symm, ``add_neg_eq_sub]
  | normalize_mode.horner :=
    [``horner.equations._eqn_1, ``add_zero, ``one_mul, ``pow_one,
    ``neg_mul_eq_neg_mul_symm, ``add_neg_eq_sub]
  | _ := []
  end,
  lemmas ← lemmas.mfoldl simp_lemmas.add_simp simp_lemmas.mk,
  trans_conv
    (λ e, do
      guard (mode ≠ normalize_mode.raw),
      (e', pr, _) ← simplify simp_lemmas.mk [] e,
      pure (e', pr))
    (λ e, do
      a ← read_ref atoms,
      (a, e', pr) ← ext_simplify_core a {}
        simp_lemmas.mk (λ _, failed) (λ a _ _ _ e, do
          write_ref atoms a,
          (new_e, pr) ← match mode with
          | normalize_mode.raw := eval' red atoms
          | normalize_mode.horner := trans_conv (eval' red atoms)
                                      (λ e, do (e', prf, _) ← simplify lemmas [] e, pure (e', prf))
          | normalize_mode.SOP :=
            trans_conv (eval' red atoms) $
            trans_conv (λ e, do (e', prf, _) ← simplify lemmas [] e, pure (e', prf)) $
            simp_bottom_up' (λ e, norm_num.derive e <|> pow_lemma.rewrite e)
          end e,
          guard (¬ new_e =ₐ e),
          a ← read_ref atoms,
          pure (a, new_e, some pr, ff))
        (λ _ _ _ _ _, failed) `eq e,
      write_ref atoms a,
      pure (e', pr))
    e

/-- A `ring`-based normalization simplifier that rewrites ring expressions into the specified mode.

  * `raw` is the form that `ring` actually uses internally, with iterated applications of `horner`.
    Not very readable but useful if you don't want any postprocessing.
    This results in terms like `horner (horner (horner 3 y 1 0) x 2 1) x 1 (horner 1 y 1 0)`.
  * `horner` maintains the Horner form structure, but it unfolds the `horner` definition itself,
    and tries to otherwise minimize parentheses.
    This results in terms like `(3 * x ^ 2 * y + 1) * x + y`.
  * `SOP` means sum of products form, expanding everything to monomials.
    This results in terms like `3 * x ^ 3 * y + x + y`. -/
meta def normalize (red : transparency) (mode := normalize_mode.horner) (e : expr) :
  tactic (expr × expr) :=
using_new_ref mk_buffer $ λ atoms, normalize' atoms red mode e

end ring

namespace interactive

open tactic.ring

setup_tactic_parser

/-- Tactic for solving equations in the language of *commutative* (semi)rings.
  This version of `ring` fails if the target is not an equality
  that is provable by the axioms of commutative (semi)rings. -/
meta def ring1 (red : parse (tk "!")?) : tactic unit :=
let transp := if red.is_some then semireducible else reducible in
do `(%%e₁ = %%e₂) ← target,
  ((e₁', p₁), (e₂', p₂)) ← ring_m.run transp e₁ $
    prod.mk <$> eval e₁ <*> eval e₂,
  is_def_eq e₁' e₂',
  p ← mk_eq_symm p₂ >>= mk_eq_trans p₁,
  tactic.exact p

/-- Parser for `ring_nf`'s `mode` argument, which can only be the "keywords" `raw`, `horner` or
`SOP`. (Because these are not actually keywords we use a name parser and postprocess the result.)
-/
meta def ring.mode : lean.parser ring.normalize_mode :=
with_desc "(SOP|raw|horner)?" $
do mode ← ident?, match mode with
| none         := pure ring.normalize_mode.horner
| some `horner := pure ring.normalize_mode.horner
| some `SOP    := pure ring.normalize_mode.SOP
| some `raw    := pure ring.normalize_mode.raw
| _            := failed
end

/-- Simplification tactic for expressions in the language of commutative (semi)rings,
which rewrites all ring expressions into a normal form. When writing a normal form,
`ring_nf SOP` will use sum-of-products form instead of horner form.
`ring_nf!` will use a more aggressive reducibility setting to identify atoms.
-/
meta def ring_nf (red : parse (tk "!")?) (SOP : parse ring.mode) (loc : parse location) :
  tactic unit :=
do ns ← loc.get_locals,
   let transp := if red.is_some then semireducible else reducible,
   tt ← using_new_ref mk_buffer $ λ atoms,
     tactic.replace_at (normalize' atoms transp SOP) ns loc.include_goal
   | fail "ring_nf failed to simplify",
   when loc.include_goal $ try tactic.reflexivity

/-- Tactic for solving equations in the language of *commutative* (semi)rings.
`ring!` will use a more aggressive reducibility setting to identify atoms.

If the goal is not solvable, it falls back to rewriting all ring expressions
into a normal form, with a suggestion to use `ring_nf` instead, if this is the intent.
See also `ring1`, which is the same as `ring` but without the fallback behavior.

Based on [Proving Equalities in a Commutative Ring Done Right
in Coq](http://www.cs.ru.nl/~freek/courses/tt-2014/read/10.1.1.61.3041.pdf) by Benjamin Grégoire
and Assia Mahboubi.
-/
meta def ring (red : parse (tk "!")?) : tactic unit :=
ring1 red <|>
(ring_nf red normalize_mode.horner (loc.ns [none]) >> trace "Try this: ring_nf")

add_hint_tactic "ring"

add_tactic_doc
{ name        := "ring",
  category    := doc_category.tactic,
  decl_names  := [``ring, ``ring_nf, ``ring1],
  inherit_description_from := ``ring,
  tags        := ["arithmetic", "simplification", "decision procedure"] }

end interactive
end tactic

namespace conv.interactive
open conv interactive
open tactic tactic.interactive (ring.mode ring1)
open tactic.ring (normalize normalize_mode.horner)

local postfix `?`:9001 := optional

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

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

end conv.interactive


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

/-!
# Categories of indexed families of objects.

We define the pointwise category structure on indexed families of objects in a category
(and also the dependent generalization).

-/

namespace category_theory

universes w₀ w₁ w₂ v₁ v₂ u₁ u₂

variables {I : Type w₀} (C : I → Type u₁) [Π i, category.{v₁} (C i)]

/--
`pi C` gives the cartesian product of an indexed family of categories.
-/
instance pi : category.{max w₀ v₁} (Π i, C i) :=
{ hom := λ X Y, Π i, X i ⟶ Y i,
  id := λ X i, 𝟙 (X i),
  comp := λ X Y Z f g i, f i ≫ g i }

/--
This provides some assistance to typeclass search in a common situation,
which otherwise fails. (Without this `category_theory.pi.has_limit_of_has_limit_comp_eval` fails.)
-/
abbreviation pi' {I : Type v₁} (C : I → Type u₁) [Π i, category.{v₁} (C i)] :
  category.{v₁} (Π i, C i) :=
category_theory.pi C

attribute [instance] pi'

namespace pi

@[simp] lemma id_apply (X : Π i, C i) (i) : (𝟙 X : Π i, X i ⟶ X i) i = 𝟙 (X i) := rfl
@[simp] lemma comp_apply {X Y Z : Π i, C i} (f : X ⟶ Y) (g : Y ⟶ Z) (i) :
  (f ≫ g : Π i, X i ⟶ Z i) i = f i ≫ g i := rfl

/--
The evaluation functor at `i : I`, sending an `I`-indexed family of objects to the object over `i`.
-/
@[simps]
def eval (i : I) : (Π i, C i) ⥤ C i :=
{ obj := λ f, f i,
  map := λ f g α, α i, }

section
variables {J : Type w₁}

/--
Pull back an `I`-indexed family of objects to an `J`-indexed family, along a function `J → I`.
-/
@[simps]
def comap (h : J → I) : (Π i, C i) ⥤ (Π j, C (h j)) :=
{ obj := λ f i, f (h i),
  map := λ f g α i, α (h i), }

variables (I)
/--
The natural isomorphism between
pulling back a grading along the identity function,
and the identity functor. -/
@[simps]
def comap_id : comap C (id : I → I) ≅ 𝟭 (Π i, C i) :=
{ hom := { app := λ X, 𝟙 X },
  inv := { app := λ X, 𝟙 X } }.

variables {I}
variables {K : Type w₂}

/--
The natural isomorphism comparing between
pulling back along two successive functions, and
pulling back along their composition
-/
@[simps]
def comap_comp (f : K → J) (g : J → I) : comap C g ⋙ comap (C ∘ g) f ≅ comap C (g ∘ f) :=
{ hom := { app := λ X b, 𝟙 (X (g (f b))) },
  inv := { app := λ X b, 𝟙 (X (g (f b))) } }

/-- The natural isomorphism between pulling back then evaluating, and just evaluating. -/
@[simps]
def comap_eval_iso_eval (h : J → I) (j : J) : comap C h ⋙ eval (C ∘ h) j ≅ eval C (h j) :=
nat_iso.of_components (λ f, iso.refl _) (by tidy)

end

section
variables {J : Type w₀} {D : J → Type u₁} [Π j, category.{v₁} (D j)]

instance sum_elim_category : Π (s : I ⊕ J), category.{v₁} (sum.elim C D s)
| (sum.inl i) := by { dsimp, apply_instance, }
| (sum.inr j) := by { dsimp, apply_instance, }

/--
The bifunctor combining an `I`-indexed family of objects with a `J`-indexed family of objects
to obtain an `I ⊕ J`-indexed family of objects.
-/
@[simps]
def sum : (Π i, C i) ⥤ (Π j, D j) ⥤ (Π s : I ⊕ J, sum.elim C D s) :=
{ obj := λ f,
  { obj := λ g s, sum.rec f g s,
    map := λ g g' α s, sum.rec (λ i, 𝟙 (f i)) α s },
  map := λ f f' α,
  { app := λ g s, sum.rec α (λ j, 𝟙 (g j)) s, }}

end

variables {C}

/-- An isomorphism between `I`-indexed objects gives an isomorphism between each
pair of corresponding components. -/
@[simps] def iso_app {X Y : Π i, C i} (f : X ≅ Y) (i : I) : X i ≅ Y i :=
⟨f.hom i, f.inv i, by { dsimp, rw [← comp_apply, iso.hom_inv_id, id_apply] },
  by { dsimp, rw [← comp_apply, iso.inv_hom_id, id_apply] }⟩

@[simp] lemma iso_app_refl (X : Π i, C i) (i : I) : iso_app (iso.refl X) i = iso.refl (X i) := rfl
@[simp] lemma iso_app_symm {X Y : Π i, C i} (f : X ≅ Y) (i : I) :
  iso_app f.symm i = (iso_app f i).symm := rfl
@[simp] lemma iso_app_trans {X Y Z : Π i, C i} (f : X ≅ Y) (g : Y ≅ Z) (i : I) :
  iso_app (f ≪≫ g) i = iso_app f i ≪≫ iso_app g i := rfl

end pi

namespace functor

variables {C}
variables {D : I → Type u₁} [∀ i, category.{v₁} (D i)]

/--
Assemble an `I`-indexed family of functors into a functor between the pi types.
-/
@[simps]
def pi (F : Π i, C i ⥤ D i) : (Π i, C i) ⥤ (Π i, D i) :=
{ obj := λ f i, (F i).obj (f i),
  map := λ f g α i, (F i).map (α i) }

-- One could add some natural isomorphisms showing
-- how `functor.pi` commutes with `pi.eval` and `pi.comap`.

end functor

namespace nat_trans

variables {C}
variables {D : I → Type u₁} [∀ i, category.{v₁} (D i)]
variables {F G : Π i, C i ⥤ D i}

/--
Assemble an `I`-indexed family of natural transformations into a single natural transformation.
-/
@[simps]
def pi (α : Π i, F i ⟶ G i) : functor.pi F ⟶ functor.pi G :=
{ app := λ f i, (α i).app (f i), }

end nat_trans

end category_theory


import phase0.support

/-!
# Phase 1 of the recursion

This file contains the induction hypothesis for the first phase of the recursion. In this phase at
level `α`, we assume phase 1 at all levels `β < α`, but we do not assume any interaction between the
levels. Interaction will be introduced in phase 2.

## Main declarations

* `con_nf.core_tangle_data`:
* `con_nf.positioned_tangle_data`:
* `con_nf.almost_tangle_data`:
* `con_nf.tangle_data`: The data for the first phase of the recursion.
-/

open function set with_bot

noncomputable theory

universe u

namespace con_nf
variable [params.{u}]

section define_tangle_data

/-- The motor of the initial recursion. This contains the data of tangles and allowable permutations
for phase 1 of the recursion. -/
class core_tangle_data (α : type_index) :=
(tangle allowable : Type u)
[allowable_group : group allowable]
(allowable_to_struct_perm : allowable →* struct_perm α)
[allowable_action : mul_action allowable tangle]
(designated_support : by { haveI : mul_action allowable (support_condition α) :=
  mul_action.comp_hom _ allowable_to_struct_perm, exact Π t : tangle, support α allowable t })

export core_tangle_data (tangle allowable designated_support)
attribute [instance] core_tangle_data.allowable_group core_tangle_data.allowable_action

section
variables (α : type_index) [core_tangle_data α]

/-- The type of allowable permutations that we assume exists on `α`-tangles. -/
def allowable : Type u := core_tangle_data.allowable α

/-- Allowable permutations at level `α` forms a group with respect to function composition. Note
that at this stage in the recursion, we have not established that the allowable permutations on
`α`-tangles are actually (coercible to) functions, so we cannot compose them with the `∘` symbol; we
must instead use group multiplication `*`. -/
instance : group (allowable α) := core_tangle_data.allowable_group

variables {α} {X : Type*} [mul_action (struct_perm α) X]

namespace allowable

/-- Allowable permutations can be considered a subtype of structural permutations. However, we
cannot write this explicitly in type theory, so instead we assume this monoid homomorphism from
allowable permutations to structural permutations. This can be thought of as an inclusion map that
preserves the group structure. This allows allowable permutations to act on pretangles. -/
def to_struct_perm : allowable α →* struct_perm α := core_tangle_data.allowable_to_struct_perm

instance : mul_action (allowable α) (tangle α) := core_tangle_data.allowable_action

/-- Allowable permutations act on tangles. This action commutes with certain other operations; the
exact conditions are given in `smul_typed_near_litter` and `smul_pretangle_inj`. -/
instance : mul_action (allowable α) X := mul_action.comp_hom _ to_struct_perm

@[simp] lemma to_struct_perm_smul (f : allowable α) (x : X) : f.to_struct_perm • x = f • x := rfl

end allowable

/-- For each tangle, we provide a small support for it. This is known as the designated support of
the tangle. -/
def designated_support (t : tangle α) : support α (allowable α) t :=
core_tangle_data.designated_support _

end

/-- The motor of the initial recursion. This contains the data of the position function. -/
class positioned_tangle_data (α : type_index) [core_tangle_data α] :=
(position : tangle α ↪ μ)

export positioned_tangle_data (position)

variables (α : Λ) [core_tangle_data α]

/-- The motor of the initial recursion. This contains the data of the injection to all the
information needed for phase 1 of the recursion. -/
class almost_tangle_data :=
(typed_atom : atom ↪ tangle α)
(typed_near_litter : near_litter ↪ tangle α)
(smul_typed_near_litter :
  Π (π : allowable α) N, π • typed_near_litter N = typed_near_litter (π • N))
(pretangle_inj : tangle α ↪ pretangle α)
(smul_pretangle_inj : Π (π : allowable α) (t : tangle α),
  π • pretangle_inj t = pretangle_inj (π • t))

export almost_tangle_data (typed_atom typed_near_litter pretangle_inj)

namespace allowable
variables {α} [almost_tangle_data α]

/-- The action of allowable permutations on tangles commutes with the `typed_near_litter` function mapping
near-litters to typed near-litters. This is quite clear to see when representing tangles as codes,
but since at this stage tangles are just a type, we have to state this condition explicitly. -/
lemma smul_typed_near_litter (π : allowable α) (N : near_litter) :
  π • (typed_near_litter N : tangle α) = typed_near_litter (π • N) :=
almost_tangle_data.smul_typed_near_litter _ _

/-- The action of allowable permutations on tangles commutes with the `pretangle_inj` injection
converting tangles into pretangles. -/
lemma smul_pretangle_inj (π : allowable α) (t : tangle α) :
  π • pretangle_inj t = pretangle_inj (π • t) := almost_tangle_data.smul_pretangle_inj _ _

end allowable

/-- The position of typed atoms and typed near-litters in the position function at any level.
This is part of the `γ = -1` fix. -/
class position_data :=
(typed_atom_position : atom ↪ μ)
(typed_near_litter_position : near_litter ↪ μ)
(litter_lt : ∀ (L : litter) (a ∈ litter_set L),
  typed_near_litter_position L.to_near_litter < typed_atom_position a)
(litter_le_near_litter : ∀ (N : near_litter),
  typed_near_litter_position N.fst.to_near_litter ≤ typed_near_litter_position N)
(symm_diff_lt_near_litter : ∀ (N : near_litter) (a ∈ litter_set N.fst ∆ N.snd),
  typed_atom_position a < typed_near_litter_position N)

export position_data (typed_atom_position typed_near_litter_position
  litter_lt litter_le_near_litter symm_diff_lt_near_litter)

lemma litter_lt_near_litter [position_data] (N : near_litter) (hN : N.fst.to_near_litter ≠ N) :
  typed_near_litter_position N.fst.to_near_litter < typed_near_litter_position N :=
lt_of_le_of_ne (litter_le_near_litter N) (typed_near_litter_position.injective.ne hN)

variables [almost_tangle_data α] [positioned_tangle_data α] [position_data.{}]

/-- The motor of the initial recursion. This contains all the information needed for phase 1 of the
recursion. -/
class tangle_data : Prop :=
(typed_atom_position_eq : ∀ (a : atom),
  position (typed_atom a : tangle α) = typed_atom_position a)
(typed_near_litter_position_eq : ∀ (N : near_litter),
  position (typed_near_litter N : tangle α) = typed_near_litter_position N)
(support_le : Π (t : tangle α) (c : support_condition α) (hc : c ∈ designated_support t),
  c.fst.elim typed_atom_position typed_near_litter_position ≤ position t)

/-- The type of tangles that we assume were constructed at stage `α`.
Later in the recursion, we will construct this type explicitly, but for now, we will just assume
that it exists.
Fields in `tangle_data` give more information about this type. -/
add_decl_doc core_tangle_data.tangle

/-- An injection from near-litters into level `α` tangles.
These will be explicitly constructed as "typed near-litters", which are codes of the form
`(α, -1, N)` for `N` a near-litter.

Since we haven't assumed anything about the structure of tangles at this level, we can't construct
these typed near-litters explicitly, so we rely on this function instead. In the blueprint, this is
function `j`. -/
add_decl_doc almost_tangle_data.typed_near_litter

/-- Tangles can be considered a subtype of pretangles, which are tangles without extensionality and
which are guaranteed to have a `-1`-extension. This injection can be seen as an inclusion map.
Since pretangles have a membership relation, we can use this map to see the members of a tangle at
any given level, by first converting it to a pretangle. -/
add_decl_doc almost_tangle_data.pretangle_inj

/-- For any atom `a`, we can construct an `α`-tangle that has a `-1`-extension that contains exactly
this atom. This is called a typed singleton. In the blueprint, this is the function `k`. -/
add_decl_doc almost_tangle_data.typed_atom

/-- An injection from level `α` tangles into the type `μ`.
Since `μ` has a well-ordering, this induces a well-ordering on `α`-tangles: to compare two tangles,
simply compare their images under this map.

Conditions satisfied by this injection are given in `litter_lt`, `litter_lt_near_litter`,
`symm_diff_lt_near_litter`, and `support_le`. In the blueprint, this is function `ι`. -/
add_decl_doc positioned_tangle_data.position

/-- Each typed litter `L` precedes the typed singletons of all of its elements `a ∈ L`. -/
add_decl_doc position_data.litter_lt

/-- Each near litter `N` which is not a litter comes later than its associated liter `L = N°`. -/
add_decl_doc litter_lt_near_litter

/-- Each near litter `N` comes after all elements in the symmetric difference `N ∆ N°` (which is
a small set by construction). Note that if `N` is a litter, this condition is vacuously true. -/
add_decl_doc symm_diff_lt_near_litter

/-- For all tangles `t` that are not typed singletons and not typed litters, `t` comes later than
all of the support conditions in its designated support. That is, if an atom `a` is in the
designated support for `t`, then `t` lies after `a`, and if a near-litter `N` is in the designated
support for `t`, then `t` lies after `N` (under suitable maps to `μ`). -/
add_decl_doc tangle_data.support_le

end define_tangle_data

section instances
variables {α : Λ} (β : Iio α) [core_tangle_data (Iio_coe β)]

instance core_val : core_tangle_data β.val := ‹core_tangle_data β›
instance core_coe_coe : core_tangle_data (β : Λ) := ‹core_tangle_data β›

section positioned_tangle_data
variables [positioned_tangle_data (Iio_coe β)]

instance positioned_val : positioned_tangle_data β.val := ‹positioned_tangle_data _›
instance positioned_coe_coe : positioned_tangle_data (β : Λ) := ‹positioned_tangle_data _›

end positioned_tangle_data

variables [almost_tangle_data β]

instance almost_val : almost_tangle_data β.val := ‹almost_tangle_data β›

end instances

/-- The tangle data at level `⊥` is constructed by taking the tangles to be the atoms, the allowable
permutations to be near-litter-permutations, and the designated supports to be singletons. -/
instance bot.core_tangle_data : core_tangle_data ⊥ :=
{ tangle := atom,
  allowable := near_litter_perm,
  allowable_to_struct_perm := struct_perm.to_bot_iso.to_monoid_hom,
  allowable_action := infer_instance,
  designated_support := λ a,
    { carrier := {to_condition (sum.inl a, quiver.path.nil)},
      supports := λ π, by simp only [mem_singleton_iff, has_smul.comp.smul,
        mul_equiv.coe_to_monoid_hom, struct_perm.coe_to_bot_iso, equiv.to_fun_as_coe,
        forall_eq, struct_perm.smul_to_condition, struct_perm.derivative_nil,
        struct_perm.to_bot_smul, sum.smul_inl, embedding_like.apply_eq_iff_eq, prod.mk.inj_iff,
        eq_self_iff_true, and_true, imp_self],
      small := small_singleton _ } }

/-- The tangle data at the bottom level. -/
instance bot.positioned_tangle_data : positioned_tangle_data ⊥ := ⟨nonempty.some mk_atom.le⟩

variables (α : Λ)

/-- The core tangle data below phase `α`. -/
class core_tangle_cumul (α : Λ) := (data : Π β : Iio α, core_tangle_data β)

section core_tangle_cumul
variables [core_tangle_cumul α]

instance core_tangle_cumul.to_core_tangle_data : Π β : Iio_index α, core_tangle_data β
| ⟨⊥, h⟩ := bot.core_tangle_data
| ⟨(β : Λ), hβ⟩ := core_tangle_cumul.data ⟨β, coe_lt_coe.1 hβ⟩

instance core_tangle_cumul.to_core_tangle_data' (β : Iio α) : core_tangle_data β :=
show core_tangle_data (Iio_coe β), by apply_instance

end core_tangle_cumul

/-- The positioned tangle data below phase `α`. -/
class positioned_tangle_cumul (α : Λ) [core_tangle_cumul α] :=
(data : Π β : Iio α, positioned_tangle_data β)

section positioned_tangle_cumul
variables [core_tangle_cumul α] [positioned_tangle_cumul α]

instance positioned_tangle_cumul.to_positioned_tangle_data :
  Π β : Iio_index α, positioned_tangle_data β
| ⟨⊥, h⟩ := bot.positioned_tangle_data
| ⟨(β : Λ), hβ⟩ := positioned_tangle_cumul.data ⟨β, coe_lt_coe.1 hβ⟩

instance positioned_tangle_cumul.to_positioned_tangle_data' (β : Iio α) :
  positioned_tangle_data β :=
show positioned_tangle_data (Iio_coe β), by apply_instance

end positioned_tangle_cumul

/-- The almost tangle data below phase `α`. -/
abbreviation almost_tangle_cumul (α : Λ) [core_tangle_cumul α] := Π β : Iio α, almost_tangle_data β

/-- The tangle data below phase `α`. -/
abbreviation tangle_cumul (α : Λ) [core_tangle_cumul α] [positioned_tangle_cumul α]
  [position_data.{}] [almost_tangle_cumul α] := Π β : Iio α, tangle_data β

end con_nf


prelude
import init.core init.system.io init.data.ordering

universe u v w

inductive Rbcolor
| red | black

inductive Rbnode (α : Type u) (β : α → Type v)
| leaf  {}                                                                        : Rbnode
| Node  (c : Rbcolor) (lchild : Rbnode) (key : α) (val : β key) (rchild : Rbnode) : Rbnode

instance Rbcolor.DecidableEq : DecidableEq Rbcolor :=
{decEq := fun a b => Rbcolor.casesOn a
  (Rbcolor.casesOn b (isTrue rfl) (isFalse (fun h => Rbcolor.noConfusion h)))
  (Rbcolor.casesOn b (isFalse (fun h => Rbcolor.noConfusion h)) (isTrue rfl))}

namespace Rbnode
variable {α : Type u} {β : α → Type v} {σ : Type w}

open Rbcolor

def depth (f : Nat → Nat → Nat) : Rbnode α β → Nat
| leaf               => 0
| Node _ l _ _ r     => (f (depth l) (depth r)) + 1

protected def min : Rbnode α β → Option (Sigma (fun k => β k))
| leaf                  => none
| Node _ leaf k v _     => some ⟨k, v⟩
| Node _ l k v _        => min l

protected def max : Rbnode α β → Option (Sigma (fun k => β k))
| leaf                  => none
| Node _ _ k v leaf     => some ⟨k, v⟩
| Node _ _ k v r        => max r

@[specialize] def fold (f : ∀ (k : α), β k → σ → σ) : Rbnode α β → σ → σ
| leaf, b               => b
| Node _ l k v r,     b => fold r (f k v (fold l b))

@[specialize] def revFold (f : ∀ (k : α), β k → σ → σ) : Rbnode α β → σ → σ
| leaf, b               => b
| Node _ l k v r,     b => revFold l (f k v (revFold r b))

@[specialize] def all (p : ∀ (k : α), β k → Bool) : Rbnode α β → Bool
| leaf                 => true
| Node _ l k v r       => p k v && all l && all r

@[specialize] def any (p : ∀ (k : α), β k → Bool) : Rbnode α β → Bool
| leaf               => false
| Node _ l k v r     => p k v || any l || any r

def isRed : Rbnode α β → Bool
| Node red _ _ _ _   => true
| _                  => false

def rotateLeft : ∀ (n : Rbnode α β), n ≠ leaf → Rbnode α β
| n@(Node hc hl hk hv (Node red xl xk xv xr)), _ =>
  if !isRed hl
  then (Node hc (Node red hl hk hv xl) xk xv xr)
  else n
| leaf, h => absurd rfl h
| e, _    => e

theorem ifNodeNodeNeLeaf {c : Prop} [Decidable c] {l1 l2 : Rbnode α β} {c1 k1 v1 r1 c2 k2 v2 r2} : (if c then Node c1 l1 k1 v1 r1 else Node c2 l2 k2 v2 r2) ≠ leaf :=
fun h => if hc : c
then have h1 : (if c then Node c1 l1 k1 v1 r1 else Node c2 l2 k2 v2 r2) = Node c1 l1 k1 v1 r1 from ifPos hc;
     Rbnode.noConfusion (Eq.trans h1.symm h)
else have h1 : (if c then Node c1 l1 k1 v1 r1 else Node c2 l2 k2 v2 r2) = Node c2 l2 k2 v2 r2 from ifNeg hc;
     Rbnode.noConfusion (Eq.trans h1.symm h)

theorem rotateLeftNeLeaf : ∀ (n : Rbnode α β) (h : n ≠ leaf), rotateLeft n h ≠ leaf
| Node _ hl _ _ (Node red _ _ _ _),   _, h  => ifNodeNodeNeLeaf h
| leaf, h, _                                => absurd rfl h
| Node _ _ _ _ (Node black _ _ _ _),   _, h => Rbnode.noConfusion h

def rotateRight : ∀ (n : Rbnode α β), n ≠ leaf → Rbnode α β
| n@(Node hc (Node red xl xk xv xr) hk hv hr), _ =>
  if isRed xl
  then (Node hc xl xk xv (Node red xr hk hv hr))
  else n
| leaf, h => absurd rfl h
| e, _    => e

theorem rotateRightNeLeaf : ∀ (n : Rbnode α β) (h : n ≠ leaf), rotateRight n h ≠ leaf
| Node _ (Node red _ _ _ _) _ _ _,   _, h   => ifNodeNodeNeLeaf h
| leaf, h, _                                => absurd rfl h
| Node _ (Node black _ _ _ _) _ _ _,   _, h => Rbnode.noConfusion h

def flip : Rbcolor → Rbcolor
| red   => black
| black => red

def flipColor : Rbnode α β → Rbnode α β
| Node c l k v r   => Node (flip c) l k v r
| leaf             => leaf

def flipColors : ∀ (n : Rbnode α β), n ≠ leaf → Rbnode α β
| n@(Node c l k v r), _ =>
  if isRed l ∧ isRed r
  then Node (flip c) (flipColor l) k v (flipColor r)
  else n
| leaf, h => absurd rfl h

def fixup (n : Rbnode α β) (h : n ≠ leaf) : Rbnode α β :=
let n₁ := rotateLeft n h;
let h₁ := (rotateLeftNeLeaf n h);
let n₂ := rotateRight n₁ h₁;
let h₂ := (rotateRightNeLeaf n₁ h₁);
flipColors n₂ h₂

def setBlack : Rbnode α β → Rbnode α β
| Node red l k v r   => Node black l k v r
| n                  => n

section insert
variable (lt : α → α → Prop) [DecidableRel lt]

def ins (x : α) (vx : β x) : Rbnode α β → Rbnode α β
| leaf             => Node red leaf x vx leaf
| Node c l k v r   =>
  if lt x k then fixup (Node c (ins l) k v r) (fun h => Rbnode.noConfusion h)
  else if lt k x then fixup (Node c l k v (ins r)) (fun h => Rbnode.noConfusion h)
  else Node c l x vx r

def insert (t : Rbnode α β) (k : α) (v : β k) : Rbnode α β :=
setBlack (ins lt k v t)

end insert

section membership
variable (lt : α → α → Prop)

variable [DecidableRel lt]

def findCore : Rbnode α β → ∀ (k : α), Option (Sigma (fun k => β k))
| leaf,                 x => none
| Node _ a ky vy b,   x =>
  (match cmpUsing lt x ky with
   | Ordering.lt => findCore a x
   | Ordering.Eq => some ⟨ky, vy⟩
   | Ordering.gt => findCore b x)

def find {β : Type v} : Rbnode α (fun _ => β) → α → Option β
| leaf,                 x => none
| Node _ a ky vy b,   x =>
  (match cmpUsing lt x ky with
   | Ordering.lt => find a x
   | Ordering.Eq => some vy
   | Ordering.gt => find b x)

def lowerBound : Rbnode α β → α → Option (Sigma β) → Option (Sigma β)
| leaf,                 x, lb => lb
| Node _ a ky vy b,   x, lb =>
  (match cmpUsing lt x ky with
   | Ordering.lt => lowerBound a x lb
   | Ordering.Eq => some ⟨ky, vy⟩
   | Ordering.gt => lowerBound b x (some ⟨ky, vy⟩))

end membership

inductive WellFormed (lt : α → α → Prop) : Rbnode α β → Prop
| leafWff : WellFormed leaf
| insertWff {n n' : Rbnode α β} {k : α} {v : β k} [DecidableRel lt] : WellFormed n → n' = insert lt n k v → WellFormed n'

end Rbnode

open Rbnode

/- TODO(Leo): define dRbmap -/

def Rbmap (α : Type u) (β : Type v) (lt : α → α → Prop) : Type (max u v) :=
{t : Rbnode α (fun _ => β) // t.WellFormed lt }

@[inline] def mkRbmap (α : Type u) (β : Type v) (lt : α → α → Prop) : Rbmap α β lt :=
⟨leaf, WellFormed.leafWff lt⟩

namespace Rbmap
variable {α : Type u} {β : Type v} {σ : Type w} {lt : α → α → Prop}

def depth (f : Nat → Nat → Nat) (t : Rbmap α β lt) : Nat :=
t.val.depth f

@[inline] def fold (f : α → β → σ → σ) : Rbmap α β lt → σ → σ
| ⟨t, _⟩, b => t.fold f b

@[inline] def revFold (f : α → β → σ → σ) : Rbmap α β lt → σ → σ
| ⟨t, _⟩, b => t.revFold f b

@[inline] def empty : Rbmap α β lt → Bool
| ⟨leaf, _⟩ => true
| _         => false

@[specialize] def toList : Rbmap α β lt → List (α × β)
| ⟨t, _⟩ => t.revFold (fun k v ps => (k, v)::ps) []

@[inline] protected def min : Rbmap α β lt → Option (α × β)
| ⟨t, _⟩ =>
  match t.min with
  | some ⟨k, v⟩ => some (k, v)
  | none        => none

@[inline] protected def max : Rbmap α β lt → Option (α × β)
| ⟨t, _⟩ =>
  match t.max with
  | some ⟨k, v⟩ => some (k, v)
  | none        => none

instance [Repr α] [Repr β] : Repr (Rbmap α β lt) :=
⟨fun t => "rbmapOf " ++ repr t.toList⟩

variable [DecidableRel lt]

def insert : Rbmap α β lt → α → β → Rbmap α β lt
| ⟨t, w⟩,   k, v => ⟨t.insert lt k v, WellFormed.insertWff w rfl⟩

@[specialize] def ofList : List (α × β) → Rbmap α β lt
| []          => mkRbmap _ _ _
| ⟨k,v⟩::xs   => (ofList xs).insert k v

def findCore : Rbmap α β lt → α → Option (Sigma (fun (k : α) => β))
| ⟨t, _⟩, x => t.findCore lt x

def find : Rbmap α β lt → α → Option β
| ⟨t, _⟩, x => t.find lt x

/-- (lowerBound k) retrieves the kv pair of the largest key smaller than or equal to `k`,
    if it exists. -/
def lowerBound : Rbmap α β lt → α → Option (Sigma (fun (k : α) => β))
| ⟨t, _⟩, x => t.lowerBound lt x none

@[inline] def contains (t : Rbmap α β lt) (a : α) : Bool :=
(t.find a).isSome

def fromList (l : List (α × β)) (lt : α → α → Prop) [DecidableRel lt] : Rbmap α β lt :=
l.foldl (fun r p => r.insert p.1 p.2) (mkRbmap α β lt)

@[inline] def all : Rbmap α β lt → (α → β → Bool) → Bool
| ⟨t, _⟩, p => t.all p

@[inline] def any : Rbmap α β lt → (α → β → Bool) → Bool
| ⟨t, _⟩, p => t.any p

end Rbmap

def rbmapOf {α : Type u} {β : Type v} (l : List (α × β)) (lt : α → α → Prop) [DecidableRel lt] : Rbmap α β lt :=
Rbmap.fromList l lt

/- Test -/

@[reducible] def map : Type := Rbmap Nat Bool Less.Less

def mkMapAux : Nat → map → map
| 0, m => m
| n+1,   m => mkMapAux n (m.insert n (n % 10 = 0))

def mkMap (n : Nat) :=
mkMapAux n (mkRbmap Nat Bool Less.Less)

def main (xs : List String) : IO UInt32 :=
let m := mkMap xs.head.toNat;
let v := Rbmap.fold (fun (k : Nat) (v : Bool) (r : Nat) => if v then r + 1 else r) m 0;
IO.println (toString v) *>
pure 0


/-
Copyright (c) 2021 Adam Topaz. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Adam Topaz
-/
import category_theory.sites.whiskering
import category_theory.sites.plus

/-!

In this file, we prove that the plus functor is compatible with functors which
preserve the correct limits and colimits.

See `category_theory/sites/compatible_sheafification` for the compatibility
of sheafification, which follows easily from the content in this file.

-/

namespace category_theory.grothendieck_topology

open category_theory
open category_theory.limits
open opposite

universes w₁ w₂ v u
variables {C : Type u} [category.{v} C] (J : grothendieck_topology C)
variables {D : Type w₁} [category.{max v u} D]
variables {E : Type w₂} [category.{max v u} E]
variables (F : D ⥤ E)

noncomputable theory

variables [∀ (α β : Type (max v u)) (fst snd : β → α),
  has_limits_of_shape (walking_multicospan fst snd) D]
variables [∀ (α β : Type (max v u)) (fst snd : β → α),
  has_limits_of_shape (walking_multicospan fst snd) E]
variables [∀ (X : C) (W : J.cover X) (P : Cᵒᵖ ⥤ D), preserves_limit (W.index P).multicospan F]

variables (P : Cᵒᵖ ⥤ D)

/-- The diagram used to define `P⁺`, composed with `F`, is isomorphic
to the diagram used to define `P ⋙ F`. -/
def diagram_comp_iso (X : C) : J.diagram P X ⋙ F ≅ J.diagram (P ⋙ F) X :=
nat_iso.of_components
(λ W, begin
  refine _ ≪≫ has_limit.iso_of_nat_iso (W.unop.multicospan_comp _ _).symm,
  refine (is_limit_of_preserves F (limit.is_limit _)).cone_point_unique_up_to_iso
    (limit.is_limit _)
end) begin
  intros A B f,
  ext,
  dsimp,
  simp only [functor.map_cone_π_app, multiequalizer.multifork_π_app_left,
    iso.symm_hom, multiequalizer.lift_ι, eq_to_hom_refl, category.comp_id,
    limit.cone_point_unique_up_to_iso_hom_comp,
    grothendieck_topology.cover.multicospan_comp_hom_inv_left,
    has_limit.iso_of_nat_iso_hom_π, category.assoc],
  simp only [← F.map_comp, multiequalizer.lift_ι],
end

@[simp, reassoc]
lemma diagram_comp_iso_hom_ι (X : C) (W : (J.cover X)ᵒᵖ) (i : W.unop.arrow):
  (J.diagram_comp_iso F P X).hom.app W ≫ multiequalizer.ι _ i =
  F.map (multiequalizer.ι _ _) :=
begin
  delta diagram_comp_iso,
  dsimp,
  simp,
end

variables [∀ (X : C), has_colimits_of_shape (J.cover X)ᵒᵖ D]
variables [∀ (X : C), has_colimits_of_shape (J.cover X)ᵒᵖ E]
variables [∀ (X : C), preserves_colimits_of_shape (J.cover X)ᵒᵖ F]

/-- The isomorphism between `P⁺ ⋙ F` and `(P ⋙ F)⁺`. -/
def plus_comp_iso : J.plus_obj P ⋙ F ≅ J.plus_obj (P ⋙ F) :=
nat_iso.of_components
(λ X, begin
  refine _ ≪≫ has_colimit.iso_of_nat_iso (J.diagram_comp_iso F P X.unop),
  refine (is_colimit_of_preserves F (colimit.is_colimit
    (J.diagram P (unop X)))).cocone_point_unique_up_to_iso (colimit.is_colimit _)
end) begin
  intros X Y f,
  apply (is_colimit_of_preserves F (colimit.is_colimit (J.diagram P X.unop))).hom_ext,
  intros W,
  dsimp [plus_obj, plus_map],
  simp only [functor.map_comp, category.assoc],
  slice_rhs 1 2
  { erw (is_colimit_of_preserves F (colimit.is_colimit (J.diagram P X.unop))).fac },
  slice_lhs 1 3
  { simp only [← F.map_comp],
    dsimp [colim_map, is_colimit.map, colimit.pre],
    simp only [colimit.ι_desc_assoc, colimit.ι_desc],
    dsimp [cocones.precompose],
    rw [category.assoc, colimit.ι_desc],
    dsimp [cocone.whisker],
    rw F.map_comp },
  simp only [category.assoc],
  slice_lhs 2 3
  { erw (is_colimit_of_preserves F (colimit.is_colimit (J.diagram P Y.unop))).fac },
  dsimp,
  simp only [has_colimit.iso_of_nat_iso_ι_hom_assoc,
    grothendieck_topology.diagram_pullback_app, colimit.ι_pre,
    has_colimit.iso_of_nat_iso_ι_hom, ι_colim_map_assoc],
  simp only [← category.assoc],
  congr' 1,
  ext,
  dsimp,
  simp only [category.assoc],
  erw [multiequalizer.lift_ι, diagram_comp_iso_hom_ι, diagram_comp_iso_hom_ι,
    ← F.map_comp, multiequalizer.lift_ι],
end

@[simp, reassoc]
lemma ι_plus_comp_iso_hom (X) (W) : F.map (colimit.ι _ W) ≫ (J.plus_comp_iso F P).hom.app X =
  (J.diagram_comp_iso F P X.unop).hom.app W ≫ colimit.ι _ W :=
begin
  delta diagram_comp_iso plus_comp_iso,
  simp only [is_colimit.desc_cocone_morphism_hom, is_colimit.unique_up_to_iso_hom,
    cocones.forget_map, iso.trans_hom, nat_iso.of_components_hom_app, functor.map_iso_hom,
    ← category.assoc],
  erw (is_colimit_of_preserves F (colimit.is_colimit (J.diagram P (unop X)))).fac,
  simp only [category.assoc, has_limit.iso_of_nat_iso_hom_π, iso.symm_hom,
    cover.multicospan_comp_hom_inv_left, eq_to_hom_refl, category.comp_id,
    limit.cone_point_unique_up_to_iso_hom_comp, functor.map_cone_π_app,
    multiequalizer.multifork_π_app_left, multiequalizer.lift_ι, functor.map_comp, eq_self_iff_true,
    category.assoc, iso.trans_hom, iso.cancel_iso_hom_left, nat_iso.of_components_hom_app,
    colimit.cocone_ι, category.assoc, has_colimit.iso_of_nat_iso_ι_hom],

end

@[simp, reassoc]
lemma plus_comp_iso_whisker_left {F G : D ⥤ E} (η : F ⟶ G) (P : Cᵒᵖ ⥤ D)
  [∀ (X : C), preserves_colimits_of_shape (J.cover X)ᵒᵖ F]
  [∀ (X : C) (W : J.cover X) (P : Cᵒᵖ ⥤ D), preserves_limit (W.index P).multicospan F]
  [∀ (X : C), preserves_colimits_of_shape (J.cover X)ᵒᵖ G]
  [∀ (X : C) (W : J.cover X) (P : Cᵒᵖ ⥤ D), preserves_limit (W.index P).multicospan G] :
  whisker_left _ η ≫ (J.plus_comp_iso G P).hom =
  (J.plus_comp_iso F P).hom ≫ J.plus_map (whisker_left _ η) :=
begin
  ext X,
  apply (is_colimit_of_preserves F (colimit.is_colimit (J.diagram P X.unop))).hom_ext,
  intros W,
  dsimp [plus_obj, plus_map],
  simp only [ι_plus_comp_iso_hom, ι_colim_map, whisker_left_app, ι_plus_comp_iso_hom_assoc,
    nat_trans.naturality_assoc, grothendieck_topology.diagram_nat_trans_app],
  simp only [← category.assoc],
  congr' 1,
  ext,
  dsimp,
  simpa,
end

/-- The isomorphism between `P⁺ ⋙ F` and `(P ⋙ F)⁺`, functorially in `F`. -/
@[simps hom_app inv_app]
def plus_functor_whisker_left_iso (P : Cᵒᵖ ⥤ D)
  [∀ (F : D ⥤ E) (X : C), preserves_colimits_of_shape (J.cover X)ᵒᵖ F]
  [∀ (F : D ⥤ E) (X : C) (W : J.cover X) (P : Cᵒᵖ ⥤ D),
    preserves_limit (W.index P).multicospan F] :
  (whiskering_left _ _ E).obj (J.plus_obj P) ≅
  (whiskering_left _ _ _).obj P ⋙ J.plus_functor E :=
nat_iso.of_components
(λ X, plus_comp_iso _ _ _) $ λ F G η, plus_comp_iso_whisker_left _ _ _

@[simp, reassoc]
lemma plus_comp_iso_whisker_right {P Q : Cᵒᵖ ⥤ D} (η : P ⟶ Q) :
  whisker_right (J.plus_map η) F ≫ (J.plus_comp_iso F Q).hom =
  (J.plus_comp_iso F P).hom ≫ J.plus_map (whisker_right η F) :=
begin
  ext X,
  apply (is_colimit_of_preserves F (colimit.is_colimit (J.diagram P X.unop))).hom_ext,
  intros W,
  dsimp [plus_obj, plus_map],
  simp only [ι_colim_map, whisker_right_app, ι_plus_comp_iso_hom_assoc,
    grothendieck_topology.diagram_nat_trans_app],
  simp only [← category.assoc, ← F.map_comp],
  dsimp [colim_map, is_colimit.map],
  simp only [colimit.ι_desc],
  dsimp [cocones.precompose],
  simp only [functor.map_comp, category.assoc, ι_plus_comp_iso_hom],
  simp only [← category.assoc],
  congr' 1,
  ext,
  dsimp,
  simp only [diagram_comp_iso_hom_ι_assoc, multiequalizer.lift_ι,
    diagram_comp_iso_hom_ι, category.assoc],
  simp only [← F.map_comp, multiequalizer.lift_ι],
end

/-- The isomorphism between `P⁺ ⋙ F` and `(P ⋙ F)⁺`, functorially in `P`. -/
@[simps hom_app inv_app]
def plus_functor_whisker_right_iso : J.plus_functor D ⋙ (whiskering_right _ _ _).obj F ≅
  (whiskering_right _ _ _).obj F ⋙ J.plus_functor E :=
nat_iso.of_components (λ P, J.plus_comp_iso _ _) $ λ P Q η, plus_comp_iso_whisker_right _ _ _

@[simp, reassoc]
lemma whisker_right_to_plus_comp_plus_comp_iso_hom :
  whisker_right (J.to_plus _) _ ≫ (J.plus_comp_iso F P).hom = J.to_plus _ :=
begin
  ext,
  dsimp [to_plus],
  simp only [ι_plus_comp_iso_hom, functor.map_comp, category.assoc],
  simp only [← category.assoc],
  congr' 1,
  ext,
  delta cover.to_multiequalizer,
  simp only [diagram_comp_iso_hom_ι, category.assoc, ← F.map_comp],
  erw [multiequalizer.lift_ι, multiequalizer.lift_ι],
  refl,
end

@[simp]
lemma to_plus_comp_plus_comp_iso_inv : J.to_plus _ ≫ (J.plus_comp_iso F P).inv =
  whisker_right (J.to_plus _) _ :=
by simp [iso.comp_inv_eq]

lemma plus_comp_iso_inv_eq_plus_lift (hP : presheaf.is_sheaf J ((J.plus_obj P) ⋙ F)) :
  (J.plus_comp_iso F P).inv = J.plus_lift (whisker_right (J.to_plus _) _) hP :=
by { apply J.plus_lift_unique, simp [iso.comp_inv_eq] }

end category_theory.grothendieck_topology


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

Tactics based on the strongly connected components (SCC) of a graph where
the vertices are propositions and the edges are implications found
in the context.

They are used for finding the sets of equivalent propositions in a set
of implications.
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.tactic.tauto
import Mathlib.data.sum
import Mathlib.PostPort

namespace Mathlib

/-!
# Strongly Connected Components

This file defines tactics to construct proofs of equivalences between a set of mutually equivalent
propositions. The tactics use implications transitively to find sets of equivalent propositions.

## Implementation notes

The tactics use a strongly connected components algorithm on a graph where propositions are
vertices and edges are proofs that the source implies the target. The strongly connected components
are therefore sets of propositions that are pairwise equivalent to each other.

The resulting strongly connected components are encoded in a disjoint set data structure to
facilitate the construction of equivalence proofs between two arbitrary members of an equivalence
class.

## Possible generalizations

Instead of reasoning about implications and equivalence, we could generalize the machinery to
reason about arbitrary partial orders.

## References

 * Tarjan, R. E. (1972), "Depth-first search and linear graph algorithms",
   SIAM Journal on Computing, 1 (2): 146–160, doi:10.1137/0201010
 * Dijkstra, Edsger (1976), A Discipline of Programming, NJ: Prentice Hall, Ch. 25.
 * <https://en.wikipedia.org/wiki/Disjoint-set_data_structure>

## Tags

graphs, tactic, strongly connected components, disjoint sets
-/

namespace tactic

/--
`closure` implements a disjoint set data structure using path compression
optimization. For the sake of the scc algorithm, it also stores the preorder
numbering of the equivalence graph of the local assumptions.

The `expr_map` encodes a directed forest by storing for every non-root
node, a reference to its parent and a proof of equivalence between
that node's expression and its parent's expression. Given that data
structure, checking that two nodes belong to the same tree is easy and
fast by repeatedly following the parent references until a root is reached.
If both nodes have the same root, they belong to the same tree, i.e. their
expressions are equivalent. The proof of equivalence can be formed by
composing the proofs along the edges of the paths to the root.

More concretely, if we ignore preorder numbering, the set
`{ {e₀,e₁,e₂,e₃}, {e₄,e₅} }` is represented as:

```
e₀ → ⊥      -- no parent, i.e. e₀ is a root
e₁ → e₀, p₁ -- with p₁ : e₁ ↔ e₀
e₂ → e₁, p₂ -- with p₂ : e₂ ↔ e₁
e₃ → e₀, p₃ -- with p₃ : e₃ ↔ e₀
e₄ → ⊥      -- no parent, i.e. e₄ is a root
e₅ → e₄, p₅ -- with p₅ : e₅ ↔ e₄
```

We can check that `e₂` and `e₃` are equivalent by seeking the root of
the tree of each. The parent of `e₂` is `e₁`, the parent of `e₁` is
`e₀` and `e₀` does not have a parent, and thus, this is the root of its tree.
The parent of `e₃` is `e₀` and it's also the root, the same as for `e₂` and
they are therefore equivalent. We can build a proof of that equivalence by using
transitivity on `p₂`, `p₁` and `p₃.symm` in that order.

Similarly, we can discover that `e₂` and `e₅` aren't equivalent.

A description of the path compression optimization can be found at:
<https://en.wikipedia.org/wiki/Disjoint-set_data_structure#Path_compression>

-/
namespace closure

/-- `with_new_closure f` creates an empty `closure` `c`, executes `f` on `c`, and then deletes `c`,
returning the output of `f`. -/
/-- `to_tactic_format cl` pretty-prints the `closure` `cl` as a list. Assuming `cl` was built by
`dfs_at`, each element corresponds to a node `pᵢ : expr` and is one of the folllowing:
- if `pᵢ` is a root: `"pᵢ ⇐ i"`, where `i` is the preorder number of `pᵢ`,
- otherwise: `"(pᵢ, pⱼ) : P"`, where `P` is `pᵢ ↔ pⱼ`.
Useful for debugging. -/
/-- `(n,r,p) ← root cl e` returns `r` the root of the tree that `e` is a part of (which might be
itself) along with `p` a proof of `e ↔ r` and `n`, the preorder numbering of the root. -/
/-- (Implementation of `merge`.) -/
/-- `merge cl p`, with `p` a proof of `e₀ ↔ e₁` for some `e₀` and `e₁`,
merges the trees of `e₀` and `e₁` and keeps the root with the smallest preorder
number as the root. This ensures that, in the depth-first traversal of the graph,
when encountering an edge going into a vertex whose equivalence class includes
a vertex that originated the current search, that vertex will be the root of
the corresponding tree. -/
/-- Sequentially assign numbers to the nodes of the graph as they are being visited. -/
/-- `prove_eqv cl e₀ e₁` constructs a proof of equivalence of `e₀` and `e₁` if
they are equivalent. -/
/-- `prove_impl cl e₀ e₁` constructs a proof of `e₀ -> e₁` if they are equivalent. -/
/-- `is_eqv cl e₀ e₁` checks whether `e₀` and `e₁` are equivalent without building a proof. -/
end closure

/-- mutable graphs between local propositions that imply each other with the proof of implication -/
/-- `with_impl_graph f` creates an empty `impl_graph` `g`, executes `f` on `g`, and then deletes
`g`, returning the output of `f`. -/
namespace impl_graph

/-- `add_edge g p`, with `p` a proof of `v₀ → v₁` or `v₀ ↔ v₁`, adds an edge to the implication
graph `g`. -/
/-- `merge_path path e`, where `path` and `e` forms a cycle with proofs of implication between
consecutive vertices. The proofs are compiled into proofs of equivalences and added to the closure
structure. `e` and the first vertex of `path` do not have to be the same but they have to be
in the same equivalence class. -/
/-- (implementation of `collapse`) -/
/-- `collapse path v`, where `v` is a vertex that originated the current search
(or a vertex in the same equivalence class as the one that originated the current search).
It or its equivalent should be found in `path`. Since the vertices following `v` in the path
form a cycle with `v`, they can all be added to an equivalence class. -/
/--
Strongly connected component algorithm inspired by Tarjan's and
Dijkstra's scc algorithm. Whereas they return strongly connected
components by enumerating them, this algorithm returns a disjoint set
data structure using path compression. This is a compact
representation that allows us, after the fact, to construct a proof of
equivalence between any two members of an equivalence class.

 * Tarjan, R. E. (1972), "Depth-first search and linear graph algorithms",
   SIAM Journal on Computing, 1 (2): 146–160, doi:10.1137/0201010
 * Dijkstra, Edsger (1976), A Discipline of Programming, NJ: Prentice Hall, Ch. 25.
-/
/-- Use the local assumptions to create a set of equivalence classes. -/
end impl_graph

/--
`scc` uses the available equivalences and implications to prove
a goal of the form `p ↔ q`.

```lean
example (p q r : Prop) (hpq : p → q) (hqr : q ↔ r) (hrp : r → p) : p ↔ r :=
by scc
```
-/
/-- Collect all the available equivalences and implications and
add assumptions for every equivalence that can be proven using the
strongly connected components technique. Mostly useful for testing. -/
/--
`scc` uses the available equivalences and implications to prove


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

! This file was ported from Lean 3 source module algebra.group_with_zero.inj_surj
! leanprover-community/mathlib commit a148d797a1094ab554ad4183a4ad6f130358ef64
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathlib.Algebra.Group.InjSurj
import Mathlib.Algebra.GroupWithZero.Defs

/-!
# Lifting groups with zero along injective/surjective maps

-/

open Function

variable {M₀ G₀ M₀' G₀' : Type _}

section MulZeroClass

variable [MulZeroClass M₀] {a b : M₀}

/-- Pullback a `MulZeroClass` instance along an injective function.
See note [reducible non-instances]. -/
@[reducible]
protected def Function.Injective.mulZeroClass [Mul M₀'] [Zero M₀'] (f : M₀' → M₀) (hf : Injective f)
    (zero : f 0 = 0) (mul : ∀ a b, f (a * b) = f a * f b) : MulZeroClass M₀' where
  mul := (· * ·)
  zero := 0
  zero_mul a := hf <| by simp only [mul, zero, zero_mul]
  mul_zero a := hf <| by simp only [mul, zero, mul_zero]
#align function.injective.mul_zero_class Function.Injective.mulZeroClass

/-- Pushforward a `MulZeroClass` instance along an surjective function.
See note [reducible non-instances]. -/
@[reducible]
protected def Function.Surjective.mulZeroClass [Mul M₀'] [Zero M₀'] (f : M₀ → M₀')
    (hf : Surjective f) (zero : f 0 = 0) (mul : ∀ a b, f (a * b) = f a * f b) :
    MulZeroClass M₀' where
  mul := (· * ·)
  zero := 0
  mul_zero := hf.forall.2 fun x => by simp only [← zero, ← mul, mul_zero]
  zero_mul := hf.forall.2 fun x => by simp only [← zero, ← mul, zero_mul]
#align function.surjective.mul_zero_class Function.Surjective.mulZeroClass

end MulZeroClass

section NoZeroDivisors

/-- Pushforward a `NoZeroDivisors` instance along an injective function. -/
protected theorem Function.Injective.noZeroDivisors [Mul M₀] [Zero M₀] [Mul M₀'] [Zero M₀']
    [NoZeroDivisors M₀'] (f : M₀ → M₀') (hf : Injective f) (zero : f 0 = 0)
    (mul : ∀ x y, f (x * y) = f x * f y) : NoZeroDivisors M₀ :=
  { eq_zero_or_eq_zero_of_mul_eq_zero := fun H =>
      have : f _ * f _ = 0 := by rw [← mul, H, zero]
      (eq_zero_or_eq_zero_of_mul_eq_zero this).imp
        (fun H => hf <| by rwa [zero]) fun H => hf <| by rwa [zero] }
#align function.injective.no_zero_divisors Function.Injective.noZeroDivisors

end NoZeroDivisors

section MulZeroOneClass

variable [MulZeroOneClass M₀]

/-- Pullback a `MulZeroOneClass` instance along an injective function.
See note [reducible non-instances]. -/
@[reducible]
protected def Function.Injective.mulZeroOneClass [Mul M₀'] [Zero M₀'] [One M₀'] (f : M₀' → M₀)
    (hf : Injective f) (zero : f 0 = 0) (one : f 1 = 1) (mul : ∀ a b, f (a * b) = f a * f b) :
    MulZeroOneClass M₀' :=
  { hf.mulZeroClass f zero mul, hf.mulOneClass f one mul with }
#align function.injective.mul_zero_one_class Function.Injective.mulZeroOneClass

/-- Pushforward a `MulZeroOneClass` instance along an surjective function.
See note [reducible non-instances]. -/
@[reducible]
protected def Function.Surjective.mulZeroOneClass [Mul M₀'] [Zero M₀'] [One M₀'] (f : M₀ → M₀')
    (hf : Surjective f) (zero : f 0 = 0) (one : f 1 = 1) (mul : ∀ a b, f (a * b) = f a * f b) :
    MulZeroOneClass M₀' :=
  { hf.mulZeroClass f zero mul, hf.mulOneClass f one mul with }
#align function.surjective.mul_zero_one_class Function.Surjective.mulZeroOneClass

end MulZeroOneClass

section SemigroupWithZero

/-- Pullback a `SemigroupWithZero` along an injective function.
See note [reducible non-instances]. -/
@[reducible]
protected def Function.Injective.semigroupWithZero [Zero M₀'] [Mul M₀'] [SemigroupWithZero M₀]
    (f : M₀' → M₀) (hf : Injective f) (zero : f 0 = 0) (mul : ∀ x y, f (x * y) = f x * f y) :
    SemigroupWithZero M₀' :=
  { hf.mulZeroClass f zero mul, ‹Zero M₀'›, hf.semigroup f mul with }
#align function.injective.semigroup_with_zero Function.Injective.semigroupWithZero

/-- Pushforward a `SemigroupWithZero` along an surjective function.
See note [reducible non-instances]. -/
@[reducible]
protected def Function.Surjective.semigroupWithZero [SemigroupWithZero M₀] [Zero M₀'] [Mul M₀']
    (f : M₀ → M₀') (hf : Surjective f) (zero : f 0 = 0) (mul : ∀ x y, f (x * y) = f x * f y) :
    SemigroupWithZero M₀' :=
  { hf.mulZeroClass f zero mul, ‹Zero M₀'›, hf.semigroup f mul with }
#align function.surjective.semigroup_with_zero Function.Surjective.semigroupWithZero

end SemigroupWithZero

section MonoidWithZero

/-- Pullback a `MonoidWithZero` along an injective function.
See note [reducible non-instances]. -/
@[reducible]
protected def Function.Injective.monoidWithZero [Zero M₀'] [Mul M₀'] [One M₀'] [Pow M₀' ℕ]
    [MonoidWithZero M₀] (f : M₀' → M₀) (hf : Injective f) (zero : f 0 = 0) (one : f 1 = 1)
    (mul : ∀ x y, f (x * y) = f x * f y) (npow : ∀ (x) (n : ℕ), f (x ^ n) = f x ^ n) :
    MonoidWithZero M₀' :=
  { hf.monoid f one mul npow, hf.mulZeroClass f zero mul with }
#align function.injective.monoid_with_zero Function.Injective.monoidWithZero

/-- Pushforward a `MonoidWithZero` along a surjective function.
See note [reducible non-instances]. -/
@[reducible]
protected def Function.Surjective.monoidWithZero [Zero M₀'] [Mul M₀'] [One M₀'] [Pow M₀' ℕ]
    [MonoidWithZero M₀] (f : M₀ → M₀') (hf : Surjective f) (zero : f 0 = 0) (one : f 1 = 1)
    (mul : ∀ x y, f (x * y) = f x * f y) (npow : ∀ (x) (n : ℕ), f (x ^ n) = f x ^ n) :
    MonoidWithZero M₀' :=
  { hf.monoid f one mul npow, hf.mulZeroClass f zero mul with }
#align function.surjective.monoid_with_zero Function.Surjective.monoidWithZero

/-- Pullback a `CommMonoidWithZero` along an injective function.
See note [reducible non-instances]. -/
@[reducible]
protected def Function.Injective.commMonoidWithZero [Zero M₀'] [Mul M₀'] [One M₀'] [Pow M₀' ℕ]
    [CommMonoidWithZero M₀] (f : M₀' → M₀) (hf : Injective f) (zero : f 0 = 0) (one : f 1 = 1)
    (mul : ∀ x y, f (x * y) = f x * f y) (npow : ∀ (x) (n : ℕ), f (x ^ n) = f x ^ n) :
    CommMonoidWithZero M₀' :=
  { hf.commMonoid f one mul npow, hf.mulZeroClass f zero mul with }
#align function.injective.comm_monoid_with_zero Function.Injective.commMonoidWithZero

/-- Pushforward a `CommMonoidWithZero` along a surjective function.
See note [reducible non-instances]. -/
@[reducible]
protected def Function.Surjective.commMonoidWithZero [Zero M₀'] [Mul M₀'] [One M₀'] [Pow M₀' ℕ]
    [CommMonoidWithZero M₀] (f : M₀ → M₀') (hf : Surjective f) (zero : f 0 = 0) (one : f 1 = 1)
    (mul : ∀ x y, f (x * y) = f x * f y) (npow : ∀ (x) (n : ℕ), f (x ^ n) = f x ^ n) :
    CommMonoidWithZero M₀' :=
  { hf.commMonoid f one mul npow, hf.mulZeroClass f zero mul with }
#align function.surjective.comm_monoid_with_zero Function.Surjective.commMonoidWithZero

end MonoidWithZero

section CancelMonoidWithZero

variable [CancelMonoidWithZero M₀] {a b c : M₀}

/-- Pullback a `CancelMonoidWithZero` along an injective function.
See note [reducible non-instances]. -/
@[reducible]
protected def Function.Injective.cancelMonoidWithZero [Zero M₀'] [Mul M₀'] [One M₀'] [Pow M₀' ℕ]
    (f : M₀' → M₀) (hf : Injective f) (zero : f 0 = 0) (one : f 1 = 1)
    (mul : ∀ x y, f (x * y) = f x * f y) (npow : ∀ (x) (n : ℕ), f (x ^ n) = f x ^ n) :
    CancelMonoidWithZero M₀' :=
  { hf.monoid f one mul npow, hf.mulZeroClass f zero mul with
    mul_left_cancel_of_ne_zero := fun hx H =>
      hf <| mul_left_cancel₀ ((hf.ne_iff' zero).2 hx) <| by erw [← mul, ← mul, H],
    mul_right_cancel_of_ne_zero := fun hx H =>
      hf <| mul_right_cancel₀ ((hf.ne_iff' zero).2 hx) <| by erw [← mul, ← mul, H] }
#align function.injective.cancel_monoid_with_zero Function.Injective.cancelMonoidWithZero

end CancelMonoidWithZero

section CancelCommMonoidWithZero

variable [CancelCommMonoidWithZero M₀] {a b c : M₀}

/-- Pullback a `CancelCommMonoidWithZero` along an injective function.
See note [reducible non-instances]. -/
@[reducible]
protected def Function.Injective.cancelCommMonoidWithZero [Zero M₀'] [Mul M₀'] [One M₀'] [Pow M₀' ℕ]
    (f : M₀' → M₀) (hf : Injective f) (zero : f 0 = 0) (one : f 1 = 1)
    (mul : ∀ x y, f (x * y) = f x * f y) (npow : ∀ (x) (n : ℕ), f (x ^ n) = f x ^ n) :
    CancelCommMonoidWithZero M₀' :=
  { hf.commMonoidWithZero f zero one mul npow, hf.cancelMonoidWithZero f zero one mul npow with }
#align function.injective.cancel_comm_monoid_with_zero Function.Injective.cancelCommMonoidWithZero

end CancelCommMonoidWithZero

section GroupWithZero

variable [GroupWithZero G₀] {a b c g h x : G₀}

/-- Pullback a `GroupWithZero` along an injective function.
See note [reducible non-instances]. -/
@[reducible]
protected def Function.Injective.groupWithZero [Zero G₀'] [Mul G₀'] [One G₀'] [Inv G₀'] [Div G₀']
    [Pow G₀' ℕ] [Pow G₀' ℤ] (f : G₀' → G₀) (hf : Injective f) (zero : f 0 = 0) (one : f 1 = 1)
    (mul : ∀ x y, f (x * y) = f x * f y) (inv : ∀ x, f x⁻¹ = (f x)⁻¹)
    (div : ∀ x y, f (x / y) = f x / f y) (npow : ∀ (x) (n : ℕ), f (x ^ n) = f x ^ n)
    (zpow : ∀ (x) (n : ℤ), f (x ^ n) = f x ^ n) : GroupWithZero G₀' :=
  { hf.monoidWithZero f zero one mul npow,
    hf.divInvMonoid f one mul inv div npow zpow,
    pullback_nonzero f zero one with
    inv_zero := hf <| by erw [inv, zero, inv_zero],
    mul_inv_cancel := fun x hx => hf <| by
      erw [one, mul, inv, mul_inv_cancel ((hf.ne_iff' zero).2 hx)] }
#align function.injective.group_with_zero Function.Injective.groupWithZero

/-- Pushforward a `GroupWithZero` along an surjective function.
See note [reducible non-instances]. -/
@[reducible]
protected def Function.Surjective.groupWithZero [Zero G₀'] [Mul G₀'] [One G₀'] [Inv G₀'] [Div G₀']
    [Pow G₀' ℕ] [Pow G₀' ℤ] (h01 : (0 : G₀') ≠ 1) (f : G₀ → G₀') (hf : Surjective f)
    (zero : f 0 = 0) (one : f 1 = 1) (mul : ∀ x y, f (x * y) = f x * f y)
    (inv : ∀ x, f x⁻¹ = (f x)⁻¹) (div : ∀ x y, f (x / y) = f x / f y)
    (npow : ∀ (x) (n : ℕ), f (x ^ n) = f x ^ n) (zpow : ∀ (x) (n : ℤ), f (x ^ n) = f x ^ n) :
    GroupWithZero G₀' :=
  { hf.monoidWithZero f zero one mul npow, hf.divInvMonoid f one mul inv div npow zpow with
    inv_zero := by erw [← zero, ← inv, inv_zero],
    mul_inv_cancel := hf.forall.2 fun x hx => by
        erw [← inv, ← mul, mul_inv_cancel (mt (congr_arg f) <| fun h ↦ hx (h.trans zero)), one]
    exists_pair_ne := ⟨0, 1, h01⟩ }
#align function.surjective.group_with_zero Function.Surjective.groupWithZero

end GroupWithZero

section CommGroupWithZero

variable [CommGroupWithZero G₀] {a b c d : G₀}

/-- Pullback a `CommGroupWithZero` along an injective function.
See note [reducible non-instances]. -/
@[reducible]
protected def Function.Injective.commGroupWithZero [Zero G₀'] [Mul G₀'] [One G₀'] [Inv G₀']
    [Div G₀'] [Pow G₀' ℕ] [Pow G₀' ℤ] (f : G₀' → G₀) (hf : Injective f) (zero : f 0 = 0)
    (one : f 1 = 1) (mul : ∀ x y, f (x * y) = f x * f y) (inv : ∀ x, f x⁻¹ = (f x)⁻¹)
    (div : ∀ x y, f (x / y) = f x / f y) (npow : ∀ (x) (n : ℕ), f (x ^ n) = f x ^ n)
    (zpow : ∀ (x) (n : ℤ), f (x ^ n) = f x ^ n) : CommGroupWithZero G₀' :=
  { hf.groupWithZero f zero one mul inv div npow zpow, hf.commSemigroup f mul with }
#align function.injective.comm_group_with_zero Function.Injective.commGroupWithZero

/-- Pushforward a `CommGroupWithZero` along a surjective function.
See note [reducible non-instances]. -/
protected def Function.Surjective.commGroupWithZero [Zero G₀'] [Mul G₀'] [One G₀'] [Inv G₀']
    [Div G₀'] [Pow G₀' ℕ] [Pow G₀' ℤ] (h01 : (0 : G₀') ≠ 1) (f : G₀ → G₀') (hf : Surjective f)
    (zero : f 0 = 0) (one : f 1 = 1) (mul : ∀ x y, f (x * y) = f x * f y)
    (inv : ∀ x, f x⁻¹ = (f x)⁻¹) (div : ∀ x y, f (x / y) = f x / f y)
    (npow : ∀ (x) (n : ℕ), f (x ^ n) = f x ^ n) (zpow : ∀ (x) (n : ℤ), f (x ^ n) = f x ^ n) :
    CommGroupWithZero G₀' :=
  { hf.groupWithZero h01 f zero one mul inv div npow zpow, hf.commSemigroup f mul with }
#align function.surjective.comm_group_with_zero Function.Surjective.commGroupWithZero

end CommGroupWithZero


/-
Copyright (c) 2019 Paul-Nicolas Madelaine. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Paul-Nicolas Madelaine, Robert Y. Lewis, Mario Carneiro, Gabriel Ebner
-/

import Mathlib.Tactic.NormCast.Ext
import Mathlib.Tactic.OpenPrivate
import Mathlib.Tactic.SudoSetOption
import Mathlib.Util.Simp
import Mathlib.Algebra.Group.Defs

open Lean Meta Simp

namespace Tactic.NormCast

initialize registerTraceClass `Tactic.norm_cast

/-- Prove `a = b` using the given simp set. -/
def proveEqUsing (s : SimpTheorems) (a b : Expr) : MetaM (Option Simp.Result) := do
  let go : SimpM (Option Simp.Result) := do
    let methods := Simp.DefaultMethods.methods
    let a' ← Simp.simp a methods
    let b' ← Simp.simp b methods
    unless ← isDefEq a'.expr b'.expr do return none
    mkEqTrans a' (← mkEqSymm b b')
  withReducible do
    (go { simpTheorems := #[s], congrTheorems := ← Meta.getSimpCongrTheorems }).run' {}

/-- Prove `a = b` by simplifying using move and squash lemmas. -/
def proveEqUsingDown (a b : Expr) : MetaM (Option Simp.Result) := do
  trace[Tactic.norm_cast] "proving: {← mkEq a b}"
  proveEqUsing (← normCastExt.down.getTheorems) a b

def mkCoe (e : Expr) (ty : Expr) : MetaM Expr := do
  let eType ← inferType e
  let u ← getLevel eType
  let v ← getLevel ty
  let coeTInstType := mkAppN (mkConst ``CoeT [u, v]) #[eType, e, ty]
  let inst ← synthInstance coeTInstType
  expandCoe <| mkAppN (mkConst ``CoeT.coe [u, v]) #[eType, e, ty, inst]

def isCoeOf? (e : Expr) : MetaM (Option Expr) := do
  if let Expr.const fn .. := e.getAppFn then
    if let some info ← getCoeFnInfo? fn then
      if e.getAppNumArgs == info.numArgs then
        return e.getArg! info.coercee
  return none

def isNumeral? (e : Expr) : Option (Expr × Nat) :=
  if e.isConstOf ``Nat.zero then
    (mkConst ``Nat, 0)
  else if let Expr.app (Expr.app (Expr.app (Expr.const ``OfNat.ofNat ..) α ..)
      (Expr.lit (Literal.natVal n) ..) ..) .. := e then
    some (α, n)
  else
    none

/--
This is the main heuristic used alongside the elim and move lemmas.
The goal is to help casts move past operators by adding intermediate casts.
An expression of the shape: op (↑(x : α) : γ) (↑(y : β) : γ)
is rewritten to:            op (↑(↑(x : α) : β) : γ) (↑(y : β) : γ)
when (↑(↑(x : α) : β) : γ) = (↑(x : α) : γ) can be proven with a squash lemma
-/
def splittingProcedure (expr : Expr) : MetaM Simp.Result := do
  let Expr.app (Expr.app op x ..) y .. := expr | return {expr}

  let Expr.forallE _ γ (Expr.forallE _ γ' ty ..) .. ← inferType op | return {expr}
  if γ'.hasLooseBVars || ty.hasLooseBVars then return {expr}
  unless ← isDefEq γ γ' do return {expr}

  try
    let some x' ← isCoeOf? x | failure
    let some y' ← isCoeOf? y | failure
    let α ← inferType x'
    let β ← inferType y'

    -- TODO: fast timeout
    (try
      let x2 ← mkCoe (← mkCoe x' β) γ
      let some x_x2 ← proveEqUsingDown x x2 | failure
      Simp.mkCongrFun (← Simp.mkCongr {expr := op} x_x2) y
    catch _ =>
      let y2 ← mkCoe (← mkCoe y' α) γ
      let some y_y2 ← proveEqUsingDown y y2 | failure
      Simp.mkCongr {expr := mkApp op x} y_y2)
  catch _ => try
    let some (β, n) := isNumeral? y | failure
    let some x' ← isCoeOf? x | failure
    let α ← inferType x'
    let y2 ← mkCoe (← mkNumeral α n) γ
    let some y_y2 ← proveEqUsingDown y y2 | failure
    Simp.mkCongr {expr := mkApp op x} y_y2
  catch _ => try
    let some (α, n) := isNumeral? x | failure
    let some y' ← isCoeOf? y | failure
    let β ← inferType y'
    let x2 ← mkCoe (← mkNumeral β n) γ
    let some x_x2 ← proveEqUsingDown x x2 | failure
    Simp.mkCongrFun (← Simp.mkCongr {expr := op} x_x2) y
  catch _ =>
    return {expr}

/--
Discharging function used during simplification in the "squash" step.

TODO: normCast takes a list of expressions to use as lemmas for the discharger
TODO: a tactic to print the results the discharger fails to proove
-/
def prove (e : Expr) : SimpM (Option Expr) := do
  trace[Tactic.norm_cast] "discharging {e}"
  return (← findLocalDeclWithType? e).map mkFVar

/--
Core rewriting function used in the "squash" step, which moves casts upwards
and eliminates them.

It tries to rewrite an expression using the elim and move lemmas.
On failure, it calls the splitting procedure heuristic.
-/
partial def upwardAndElim (up : SimpTheorems) (e : Expr) : SimpM Simp.Step := do
  let r ← Simp.rewrite e up.post up.erased prove (tag := "squash")
  let r ← mkEqTrans r <|<- splittingProcedure r.expr
  if r.expr == e then return Simp.Step.done {expr := e}
  return Simp.Step.visit r

/--
If possible, rewrite `(n : α)` to `(Nat.cast n : α)` where `n` is a numeral and `α ≠ ℕ`.
Returns a pair of the new expression and proof that they are equal.
-/
def numeralToCoe (e : Expr) : MetaM Simp.Result := do
  let some (α, n) := isNumeral? e | failure
  if (← whnf α).isConstOf ``Nat then failure
  let newE ← mkAppOptM ``Nat.cast #[α, none, toExpr n]
  let some pr ← proveEqUsingDown e newE | failure
  return pr

/--
The core simplification routine of `normCast`.
-/
def derive (e : Expr) : MetaM Simp.Result := do
  let e ← instantiateMVars e

  let config : Simp.Config := {
    zeta := false
    beta := false
    eta  := false
    proj := false
    iota := false
  }
  let congrTheorems ← Meta.getSimpCongrTheorems

  let r := {expr := e}

  trace[Tactic.norm_cast] "before: {r.expr}"

  -- step 1: pre-processing of numerals
  let r ← mkEqTrans r <|<- Simp.main r.expr { config, congrTheorems }
    { post := fun e => return Simp.Step.done (← try numeralToCoe e catch _ => pure {expr := e}) }
  trace[Tactic.norm_cast] "after numeralToCoe: {r.expr}"

  -- step 2: casts are moved upwards and eliminated
  let r ← mkEqTrans r <|<- Simp.main r.expr { config, congrTheorems }
    { post := upwardAndElim (← normCastExt.up.getTheorems) }
  trace[Tactic.norm_cast] "after upwardAndElim: {r.expr}"

  -- step 3: casts are squashed
  let r ← mkEqTrans r <|<- simp r.expr {
    simpTheorems := #[← normCastExt.squash.getTheorems]
    config, congrTheorems
  }
  trace[Tactic.norm_cast] "after squashing: {r.expr}"

  return r

open Elab.Term in
elab "mod_cast " e:term : term <= expectedType => do
  if (← instantiateMVars expectedType).hasExprMVar then tryPostpone
  let expectedType' ← derive expectedType
  let e ← elabTerm e expectedType'.expr
  synthesizeSyntheticMVars
  let eTy ← instantiateMVars (← inferType e)
  if eTy.hasExprMVar then tryPostpone
  let eTy' ← derive eTy
  unless ← isDefEq eTy'.expr expectedType'.expr do
    throwTypeMismatchError "mod_cast" expectedType'.expr eTy'.expr e
  let eTy_eq_expectedType ← mkEqTrans eTy' (← mkEqSymm expectedType expectedType')
  mkCast eTy_eq_expectedType e

open Tactic Parser.Tactic Elab.Tactic

def normCastTarget : TacticM Unit :=
  liftMetaTactic1 fun mvarId => do
    let tgt ← instantiateMVars (← getMVarType mvarId)
    let prf ← derive tgt
    applySimpResultToTarget mvarId tgt prf

def normCastHyp (fvarId : FVarId) : TacticM Unit :=
  liftMetaTactic1 fun mvarId => do
    let hyp ← instantiateMVars (← getLocalDecl fvarId).type
    let prf ← derive hyp
    return (← applySimpResultToLocalDecl mvarId fvarId prf).map (·.snd)

elab "norm_cast0" loc:(ppSpace location)? : tactic =>
  withMainContext do
    match expandOptLocation loc with
    | Location.targets hyps target =>
      if target then normCastTarget
      (← getFVarIds hyps).forM normCastHyp
    | Location.wildcard =>
      normCastTarget
      (← getNondepPropHyps (← getMainGoal)).forM normCastHyp

/-- `assumption_mod_cast` runs `norm_cast` on the goal. For each local hypothesis `h`, it also
normalizes `h` and tries to use that to close the goal. -/
macro "assumption_mod_cast" : tactic => `(norm_cast0 at * <;> assumption)

/--
Normalize casts at the given locations by moving them "upwards".
-/
macro "norm_cast" loc:(ppSpace location)? : tactic =>
  let loc := loc.getOptional?
  `(tactic| norm_cast0 $[$loc:location]? <;> try trivial)

/--
Rewrite with the given rules and normalize casts between steps.
-/
syntax "rw_mod_cast" (config)? rwRuleSeq (ppSpace location)? : tactic
macro_rules
  | `(tactic|rw_mod_cast $[$config:config]? [$rules,*] $[$loc:location]?) => do
    let tacs ← rules.getElems.mapM fun rule =>
      `(tactic| norm_cast at *; rw $[$config]? [$rule] $[$loc:location]?)
    `(tactic| ($[$tacs:tactic]*))

/--
Normalize the goal and the given expression, then close the goal with exact.
-/
macro "exact_mod_cast " e:term : tactic => `(exact mod_cast ($e : _))

/--
Normalize the goal and the given expression, then apply the expression to the goal.
-/
macro "apply_mod_cast " e:term : tactic => `(apply mod_cast ($e : _))

syntax (name := convNormCast) "norm_cast" : conv
@[tactic convNormCast] def evalConvNormCast : Tactic :=
  open Elab.Tactic.Conv in fun stx => withMainContext do
    applySimpResult (← derive (← getLhs))

syntax (name := pushCast) "push_cast " (config)? (discharger)? (&"only ")? ("[" (simpStar <|> simpErase <|> simpLemma),* "]")? (location)? : tactic
@[tactic pushCast] def evalPushCast : Tactic := fun stx => do
  let { ctx, fvarIdToLemmaId, dischargeWrapper } ← withMainContext do
    mkSimpContext' (← pushCastExt.getTheorems) stx (eraseLocal := false)
  dischargeWrapper.with fun discharge? =>
    simpLocation ctx discharge? fvarIdToLemmaId (expandOptLocation stx[5])

-- add_hint_tactic "norm_cast at *"

/-
The `norm_cast` family of tactics is used to normalize casts inside expressions.
It is basically a simp tactic with a specific set of lemmas to move casts
upwards in the expression.
Therefore it can be used more safely as a non-terminating tactic.
It also has special handling of numerals.

For instance, given an assumption
```lean
a b : ℤ
h : ↑a + ↑b < (10 : ℚ)
```

writing `norm_cast at h` will turn `h` into
```lean
h : a + b < 10
```

You can also use `exact_mod_cast`, `apply_mod_cast`, `rw_mod_cast`
or `assumption_mod_cast`.
Writing `exact_mod_cast h` and `apply_mod_cast h` will normalize the goal and
`h` before using `exact h` or `apply h`.
Writing `assumption_mod_cast` will normalize the goal and for every
expression `h` in the context it will try to normalize `h` and use
`exact h`.
`rw_mod_cast` acts like the `rw` tactic but it applies `norm_cast` between steps.

`push_cast` rewrites the expression to move casts toward the leaf nodes.
This uses `norm_cast` lemmas in the forward direction.
For example, `↑(a + b)` will be written to `↑a + ↑b`.
It is equivalent to `simp only with push_cast`.
It can also be used at hypotheses with `push_cast at h`
and with extra simp lemmas with `push_cast [int.add_zero]`.

```lean
example (a b : ℕ) (h1 : ((a + b : ℕ) : ℤ) = 10) (h2 : ((a + b + 0 : ℕ) : ℤ) = 10) :
  ((a + b : ℕ) : ℤ) = 10 :=
begin
  push_cast,
  push_cast at h1,
  push_cast [int.add_zero] at h2,
end
```

The implementation and behavior of the `norm_cast` family is described in detail at
<https://lean-forward.github.io/norm_cast/norm_cast.pdf>.
-/
-- add_tactic_doc
-- { name := "norm_cast",
--   category   := doc_category.tactic,
--   decl_names := [``tactic.interactive.norm_cast, ``tactic.interactive.rw_mod_cast,
--                  ``tactic.interactive.apply_mod_cast, ``tactic.interactive.assumption_mod_cast,
--                  ``tactic.interactive.exact_mod_cast, ``tactic.interactive.push_cast],
--   tags       := ["coercions", "simplification"] }
-- TODO