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

/-!
# `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> .
-/

open Lean Parser.Tactic Elab Command Elab.Tactic Meta

namespace Tactic
namespace Ring

/-- This cache contains data required by the `ring` tactic during execution. -/
structure Cache :=
  α : Expr
  univ : Level
  cs : Expr

structure State :=
  atoms : Array Expr := #[]
  numAtoms : Nat     := 0

/-- The monad that `ring` works in. This is a reader monad containing a cache and
the list of atoms-up-to-defeq encountered thus far, used for atom sorting. -/
abbrev RingM := ReaderT Cache $ StateRefT State MetaM

def RingM.run (ty : Expr) (m : RingM α) : MetaM α := do
  let Level.succ u _ ← getLevel ty | throwError "fail"
  let inst ← synthInstance (mkApp (mkConst ``CommSemiring [u]) ty)
  (m {α := ty, univ := u, cs := inst }).run' {}

def mkAppCS (f : Name) (args : Array Expr) : RingM Expr := do
  let c ← read
  pure $ mkAppN (mkConst f [c.univ]) (#[c.α, c.cs] ++ args)

/-- 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. -/
def addAtom (e : Expr) : RingM Nat := do
  let c ← get
  for i in [:c.numAtoms] do
    if ← isDefEq e c.atoms[i] then
      return i
  modify λ c => { c with atoms := c.atoms.push e, numAtoms := c.numAtoms + 1}
  return c.numAtoms

/-- 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 `CommSemiring` instance at the top level. See also `HornerExpr` for a
description of normal form. -/
@[reducible] def horner {α} [CommSemiring α] (a x : α) (n : ℕ) (b : α) := a * (x ^ n) + b

/-- 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. -/
inductive HornerExpr : Type
| const (e : Expr) (coeff : ℕ) : HornerExpr --TODO : coeff in ℚ
| xadd (e : Expr) (a : HornerExpr) (x : Expr × ℕ) (n : Expr × ℕ) (b : HornerExpr) : HornerExpr

instance : Inhabited HornerExpr := ⟨HornerExpr.const (mkRawNatLit 0) 0⟩

namespace HornerExpr

/-- Get the expression corresponding to a `HornerExpr`. 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. -/
def e : HornerExpr → Expr
| (HornerExpr.const e _) => e
| (HornerExpr.xadd e _ _ _ _) => e

instance : Coe HornerExpr Expr := ⟨e⟩

/-- Is this expr the constant `0`? -/
def isZero : HornerExpr → Bool
| (HornerExpr.const _ c) => c = 0
| _ => false

/-- Construct a `xadd` node -/
def xadd' (a : HornerExpr) (x : Expr × ℕ) (n : Expr × ℕ) (b : HornerExpr) : RingM HornerExpr := do
  pure $ xadd (← mkAppCS ``horner #[a, x.1, n.1, b]) a x n b

/-- Reflexivity conversion for a `HornerExpr`. -/
def reflConv (e : HornerExpr) : RingM (HornerExpr × Expr) := do pure (e, ← mkEqRefl e)

/-- Pretty printer for `horner_expr`. -/
def pp : HornerExpr → MetaM Format
| (const e c) => pure $ toString c
| (xadd e a x (_, n) b) => do
  let pa ← a.pp
  let pb ← b.pp
  let px ← PrettyPrinter.ppExpr Name.anonymous [] x.1
  return "(" ++ pa ++ ") * (" ++ px ++ ")^" ++ toString n ++ " + " ++ pb

end HornerExpr

open HornerExpr

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

theorem horner_horner {α} [CommSemiring α] (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. -/
def evalHorner : HornerExpr → Expr × ℕ → Expr × ℕ → HornerExpr → RingM (HornerExpr × Expr)
| ha@(const a coeff), x, n, b => do
  if coeff = 0 then
    return (b, ← mkAppCS ``zero_horner #[x.1, n.1, b])
  else (← xadd' ha x n b).reflConv
| ha@(xadd a a₁ x₁ n₁ b₁), x, n, b => do
  if x₁.2 = x.2 ∧ b₁.e.numeral? = some 0 then do
    let n' := mkRawNatLit (n₁.2 + n.2)
    let h ← mkEqRefl n'
    return (← xadd' a₁ x (n', n₁.2 + n.2) b,
      ← mkAppCS ``horner_horner #[a₁, x.1, n₁.1, n.1, b, n', h])
  else (← xadd' ha x n b).reflConv

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

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

theorem horner_add_horner_lt {α} [CommSemiring α] (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
  rw [← h₁, ← h₂, ← h₃]
  simp [horner, add_assoc, add_mul, pow_add, mul_assoc, add_comm n₁ k, add_left_comm b₁]

theorem horner_add_horner_gt {α} [CommSemiring α] (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
  rw [← h₁, ← h₂, ← h₃]
  simp [horner, add_assoc, mul_assoc, add_mul, add_comm n₂ k, pow_add, add_left_comm b₁]

theorem horner_add_horner_eq {α} [CommSemiring α] (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
  rw [← h₃, ← h₁, ← h₂]
  simp only [horner, add_assoc, mul_assoc, add_mul, zero_mul, zero_add, pow_add, add_left_comm b₁]

partial def evalAdd : HornerExpr → HornerExpr → RingM (HornerExpr × Expr)
| (const e₁ c₁), (const e₂ c₂) => do
  let (e', p) ← NormNum.eval $ ← mkAdd e₁ e₂
  pure (const e' (c₁ + c₂), p)
| he₁@(const e₁ c₁), he₂@(xadd e₂ a x n b) => do

  if c₁ = 0 then
    let p ← mkAppM ``zero_add #[e₂]
    return (he₂, p)
  else
    let (b', h) ← evalAdd he₁ b
    return (← xadd' a x n b',
      ← mkAppCS ``const_add_horner #[e₁, a, x.1, n.1, b, b', h])
| he₁@(xadd e₁ a x n b), he₂@(const e₂ c₂) => do
  if c₂ = 0 then
    let p ← mkAppM ``add_zero #[e₁]
    return (he₁, p)
  else
    let (b', h) ← evalAdd b he₂
    return (← xadd' a x n b',
      ← mkAppCS ``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
  let c ← get
  if x₁.2 < x₂.2 then
    let (b', h) ← evalAdd b₁ he₂
    return (← xadd' a₁ x₁ n₁ b',
      ← mkAppCS ``horner_add_const #[a₁, x₁.1, n₁.1, b₁, e₂, b', h])
  else if x₁.2 ≠ x₂.2 then
    let (b', h) ← evalAdd he₁ b₂
    return (← xadd' a₂ x₂ n₂ b',
      ← mkAppCS ``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
    let ek := mkRawNatLit k
    let h₁ ← mkEqRefl n₂.1
    let c ← read
    let α0 ← mkAppOptM ``OfNat.ofNat #[(← read).α, mkRawNatLit 0, none]
    let (a', h₂) ← evalAdd a₁ (← xadd' a₂ x₁ (ek, k) (const α0 0))
    let (b', h₃) ← evalAdd b₁ b₂
    return (← xadd' a' x₁ n₁ b',
      ← mkAppCS ``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
    let ek := mkRawNatLit k
    let h₁ ← mkEqRefl n₁.1
    let α0 ← mkAppOptM ``OfNat.ofNat #[(← read).α, mkRawNatLit 0, none]
    let (a', h₂) ← evalAdd (← xadd' a₁ x₁ (ek, k) (const α0 0)) a₂
    let (b', h₃) ← evalAdd b₁ b₂
    return (← xadd' a' x₁ n₂ b',
      ← mkAppCS ``horner_add_horner_gt #[a₁, x₁.1, n₁.1, b₁, a₂, n₂.1, b₂, ek, a', b', h₁, h₂, h₃])
  else do
    let (a', h₁) ← evalAdd a₁ a₂
    let (b', h₂) ← evalAdd b₁ b₂
    let (t, h₃) ← evalHorner a' x₁ n₁ b'
    return (t, ← mkAppCS ``horner_add_horner_eq
      #[a₁, x₁.1, n₁.1, b₁, a₂, b₂, a', b', t, h₁, h₂, h₃])

theorem horner_const_mul {α} [CommSemiring α] (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 {α} [CommSemiring α] (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 [horner, ← h₁, ← h₂, add_mul, mul_assoc, mul_comm c]

/-- Evaluate `k * a` where `k` is a rational numeral and `a` is in normal form. -/
def evalConstMul (k : Expr × ℕ) : HornerExpr → RingM (HornerExpr × Expr)
| (const e coeff) => do
  let (e', p) ← NormNum.eval $ ← mkMul k.1 e
  return (const e' (k.2 * coeff), p)
| (xadd e a x n b) => do
  let (a', h₁) ← evalConstMul k a
  let (b', h₂) ← evalConstMul k b
  return (← xadd' a' x n b',
    ← mkAppCS ``horner_const_mul #[k.1, a, x.1, n.1, b, a', b', h₁, h₂])

theorem horner_mul_horner_zero {α} [CommSemiring α] (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, add_mul, mul_assoc]

theorem horner_mul_horner {α} [CommSemiring α]
  (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, add_mul, mul_add, mul_assoc, mul_comm b₂]

/-- Evaluate `a * b` where `a` and `b` are in normal form. -/
partial def evalMul : HornerExpr → HornerExpr → RingM (HornerExpr × Expr)
| (const e₁ c₁), (const e₂ c₂) => do
  let (e', p) ← NormNum.eval $ ← mkMul e₁ e₂
  return (const e' (c₁ * c₂), p)
| (const e₁ c₁), e₂ =>
  if c₁ = 0 then do
    let α0 ← mkAppOptM ``OfNat.ofNat #[(← read).α, mkRawNatLit 0, none]
    let p ← mkAppM ``zero_mul #[e₂]
    return (const α0 0, p)
  else if c₁ = 1 then do
    let p ←  mkAppM ``one_mul #[e₂]
    return (e₂, p)
  else evalConstMul (e₁, c₁) e₂
| e₁, he₂@(const e₂ c₂) => do
  let p₁ ← mkAppM ``mul_comm #[e₁, e₂]
  let (e', p₂) ← evalMul he₂ e₁
  let p ← mkEqTrans p₁ p₂
  return (e', p)
| he₁@(xadd e₁ a₁ x₁ n₁ b₁), he₂@(xadd e₂ a₂ x₂ n₂ b₂) => do
  if x₁.2 < x₂.2 then do
    let (a', h₁) ← evalMul a₁ he₂
    let (b', h₂) ← evalMul b₁ he₂
    return (← xadd' a' x₁ n₁ b',
      ← mkAppCS ``horner_mul_const #[a₁, x₁.1, n₁.1, b₁, e₂, a', b', h₁, h₂])
  else if x₁.2 ≠ x₂.2 then do
    let (a', h₁) ← evalMul he₁ a₂
    let (b', h₂) ← evalMul he₁ b₂
    return (← xadd' a' x₂ n₂ b',
      ← mkAppCS ``horner_const_mul #[e₁, a₂, x₂.1, n₂.1, b₂, a', b', h₁, h₂])
  else do
    let (aa, h₁) ← evalMul he₁ a₂
    let α0 ← mkAppOptM ``OfNat.ofNat #[(← read).α, mkRawNatLit 0, none]
    let (haa, h₂) ← evalHorner aa x₁ n₂ (const α0 0)
    if b₂.isZero then
      return (haa, ← mkAppCS ``horner_mul_horner_zero
        #[a₁, x₁.1, n₁.1, b₁, a₂, n₂.1, aa, haa, h₁, h₂])
    else do
      let (ab, h₃) ← evalMul a₁ b₂
      let (bb, h₄) ← evalMul b₁ b₂
      let (t, H) ← evalAdd haa (← xadd' ab x₁ n₁ bb)
      return (t, ← mkAppCS ``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 {α} [CommSemiring α] (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 a, pow_mul]

theorem pow_succ_eq {α} [CommSemiring α] (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. -/
partial def evalPow : HornerExpr → Expr × ℕ → RingM (HornerExpr × Expr)
| e, (_, 0) => do
  let α1 ← mkAppOptM ``OfNat.ofNat #[(← read).α, mkRawNatLit 1, none]
  let p ← mkAppM ``pow_zero #[e]
  pure (const α1 1, p)
| e, (_, 1) => do
  let p ← mkAppM ``pow_one #[e]
  pure (e, p)
| const e coeff, (e₂, m) => do
  let (e', p) ← NormNum.eval $ ← mkAppM ``HPow.hPow #[e, e₂]
  pure (const e' (coeff ^ m), p)
| he@(xadd e a x n b), m =>
  match b.e.numeral? with
  | some 0 => do
    let n' := mkRawNatLit (n.2 * m.2)
    let h₁ ← mkEqRefl n'
    let (a', h₂) ← evalPow a m
    let α0 ← mkAppOptM ``OfNat.ofNat #[(← read).α, mkRawNatLit 0, none]
    pure (← xadd' a' x (n', n.2 * m.2) (const α0 0),
      ← mkAppCS ``horner_pow #[a, x.1, n.1, m.1, n', a', h₁, h₂])
  | _ => do
    let e₂ := mkRawNatLit (m.2 - 1)
    let (tl, hl) ← evalPow he (e₂, m.2-1)
    let (t, p₂) ← evalMul tl he
    pure (t, ← mkAppCS ``pow_succ_eq #[e, e₂, tl, t, hl, p₂])

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

/-- Evaluate `a` where `a` is an atom. -/
def evalAtom (e : Expr) : RingM (HornerExpr × Expr) := do
  let i ← addAtom e
  let zero := const (← mkAppOptM ``OfNat.ofNat #[(← read).α, mkRawNatLit 0, none]) 0
  let one := const (← mkAppOptM ``OfNat.ofNat #[(← read).α, mkRawNatLit 1, none]) 1
  pure (← xadd' one (e,i) (mkRawNatLit 1,1) zero, ← mkAppCS ``horner_atom #[e])

theorem subst_into_add {α} [Add α] (l r tl tr t)
  (prl : (l : α) = tl) (prr : r = tr) (prt : tl + tr = t) : l + r = t :=
by rw [prl, prr, prt]

theorem subst_into_mul {α} [Mul α] (l r tl tr t)
  (prl : (l : α) = tl) (prr : r = tr) (prt : tl * tr = t) : l * r = t :=
by rw [prl, prr, prt]

theorem 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]

partial def eval (e : Expr) : RingM (HornerExpr × Expr) :=
  match e.getAppFnArgs with
  | (``HAdd.hAdd, #[_,_,_,_,e₁,e₂]) => do
    let (e₁', p₁) ← eval e₁
    let (e₂', p₂) ← eval e₂
    let (e', p') ← evalAdd e₁' e₂'
    let p ← mkAppM ``subst_into_add #[e₁, e₂, e₁', e₂', e', p₁, p₂, p']
    pure (e', p)
  | (``HMul.hMul, #[_,_,_,_,e₁,e₂]) => do
    let (e₁', p₁) ← eval e₁
    let (e₂', p₂) ← eval e₂
    let (e', p') ← evalMul e₁' e₂'
    let p ← mkAppM ``subst_into_mul #[e₁, e₂, e₁', e₂', e', p₁, p₂, p']
    return (e', p)
  | (``HPow.hPow, #[_,_,_,P,e₁,e₂]) => do
    -- let (e₂', p₂) ← lift $ norm_num.derive e₂ <|> refl_conv e₂,
    let (e₂', p₂) := (e₂, ← mkEqRefl e₂)
    match e₂'.numeral?, P.getAppFn with
    | some k, Expr.const ``Monoid.HPow _ _ => do
      let (e₁', p₁) ← eval e₁
      let (e', p') ← evalPow e₁' (e₂, k)
      let p ← mkAppM ``subst_into_pow #[e₁, e₂, e₁', e₂', e', p₁, p₂, p']
      return (e', p)
    | _, _ => evalAtom e
  | _ =>
    match e.numeral? with
    | some n => (const e n).reflConv
    | _ => evalAtom e

elab "ring" : tactic => liftMetaMAtMain fun g => do
  match (← instantiateMVars (← getMVarDecl g).type).getAppFnArgs with
  | (`Eq, #[ty, e₁, e₂]) =>
    let ((e₁', p₁), (e₂', p₂)) ← RingM.run ty $ do pure (← eval e₁, ← eval e₂)
    if ← isDefEq e₁' e₂' then
      assignExprMVar g (← mkEqTrans p₁ (← mkEqSymm p₂))
    else
      throwError "ring failed, ring expressions not equal: \n{← e₁'.pp}\n  !=\n{← e₂'.pp}"
  | _ => throwError "ring failed: not an equality"


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

import set_theory.principal

/-!
# Ordinal notation

Constructive ordinal arithmetic for ordinals below `ε₀`.

We define a type `onote`, with constructors `0 : onote` and `onote.oadd e n a` representing
`ω ^ e * n + a`.
We say that `o` is in Cantor normal form - `onote.NF o` - if either `o = 0` or
`o = ω ^ e * n + a` with `a < ω ^ e` and `a` in Cantor normal form.

The type `nonote` is the type of ordinals below `ε₀` in Cantor normal form.
Various operations (addition, subtraction, multiplication, power function)
are defined on `onote` and `nonote`.
-/

open ordinal
open_locale ordinal -- get notation for `ω`

/-- Recursive definition of an ordinal notation. `zero` denotes the
  ordinal 0, and `oadd e n a` is intended to refer to `ω^e * n + a`.
  For this to be valid Cantor normal form, we must have the exponents
  decrease to the right, but we can't state this condition until we've
  defined `repr`, so it is a separate definition `NF`. -/
@[derive decidable_eq]
inductive onote : Type
| zero : onote
| oadd : onote → ℕ+ → onote → onote

namespace onote

/-- Notation for 0 -/
instance : has_zero onote := ⟨zero⟩
@[simp] theorem zero_def : zero = 0 := rfl

instance : inhabited onote := ⟨0⟩

/-- Notation for 1 -/
instance : has_one onote := ⟨oadd 0 1 0⟩

/-- Notation for ω -/
def omega : onote := oadd 1 1 0

/-- The ordinal denoted by a notation -/
@[simp] noncomputable def repr : onote → ordinal.{0}
| 0 := 0
| (oadd e n a) := ω ^ repr e * n + repr a

/-- Auxiliary definition to print an ordinal notation -/
def to_string_aux1 (e : onote) (n : ℕ) (s : string) : string :=
if e = 0 then _root_.to_string n else
(if e = 1 then "ω" else "ω^(" ++ s ++ ")") ++
if n = 1 then "" else "*" ++ _root_.to_string n

/-- Print an ordinal notation -/
def to_string : onote → string
| zero := "0"
| (oadd e n 0) := to_string_aux1 e n (to_string e)
| (oadd e n a) := to_string_aux1 e n (to_string e) ++ " + " ++ to_string a

/-- Print an ordinal notation -/
def repr' : onote → string
| zero := "0"
| (oadd e n a) := "(oadd " ++ repr' e ++ " " ++ _root_.to_string (n:ℕ) ++ " " ++ repr' a ++ ")"

instance : has_to_string onote := ⟨to_string⟩
instance : has_repr onote := ⟨repr'⟩

instance : preorder onote :=
{ le       := λ x y, repr x ≤ repr y,
  lt       := λ x y, repr x < repr y,
  le_refl  := λ a, @le_refl ordinal _ _,
  le_trans := λ a b c, @le_trans ordinal _ _ _ _,
  lt_iff_le_not_le := λ a b, @lt_iff_le_not_le ordinal _ _ _ }

theorem lt_def {x y : onote} : x < y ↔ repr x < repr y := iff.rfl
theorem le_def {x y : onote} : x ≤ y ↔ repr x ≤ repr y := iff.rfl

/-- Convert a `nat` into an ordinal -/
@[simp] def of_nat : ℕ → onote
| 0            := 0
| (nat.succ n) := oadd 0 n.succ_pnat 0

@[simp] theorem of_nat_one : of_nat 1 = 1 := rfl

@[simp] theorem repr_of_nat (n : ℕ) : repr (of_nat n) = n :=
by cases n; simp

@[simp] theorem repr_one : repr 1 = 1 :=
by simpa using repr_of_nat 1

theorem omega_le_oadd (e n a) : ω ^ repr e ≤ repr (oadd e n a) :=
begin
  unfold repr,
  refine le_trans _ (le_add_right _ _),
  simpa using (mul_le_mul_iff_left $ opow_pos (repr e) omega_pos).2 (nat_cast_le.2 n.2)
end

theorem oadd_pos (e n a) : 0 < oadd e n a :=
@lt_of_lt_of_le _ _ _ _ _ (opow_pos _ omega_pos)
  (omega_le_oadd _ _ _)

/-- Compare ordinal notations -/
def cmp : onote → onote → ordering
| 0 0 := ordering.eq
| _ 0 := ordering.gt
| 0 _ := ordering.lt
| o₁@(oadd e₁ n₁ a₁) o₂@(oadd e₂ n₂ a₂) :=
  (cmp e₁ e₂).or_else $ (_root_.cmp (n₁:ℕ) n₂).or_else (cmp a₁ a₂)

theorem eq_of_cmp_eq : ∀ {o₁ o₂}, cmp o₁ o₂ = ordering.eq → o₁ = o₂
| 0            0 h := rfl
| (oadd e n a) 0 h := by injection h
| 0 (oadd e n a) h := by injection h
| o₁@(oadd e₁ n₁ a₁) o₂@(oadd e₂ n₂ a₂) h := begin
  revert h, simp [cmp],
  cases h₁ : cmp e₁ e₂; intro h; try {cases h},
  have := eq_of_cmp_eq h₁, subst e₂,
  revert h, cases h₂ : _root_.cmp (n₁:ℕ) n₂; intro h; try {cases h},
  have := eq_of_cmp_eq h, subst a₂,
  rw [_root_.cmp, cmp_using_eq_eq] at h₂,
  have := subtype.eq (eq_of_incomp h₂), subst n₂, simp
end

theorem zero_lt_one : (0 : onote) < 1 :=
by rw [lt_def, repr, repr_one]; exact zero_lt_one

/-- `NF_below o b` says that `o` is a normal form ordinal notation
  satisfying `repr o < ω ^ b`. -/
inductive NF_below : onote → ordinal.{0} → Prop
| zero {b} : NF_below 0 b
| oadd' {e n a eb b} : NF_below e eb →
  NF_below a (repr e) → repr e < b → NF_below (oadd e n a) b

/-- A normal form ordinal notation has the form

     ω ^ a₁ * n₁ + ω ^ a₂ * n₂ + ... ω ^ aₖ * nₖ
  where `a₁ > a₂ > ... > aₖ` and all the `aᵢ` are
  also in normal form.

  We will essentially only be interested in normal form
  ordinal notations, but to avoid complicating the algorithms
  we define everything over general ordinal notations and
  only prove correctness with normal form as an invariant. -/
class NF (o : onote) : Prop := (out : Exists (NF_below o))
attribute [pp_nodot] NF

instance NF.zero : NF 0 := ⟨⟨0, NF_below.zero⟩⟩

theorem NF_below.oadd {e n a b} : NF e →
  NF_below a (repr e) → repr e < b → NF_below (oadd e n a) b
| ⟨⟨eb, h⟩⟩ := NF_below.oadd' h

theorem NF_below.fst {e n a b} (h : NF_below (oadd e n a) b) : NF e :=
by cases h with _ _ _ _ eb _ h₁ h₂ h₃; exact ⟨⟨_, h₁⟩⟩

theorem NF.fst {e n a} : NF (oadd e n a) → NF e
| ⟨⟨b, h⟩⟩ := h.fst

theorem NF_below.snd {e n a b} (h : NF_below (oadd e n a) b) : NF_below a (repr e) :=
by cases h with _ _ _ _ eb _ h₁ h₂ h₃; exact h₂

theorem NF.snd' {e n a} : NF (oadd e n a) → NF_below a (repr e)
| ⟨⟨b, h⟩⟩ := h.snd

theorem NF.snd {e n a} (h : NF (oadd e n a)) : NF a :=
⟨⟨_, h.snd'⟩⟩

theorem NF.oadd {e a} (h₁ : NF e) (n)
  (h₂ : NF_below a (repr e)) : NF (oadd e n a) :=
⟨⟨_, NF_below.oadd h₁ h₂ (ordinal.lt_succ_self _)⟩⟩

instance NF.oadd_zero (e n) [h : NF e] : NF (oadd e n 0) :=
h.oadd _ NF_below.zero

theorem NF_below.lt {e n a b} (h : NF_below (oadd e n a) b) : repr e < b :=
by cases h with _ _ _ _ eb _ h₁ h₂ h₃; exact h₃

theorem NF_below_zero : ∀ {o}, NF_below o 0 ↔ o = 0
| 0            := ⟨λ _, rfl, λ _, NF_below.zero⟩
| (oadd e n a) := ⟨λ h, (not_le_of_lt h.lt).elim (ordinal.zero_le _),
                   λ e, e.symm ▸ NF_below.zero⟩

theorem NF.zero_of_zero {e n a} (h : NF (oadd e n a)) (e0 : e = 0) : a = 0 :=
by simpa [e0, NF_below_zero] using h.snd'

theorem NF_below.repr_lt {o b} (h : NF_below o b) : repr o < ω ^ b :=
begin
  induction h with _ e n a eb b h₁ h₂ h₃ _ IH,
  { exact opow_pos _ omega_pos },
  { rw repr,
    apply ((add_lt_add_iff_left _).2 IH).trans_le,
    rw ← mul_succ,
    apply (mul_le_mul_left' (ordinal.succ_le.2 (nat_lt_omega _)) _).trans,
    rw ← opow_succ,
    exact opow_le_opow_right omega_pos (ordinal.succ_le.2 h₃) }
end

theorem NF_below.mono {o b₁ b₂} (bb : b₁ ≤ b₂) (h : NF_below o b₁) : NF_below o b₂ :=
begin
  induction h with _ e n a eb b h₁ h₂ h₃ _ IH; constructor,
  exacts [h₁, h₂, lt_of_lt_of_le h₃ bb]
end

theorem NF.below_of_lt {e n a b} (H : repr e < b) : NF (oadd e n a) → NF_below (oadd e n a) b
| ⟨⟨b', h⟩⟩ := by cases h with _ _ _ _ eb _ h₁ h₂ h₃;
  exact NF_below.oadd' h₁ h₂ H

theorem NF.below_of_lt' : ∀ {o b}, repr o < ω ^ b → NF o → NF_below o b
| 0            b H _ := NF_below.zero
| (oadd e n a) b H h := h.below_of_lt $ (opow_lt_opow_iff_right one_lt_omega).1 $
    (lt_of_le_of_lt (omega_le_oadd _ _ _) H)

theorem NF_below_of_nat : ∀ n, NF_below (of_nat n) 1
| 0            := NF_below.zero
| (nat.succ n) := NF_below.oadd NF.zero NF_below.zero ordinal.zero_lt_one

instance NF_of_nat (n) : NF (of_nat n) := ⟨⟨_, NF_below_of_nat n⟩⟩

instance NF_one : NF 1 := by rw ← of_nat_one; apply_instance

theorem oadd_lt_oadd_1 {e₁ n₁ o₁ e₂ n₂ o₂} (h₁ : NF (oadd e₁ n₁ o₁)) (h : e₁ < e₂) :
  oadd e₁ n₁ o₁ < oadd e₂ n₂ o₂ :=
@lt_of_lt_of_le _ _ _ _ _ ((h₁.below_of_lt h).repr_lt) (omega_le_oadd _ _ _)

theorem oadd_lt_oadd_2 {e o₁ o₂ : onote} {n₁ n₂ : ℕ+}
  (h₁ : NF (oadd e n₁ o₁)) (h : (n₁:ℕ) < n₂) : oadd e n₁ o₁ < oadd e n₂ o₂ :=
begin
  simp [lt_def],
  refine lt_of_lt_of_le ((add_lt_add_iff_left _).2 h₁.snd'.repr_lt)
    (le_trans _ (le_add_right _ _)),
  rwa [← mul_succ, mul_le_mul_iff_left (opow_pos _ omega_pos),
       ordinal.succ_le, nat_cast_lt]
end

theorem oadd_lt_oadd_3 {e n a₁ a₂} (h : a₁ < a₂) :
  oadd e n a₁ < oadd e n a₂ :=
begin
  rw lt_def, unfold repr,
  exact add_lt_add_left h _
end

theorem cmp_compares : ∀ (a b : onote) [NF a] [NF b], (cmp a b).compares a b
| 0 0 h₁ h₂ := rfl
| (oadd e n a) 0 h₁ h₂ := oadd_pos _ _ _
| 0 (oadd e n a) h₁ h₂ := oadd_pos _ _ _
| o₁@(oadd e₁ n₁ a₁) o₂@(oadd e₂ n₂ a₂) h₁ h₂ := begin
    rw cmp,
    have IHe := @cmp_compares _ _ h₁.fst h₂.fst,
    cases cmp e₁ e₂,
    case ordering.lt { exact oadd_lt_oadd_1 h₁ IHe },
    case ordering.gt { exact oadd_lt_oadd_1 h₂ IHe },
    change e₁ = e₂ at IHe, subst IHe,
    unfold _root_.cmp, cases nh : cmp_using (<) (n₁:ℕ) n₂,
    case ordering.lt
    { rw cmp_using_eq_lt at nh, exact oadd_lt_oadd_2 h₁ nh },
    case ordering.gt
    { rw cmp_using_eq_gt at nh, exact oadd_lt_oadd_2 h₂ nh },
    rw cmp_using_eq_eq at nh,
    have := subtype.eq (eq_of_incomp nh), subst n₂,
    have IHa := @cmp_compares _ _ h₁.snd h₂.snd,
    cases cmp a₁ a₂,
    case ordering.lt { exact oadd_lt_oadd_3 IHa },
    case ordering.gt { exact oadd_lt_oadd_3 IHa },
    change a₁ = a₂ at IHa, subst IHa, exact rfl
  end

theorem repr_inj {a b} [NF a] [NF b] : repr a = repr b ↔ a = b :=
⟨match cmp a b, cmp_compares a b with
 | ordering.lt, (h : repr a < repr b), e := (ne_of_lt h e).elim
 | ordering.gt, (h : repr a > repr b), e := (ne_of_gt h e).elim
 | ordering.eq, h, e := h
 end, congr_arg _⟩

theorem NF.of_dvd_omega_opow {b e n a} (h : NF (oadd e n a)) (d : ω ^ b ∣ repr (oadd e n a)) :
  b ≤ repr e ∧ ω ^ b ∣ repr a :=
begin
  have := mt repr_inj.1 (λ h, by injection h : oadd e n a ≠ 0),
  have L := le_of_not_lt (λ l, not_le_of_lt (h.below_of_lt l).repr_lt (le_of_dvd this d)),
  simp at d,
  exact ⟨L, (dvd_add_iff $ (opow_dvd_opow _ L).mul_right _).1 d⟩
end

theorem NF.of_dvd_omega {e n a} (h : NF (oadd e n a)) :
   ω ∣ repr (oadd e n a) → repr e ≠ 0 ∧ ω ∣ repr a :=
by rw [← opow_one ω, ← one_le_iff_ne_zero]; exact h.of_dvd_omega_opow

/-- `top_below b o` asserts that the largest exponent in `o`, if
  it exists, is less than `b`. This is an auxiliary definition
  for decidability of `NF`. -/
def top_below (b) : onote → Prop
| 0            := true
| (oadd e n a) := cmp e b = ordering.lt

instance decidable_top_below : decidable_rel top_below :=
by intros b o; cases o; delta top_below; apply_instance

theorem NF_below_iff_top_below {b} [NF b] : ∀ {o},
  NF_below o (repr b) ↔ NF o ∧ top_below b o
| 0            := ⟨λ h, ⟨⟨⟨_, h⟩⟩, trivial⟩, λ _, NF_below.zero⟩
| (oadd e n a) :=
  ⟨λ h, ⟨⟨⟨_, h⟩⟩, (@cmp_compares _ b h.fst _).eq_lt.2 h.lt⟩,
   λ ⟨h₁, h₂⟩, h₁.below_of_lt $ (@cmp_compares _ b h₁.fst _).eq_lt.1 h₂⟩

instance decidable_NF : decidable_pred NF
| 0            := is_true NF.zero
| (oadd e n a) := begin
  have := decidable_NF e,
  have := decidable_NF a, resetI,
  apply decidable_of_iff (NF e ∧ NF a ∧ top_below e a),
  abstract
  { rw ← and_congr_right (λ h, @NF_below_iff_top_below _ h _),
    exact ⟨λ ⟨h₁, h₂⟩, NF.oadd h₁ n h₂, λ h, ⟨h.fst, h.snd'⟩⟩ },
end

/-- Addition of ordinal notations (correct only for normal input) -/
def add : onote → onote → onote
| 0            o := o
| (oadd e n a) o := match add a o with
  | 0 := oadd e n 0
  | o'@(oadd e' n' a') := match cmp e e' with
    | ordering.lt := o'
    | ordering.eq := oadd e (n + n') a'
    | ordering.gt := oadd e n o'
    end
  end

instance : has_add onote := ⟨add⟩

@[simp] theorem zero_add (o : onote) : 0 + o = o := rfl
theorem oadd_add (e n a o) : oadd e n a + o = add._match_1 e n (a + o) := rfl

/-- Subtraction of ordinal notations (correct only for normal input) -/
def sub : onote → onote → onote
| 0 o := 0
| o 0 := o
| o₁@(oadd e₁ n₁ a₁) (oadd e₂ n₂ a₂) := match cmp e₁ e₂ with
  | ordering.lt := 0
  | ordering.gt := o₁
  | ordering.eq := match (n₁:ℕ) - n₂ with
    | 0            := if n₁ = n₂ then sub a₁ a₂ else 0
    | (nat.succ k) := oadd e₁ k.succ_pnat a₁
  end
end

instance : has_sub onote := ⟨sub⟩

theorem add_NF_below {b} : ∀ {o₁ o₂}, NF_below o₁ b → NF_below o₂ b → NF_below (o₁ + o₂) b
| 0            o h₁ h₂ := h₂
| (oadd e n a) o h₁ h₂ := begin
  have h' := add_NF_below (h₁.snd.mono $ le_of_lt h₁.lt) h₂,
  simp [oadd_add], cases a + o with e' n' a',
  { exact NF_below.oadd h₁.fst NF_below.zero h₁.lt },
  simp [add], have := @cmp_compares _ _ h₁.fst h'.fst,
  cases cmp e e'; simp [add],
  { exact h' },
  { simp at this, subst e',
    exact NF_below.oadd h'.fst h'.snd h'.lt },
  { exact NF_below.oadd h₁.fst (NF.below_of_lt this ⟨⟨_, h'⟩⟩) h₁.lt }
end

instance add_NF (o₁ o₂) : ∀ [NF o₁] [NF o₂], NF (o₁ + o₂)
| ⟨⟨b₁, h₁⟩⟩ ⟨⟨b₂, h₂⟩⟩ := ⟨(b₁.le_total b₂).elim
  (λ h, ⟨b₂, add_NF_below (h₁.mono h) h₂⟩)
  (λ h, ⟨b₁, add_NF_below h₁ (h₂.mono h)⟩)⟩

@[simp] theorem repr_add : ∀ o₁ o₂ [NF o₁] [NF o₂], repr (o₁ + o₂) = repr o₁ + repr o₂
| 0            o h₁ h₂ := by simp
| (oadd e n a) o h₁ h₂ := begin
  haveI := h₁.snd, have h' := repr_add a o,
  conv at h' in (_+o) {simp [(+)]},
  have nf := onote.add_NF a o,
  conv at nf in (_+o) {simp [(+)]},
  conv in (_+o) {simp [(+), add]},
  cases add a o with e' n' a'; simp [add, h'.symm, add_assoc],
  have := h₁.fst, haveI := nf.fst, have ee := cmp_compares e e',
  cases cmp e e'; simp [add],
  { rw [← add_assoc, @add_absorp _ (repr e') (ω ^ repr e' * (n':ℕ))],
    { have := (h₁.below_of_lt ee).repr_lt, unfold repr at this,
      exact lt_of_le_of_lt (le_add_right _ _) this },
    { simpa using (mul_le_mul_iff_left $
        opow_pos (repr e') omega_pos).2 (nat_cast_le.2 n'.pos) } },
  { change e = e' at ee, substI e',
    rw [← add_assoc, ← ordinal.mul_add, ← nat.cast_add] }
end

theorem sub_NF_below : ∀ {o₁ o₂ b}, NF_below o₁ b → NF o₂ → NF_below (o₁ - o₂) b
| 0            o b h₁ h₂ := by cases o; exact NF_below.zero
| (oadd e n a) 0 b h₁ h₂ := h₁
| (oadd e₁ n₁ a₁) (oadd e₂ n₂ a₂) b h₁ h₂ := begin
  have h' := sub_NF_below h₁.snd h₂.snd,
  simp [has_sub.sub, sub] at h' ⊢,
  have := @cmp_compares _ _ h₁.fst h₂.fst,
  cases cmp e₁ e₂; simp [sub],
  { apply NF_below.zero },
  { simp at this, subst e₂,
    cases mn : (n₁:ℕ) - n₂; simp [sub],
    { by_cases en : n₁ = n₂; simp [en],
      { exact h'.mono (le_of_lt h₁.lt) },
      { exact NF_below.zero } },
    { exact NF_below.oadd h₁.fst h₁.snd h₁.lt } },
  { exact h₁ }
end

instance sub_NF (o₁ o₂) : ∀ [NF o₁] [NF o₂], NF (o₁ - o₂)
| ⟨⟨b₁, h₁⟩⟩ h₂ := ⟨⟨b₁, sub_NF_below h₁ h₂⟩⟩

@[simp] theorem repr_sub : ∀ o₁ o₂ [NF o₁] [NF o₂], repr (o₁ - o₂) = repr o₁ - repr o₂
| 0            o h₁ h₂ := by cases o; exact (ordinal.zero_sub _).symm
| (oadd e n a) 0 h₁ h₂ := (ordinal.sub_zero _).symm
| (oadd e₁ n₁ a₁) (oadd e₂ n₂ a₂) h₁ h₂ := begin
  haveI := h₁.snd, haveI := h₂.snd, have h' := repr_sub a₁ a₂,
  conv at h' in (a₁-a₂) {simp [has_sub.sub]},
  have nf := onote.sub_NF a₁ a₂,
  conv at nf in (a₁-a₂) {simp [has_sub.sub]},
  conv in (_-oadd _ _ _) {simp [has_sub.sub, sub]},
  have ee := @cmp_compares _ _ h₁.fst h₂.fst,
  cases cmp e₁ e₂,
  { rw [ordinal.sub_eq_zero_iff_le.2], {refl},
    exact le_of_lt (oadd_lt_oadd_1 h₁ ee) },
  { change e₁ = e₂ at ee, substI e₂, unfold sub._match_1,
    cases mn : (n₁:ℕ) - n₂; dsimp only [sub._match_2],
    { by_cases en : n₁ = n₂,
      { simp [en], rwa [add_sub_add_cancel] },
      { simp [en, -repr],
        exact (ordinal.sub_eq_zero_iff_le.2 $ le_of_lt $ oadd_lt_oadd_2 h₁ $
          lt_of_le_of_ne (tsub_eq_zero_iff_le.1 mn) (mt pnat.eq en)).symm } },
    { simp [nat.succ_pnat, -nat.cast_succ],
      rw [(tsub_eq_iff_eq_add_of_le $ le_of_lt $ nat.lt_of_sub_eq_succ mn).1 mn,
          add_comm, nat.cast_add, ordinal.mul_add, add_assoc, add_sub_add_cancel],
      refine (ordinal.sub_eq_of_add_eq $ add_absorp h₂.snd'.repr_lt $
        le_trans _ (le_add_right _ _)).symm,
      simpa using mul_le_mul_left' (nat_cast_le.2 $ nat.succ_pos _) _ } },
  { exact (ordinal.sub_eq_of_add_eq $ add_absorp (h₂.below_of_lt ee).repr_lt $
      omega_le_oadd _ _ _).symm }
end

/-- Multiplication of ordinal notations (correct only for normal input) -/
def mul : onote → onote → onote
| 0 _ := 0
| _ 0 := 0
| o₁@(oadd e₁ n₁ a₁) (oadd e₂ n₂ a₂) :=
  if e₂ = 0 then oadd e₁ (n₁ * n₂) a₁ else
  oadd (e₁ + e₂) n₂ (mul o₁ a₂)

instance : has_mul onote := ⟨mul⟩

@[simp] theorem zero_mul (o : onote) : 0 * o = 0 := by cases o; refl
@[simp] theorem mul_zero (o : onote) : o * 0 = 0 := by cases o; refl

theorem oadd_mul (e₁ n₁ a₁ e₂ n₂ a₂) : oadd e₁ n₁ a₁ * oadd e₂ n₂ a₂ =
  if e₂ = 0 then oadd e₁ (n₁ * n₂) a₁ else
  oadd (e₁ + e₂) n₂ (oadd e₁ n₁ a₁ * a₂) := rfl

theorem oadd_mul_NF_below {e₁ n₁ a₁ b₁} (h₁ : NF_below (oadd e₁ n₁ a₁) b₁) :
  ∀ {o₂ b₂}, NF_below o₂ b₂ → NF_below (oadd e₁ n₁ a₁ * o₂) (repr e₁ + b₂)
| 0 b₂ h₂ := NF_below.zero
| (oadd e₂ n₂ a₂) b₂ h₂ := begin
  have IH := oadd_mul_NF_below h₂.snd,
  by_cases e0 : e₂ = 0; simp [e0, oadd_mul],
  { apply NF_below.oadd h₁.fst h₁.snd,
    simpa using (add_lt_add_iff_left (repr e₁)).2
      (lt_of_le_of_lt (ordinal.zero_le _) h₂.lt) },
  { haveI := h₁.fst, haveI := h₂.fst,
    apply NF_below.oadd, apply_instance,
    { rwa repr_add },
    { rw [repr_add, add_lt_add_iff_left], exact h₂.lt } }
end

instance mul_NF : ∀ o₁ o₂ [NF o₁] [NF o₂], NF (o₁ * o₂)
| 0 o h₁ h₂ := by cases o; exact NF.zero
| (oadd e n a) o ⟨⟨b₁, hb₁⟩⟩ ⟨⟨b₂, hb₂⟩⟩ :=
  ⟨⟨_, oadd_mul_NF_below hb₁ hb₂⟩⟩

@[simp] theorem repr_mul : ∀ o₁ o₂ [NF o₁] [NF o₂], repr (o₁ * o₂) = repr o₁ * repr o₂
| 0               o               h₁ h₂ := by cases o; exact (ordinal.zero_mul _).symm
| (oadd e₁ n₁ a₁) 0               h₁ h₂ := (ordinal.mul_zero _).symm
| (oadd e₁ n₁ a₁) (oadd e₂ n₂ a₂) h₁ h₂ := begin
  have IH : repr (mul _ _) = _ := @repr_mul _ _ h₁ h₂.snd,
  conv {to_lhs, simp [(*)]},
  have ao : repr a₁ + ω ^ repr e₁ * (n₁:ℕ) = ω ^ repr e₁ * (n₁:ℕ),
  { apply add_absorp h₁.snd'.repr_lt,
    simpa using (mul_le_mul_iff_left $ opow_pos _ omega_pos).2
      (nat_cast_le.2 n₁.2) },
  by_cases e0 : e₂ = 0; simp [e0, mul],
  { cases nat.exists_eq_succ_of_ne_zero n₂.ne_zero with x xe,
    simp [h₂.zero_of_zero e0, xe, -nat.cast_succ],
    rw [← nat_cast_succ x, add_mul_succ _ ao, mul_assoc] },
  { haveI := h₁.fst, haveI := h₂.fst,
    simp [IH, repr_add, opow_add, ordinal.mul_add],
    rw ← mul_assoc, congr' 2,
    have := mt repr_inj.1 e0,
    rw [add_mul_limit ao (opow_is_limit_left omega_is_limit this),
        mul_assoc, mul_omega_dvd (nat_cast_pos.2 n₁.pos) (nat_lt_omega _)],
    simpa using opow_dvd_opow ω (one_le_iff_ne_zero.2 this) },
end

/-- Calculate division and remainder of `o` mod ω.
  `split' o = (a, n)` means `o = ω * a + n`. -/
def split' : onote → onote × ℕ
| 0            := (0, 0)
| (oadd e n a) := if e = 0 then (0, n) else
  let (a', m) := split' a in (oadd (e - 1) n a', m)

/-- Calculate division and remainder of `o` mod ω.
  `split o = (a, n)` means `o = a + n`, where `ω ∣ a`. -/
def split : onote → onote × ℕ
| 0            := (0, 0)
| (oadd e n a) := if e = 0 then (0, n) else
  let (a', m) := split a in (oadd e n a', m)

/-- `scale x o` is the ordinal notation for `ω ^ x * o`. -/
def scale (x : onote) : onote → onote
| 0            := 0
| (oadd e n a) := oadd (x + e) n (scale a)

/-- `mul_nat o n` is the ordinal notation for `o * n`. -/
def mul_nat : onote → ℕ → onote
| 0            m := 0
| _            0 := 0
| (oadd e n a) (m+1) := oadd e (n * m.succ_pnat) a

/-- Auxiliary definition to compute the ordinal notation for the ordinal
exponentiation in `opow` -/
def opow_aux (e a0 a : onote) : ℕ → ℕ → onote
| _     0     := 0
| 0     (m+1) := oadd e m.succ_pnat 0
| (k+1) m     := scale (e + mul_nat a0 k) a + opow_aux k m

/-- `opow o₁ o₂` calculates the ordinal notation for
  the ordinal exponential `o₁ ^ o₂`. -/
def opow (o₁ o₂ : onote) : onote :=
match split o₁ with
| (0, 0) := if o₂ = 0 then 1 else 0
| (0, 1) := 1
| (0, m+1) := let (b', k) := split' o₂ in
  oadd b' (@has_pow.pow ℕ+ _ _ m.succ_pnat k) 0
| (a@(oadd a0 _ _), m) := match split o₂ with
  | (b, 0) := oadd (a0 * b) 1 0
  | (b, k+1) := let eb := a0*b in
    scale (eb + mul_nat a0 k) a + opow_aux eb a0 (mul_nat a m) k m
  end
end

instance : has_pow onote onote := ⟨opow⟩

theorem opow_def (o₁ o₂ : onote) : o₁ ^ o₂ = opow._match_1 o₂ (split o₁) := rfl

theorem split_eq_scale_split' : ∀ {o o' m} [NF o], split' o = (o', m) → split o = (scale 1 o', m)
| 0            o' m h p := by injection p; substs o' m; refl
| (oadd e n a) o' m h p := begin
  by_cases e0 : e = 0; simp [e0, split, split'] at p ⊢,
  { rcases p with ⟨rfl, rfl⟩, exact ⟨rfl, rfl⟩ },
  { revert p, cases h' : split' a with a' m',
    haveI := h.fst, haveI := h.snd,
    simp [split_eq_scale_split' h', split, split'],
    have : 1 + (e - 1) = e,
    { refine repr_inj.1 _, simp,
      have := mt repr_inj.1 e0,
      exact ordinal.add_sub_cancel_of_le (one_le_iff_ne_zero.2 this) },
    intros, substs o' m, simp [scale, this] }
end

theorem NF_repr_split' : ∀ {o o' m} [NF o], split' o = (o', m) → NF o' ∧ repr o = ω * repr o' + m
| 0            o' m h p := by injection p; substs o' m; simp [NF.zero]
| (oadd e n a) o' m h p := begin
  by_cases e0 : e = 0; simp [e0, split, split'] at p ⊢,
  { rcases p with ⟨rfl, rfl⟩,
    simp [h.zero_of_zero e0, NF.zero] },
  { revert p, cases h' : split' a with a' m',
    haveI := h.fst, haveI := h.snd,
    cases NF_repr_split' h' with IH₁ IH₂,
    simp [IH₂, split'],
    intros, substs o' m,
    have : ω ^ repr e = ω ^ (1 : ordinal.{0}) * ω ^ (repr e - 1),
    { have := mt repr_inj.1 e0,
      rw [← opow_add, ordinal.add_sub_cancel_of_le (one_le_iff_ne_zero.2 this)] },
    refine ⟨NF.oadd (by apply_instance) _ _, _⟩,
    { simp at this ⊢,
      refine IH₁.below_of_lt' ((mul_lt_mul_iff_left omega_pos).1 $
        lt_of_le_of_lt (le_add_right _ m') _),
      rw [← this, ← IH₂], exact h.snd'.repr_lt },
    { rw this, simp [ordinal.mul_add, mul_assoc, add_assoc] } }
end

theorem scale_eq_mul (x) [NF x] : ∀ o [NF o], scale x o = oadd x 1 0 * o
| 0            h := rfl
| (oadd e n a) h := begin
  simp [(*)], simp [mul, scale],
  haveI := h.snd,
  by_cases e0 : e = 0,
  { rw scale_eq_mul, simp [e0, h.zero_of_zero, show x + 0 = x, from repr_inj.1 (by simp)] },
  { simp [e0, scale_eq_mul, (*)] }
end

instance NF_scale (x) [NF x] (o) [NF o] : NF (scale x o) :=
by rw scale_eq_mul; apply_instance

@[simp] theorem repr_scale (x) [NF x] (o) [NF o] : repr (scale x o) = ω ^ repr x * repr o :=
by simp [scale_eq_mul]

theorem NF_repr_split {o o' m} [NF o] (h : split o = (o', m)) : NF o' ∧ repr o = repr o' + m :=
begin
  cases e : split' o with a n,
  cases NF_repr_split' e with s₁ s₂, resetI,
  rw split_eq_scale_split' e at h,
  injection h, substs o' n,
  simp [repr_scale, s₂.symm],
  apply_instance
end

theorem split_dvd {o o' m} [NF o] (h : split o = (o', m)) : ω ∣ repr o' :=
begin
  cases e : split' o with a n,
  rw split_eq_scale_split' e at h,
  injection h, subst o',
  cases NF_repr_split' e, resetI, simp
end

theorem split_add_lt {o e n a m} [NF o] (h : split o = (oadd e n a, m)) : repr a + m < ω ^ repr e :=
begin
  cases NF_repr_split h with h₁ h₂,
  cases h₁.of_dvd_omega (split_dvd h) with e0 d,
  have := h₁.fst, have := h₁.snd,
  apply principal_add_omega_opow _ h₁.snd'.repr_lt (lt_of_lt_of_le (nat_lt_omega _) _),
  simpa using opow_le_opow_right omega_pos (one_le_iff_ne_zero.2 e0),
end

@[simp] theorem mul_nat_eq_mul (n o) : mul_nat o n = o * of_nat n :=
by cases o; cases n; refl

instance NF_mul_nat (o) [NF o] (n) : NF (mul_nat o n) :=
by simp; apply_instance

instance NF_opow_aux (e a0 a) [NF e] [NF a0] [NF a] : ∀ k m, NF (opow_aux e a0 a k m)
| k     0     := by cases k; exact NF.zero
| 0     (m+1) := NF.oadd_zero _ _
| (k+1) (m+1) := by haveI := NF_opow_aux k;
  simp [opow_aux, nat.succ_ne_zero]; apply_instance

instance NF_opow (o₁ o₂) [NF o₁] [NF o₂] : NF (o₁ ^ o₂) :=
begin
  cases e₁ : split o₁ with a m,
  have na := (NF_repr_split e₁).1,
  cases e₂ : split' o₂ with b' k,
  haveI := (NF_repr_split' e₂).1,
  casesI a with a0 n a',
  { cases m with m,
    { by_cases o₂ = 0; simp [pow, opow, *]; apply_instance },
    { by_cases m = 0,
      { simp only [pow, opow, *, zero_def], apply_instance },
      { simp [pow, opow, *, - npow_eq_pow], apply_instance } } },
  { simp [pow, opow, e₁, e₂, split_eq_scale_split' e₂],
    have := na.fst,
    cases k with k; simp [succ_eq_add_one, opow]; resetI; apply_instance }
end

theorem scale_opow_aux (e a0 a : onote) [NF e] [NF a0] [NF a] :
  ∀ k m, repr (opow_aux e a0 a k m) = ω ^ repr e * repr (opow_aux 0 a0 a k m)
| 0     m := by cases m; simp [opow_aux]
| (k+1) m := by by_cases m = 0; simp [h, opow_aux,
  ordinal.mul_add, opow_add, mul_assoc, scale_opow_aux]

theorem repr_opow_aux₁ {e a} [Ne : NF e] [Na : NF a] {a' : ordinal}
  (e0 : repr e ≠ 0) (h : a' < ω ^ repr e) (aa : repr a = a') (n : ℕ+) :
  (ω ^ repr e * (n:ℕ) + a') ^ ω = (ω ^ repr e) ^ ω :=
begin
  subst aa,
  have No := Ne.oadd n (Na.below_of_lt' h),
  have := omega_le_oadd e n a, unfold repr at this,
  refine le_antisymm _ (opow_le_opow_left _ this),
  apply (opow_le_of_limit ((opow_pos _ omega_pos).trans_le this).ne' omega_is_limit).2,
  intros b l,
  have := (No.below_of_lt (lt_succ_self _)).repr_lt, unfold repr at this,
  apply (opow_le_opow_left b $ this.le).trans,
  rw [← opow_mul, ← opow_mul],
  apply opow_le_opow_right omega_pos,
  cases le_or_lt ω (repr e) with h h,
  { apply (mul_le_mul_left' (lt_succ_self _).le _).trans,
    rw [succ, add_mul_succ _ (one_add_of_omega_le h), ← succ,
        succ_le, mul_lt_mul_iff_left (ordinal.pos_iff_ne_zero.2 e0)],
    exact omega_is_limit.2 _ l },
  { apply (principal_mul_omega (omega_is_limit.2 _ h) l).le.trans,
    simpa using mul_le_mul_right' (one_le_iff_ne_zero.2 e0) ω }
end

section
local infixr ^ := @pow ordinal.{0} ordinal ordinal.has_pow

theorem repr_opow_aux₂ {a0 a'} [N0 : NF a0] [Na' : NF a'] (m : ℕ)
  (d : ω ∣ repr a')
  (e0 : repr a0 ≠ 0) (h : repr a' + m < ω ^ repr a0) (n : ℕ+) (k : ℕ) :
  let R := repr (opow_aux 0 a0 (oadd a0 n a' * of_nat m) k m) in
  (k ≠ 0 → R < (ω ^ repr a0) ^ succ k) ∧
  (ω ^ repr a0) ^ k * (ω ^ repr a0 * (n:ℕ) + repr a') + R =
    (ω ^ repr a0 * (n:ℕ) + repr a' + m) ^ succ k :=
begin
  intro,
  haveI No : NF (oadd a0 n a') :=
    N0.oadd n (Na'.below_of_lt' $ lt_of_le_of_lt (le_add_right _ _) h),
  induction k with k IH, {cases m; simp [opow_aux, R]},
  rename R R', let R := repr (opow_aux 0 a0 (oadd a0 n a' * of_nat m) k m),
  let ω0 := ω ^ repr a0, let α' := ω0 * n + repr a',
  change (k ≠ 0 → R < ω0 ^ succ k) ∧ ω0 ^ k * α' + R = (α' + m) ^ succ k at IH,
  have RR : R' = ω0 ^ k * (α' * m) + R,
  { by_cases m = 0; simp [h, R', opow_aux, R, opow_mul],
    { cases k; simp [opow_aux] }, { refl } },
  have α0 : 0 < α', {simpa [α', lt_def, repr] using oadd_pos a0 n a'},
  have ω00 : 0 < ω0 ^ k := opow_pos _ (opow_pos _ omega_pos),
  have Rl : R < ω ^ (repr a0 * succ ↑k),
  { by_cases k0 : k = 0,
    { simp [k0],
      refine lt_of_lt_of_le _ (opow_le_opow_right omega_pos (one_le_iff_ne_zero.2 e0)),
      cases m with m; simp [k0, R, opow_aux, omega_pos],
      rw [← nat.cast_succ], apply nat_lt_omega },
    { rw opow_mul, exact IH.1 k0 } },
  refine ⟨λ_, _, _⟩,
  { rw [RR, ← opow_mul _ _ (succ k.succ)],
    have e0 := ordinal.pos_iff_ne_zero.2 e0,
    have rr0 := lt_of_lt_of_le e0 (le_add_left _ _),
    apply principal_add_omega_opow,
    { simp [opow_mul, ω0, opow_add, mul_assoc],
      rw [mul_lt_mul_iff_left ω00, ← ordinal.opow_add],
      have := (No.below_of_lt _).repr_lt, unfold repr at this,
      refine mul_lt_omega_opow rr0 this (nat_lt_omega _),
      simpa using (add_lt_add_iff_left (repr a0)).2 e0 },
    { refine lt_of_lt_of_le Rl (opow_le_opow_right omega_pos $
        mul_le_mul_left' (succ_le_succ.2 (nat_cast_le.2 (le_of_lt k.lt_succ_self))) _) } },
  calc
        ω0 ^ k.succ * α' + R'
      = ω0 ^ succ k * α' + (ω0 ^ k * α' * m + R) : by rw [nat_cast_succ, RR, ← mul_assoc]
  ... = (ω0 ^ k * α' + R) * α' + (ω0 ^ k * α' + R) * m : _
  ... = (α' + m) ^ succ k.succ : by rw [← ordinal.mul_add, ← nat_cast_succ, opow_succ, IH.2],
  congr' 1,
  { have αd : ω ∣ α' := dvd_add (dvd_mul_of_dvd_left
      (by simpa using opow_dvd_opow ω (one_le_iff_ne_zero.2 e0)) _) d,
    rw [ordinal.mul_add (ω0 ^ k), add_assoc, ← mul_assoc, ← opow_succ,
        add_mul_limit _ (is_limit_iff_omega_dvd.2 ⟨ne_of_gt α0, αd⟩), mul_assoc,
        @mul_omega_dvd n (nat_cast_pos.2 n.pos) (nat_lt_omega _) _ αd],
    apply @add_absorp _ (repr a0 * succ k),
    { refine principal_add_omega_opow _ _ Rl,
      rw [opow_mul, opow_succ, mul_lt_mul_iff_left ω00],
      exact No.snd'.repr_lt },
    { have := mul_le_mul_left' (one_le_iff_pos.2 $ nat_cast_pos.2 n.pos) (ω0 ^ succ k),
      rw opow_mul, simpa [-opow_succ] } },
  { cases m,
    { have : R = 0, {cases k; simp [R, opow_aux]}, simp [this] },
    { rw [← nat_cast_succ, add_mul_succ],
      apply add_absorp Rl,
      rw [opow_mul, opow_succ],
      apply mul_le_mul_left',
      simpa [α', repr] using omega_le_oadd a0 n a' } }
end

end

theorem repr_opow (o₁ o₂) [NF o₁] [NF o₂] : repr (o₁ ^ o₂) = repr o₁ ^ repr o₂ :=
begin
  cases e₁ : split o₁ with a m,
  cases NF_repr_split e₁ with N₁ r₁,
  cases a with a0 n a',
  { cases m with m,
    { by_cases o₂ = 0; simp [opow_def, opow, e₁, h, r₁],
      have := mt repr_inj.1 h, rw zero_opow this },
    { cases e₂ : split' o₂ with b' k,
      cases NF_repr_split' e₂ with _ r₂,
      by_cases m = 0; simp [opow_def, opow, e₁, h, r₁, e₂, r₂, -nat.cast_succ],
      rw [opow_add, opow_mul, opow_omega _ (nat_lt_omega _)],
      simpa using nat_cast_lt.2 (nat.succ_lt_succ $ pos_iff_ne_zero.2 h) } },
  { haveI := N₁.fst, haveI := N₁.snd,
    cases N₁.of_dvd_omega (split_dvd e₁) with a00 ad,
    have al := split_add_lt e₁,
    have aa : repr (a' + of_nat m) = repr a' + m, {simp},
    cases e₂ : split' o₂ with b' k,
    cases NF_repr_split' e₂ with _ r₂,
    simp [opow_def, opow, e₁, r₁, split_eq_scale_split' e₂],
    cases k with k; resetI,
    { simp [opow, r₂, opow_mul, repr_opow_aux₁ a00 al aa, add_assoc] },
    { simp [succ_eq_add_one, opow, r₂, opow_add, opow_mul, mul_assoc, add_assoc],
      rw [repr_opow_aux₁ a00 al aa, scale_opow_aux], simp [opow_mul],
      rw [← ordinal.mul_add, ← add_assoc (ω ^ repr a0 * (n:ℕ))], congr' 1,
      rw [← opow_succ],
      exact (repr_opow_aux₂ _ ad a00 al _ _).2 } }
end

end onote

/-- The type of normal ordinal notations. (It would have been
  nicer to define this right in the inductive type, but `NF o`
  requires `repr` which requires `onote`, so all these things
  would have to be defined at once, which messes up the VM
  representation.) -/
def nonote := {o : onote // o.NF}

instance : decidable_eq nonote := by unfold nonote; apply_instance

namespace nonote
open onote

instance NF (o : nonote) : NF o.1 := o.2

/-- Construct a `nonote` from an ordinal notation
  (and infer normality) -/
def mk (o : onote) [h : NF o] : nonote := ⟨o, h⟩

/-- The ordinal represented by an ordinal notation.
  (This function is noncomputable because ordinal
  arithmetic is noncomputable. In computational applications
  `nonote` can be used exclusively without reference
  to `ordinal`, but this function allows for correctness
  results to be stated.) -/
noncomputable def repr (o : nonote) : ordinal := o.1.repr

instance : has_to_string nonote := ⟨λ x, x.1.to_string⟩
instance : has_repr nonote := ⟨λ x, x.1.repr'⟩

instance : preorder nonote :=
{ le       := λ x y, repr x ≤ repr y,
  lt       := λ x y, repr x < repr y,
  le_refl  := λ a, @le_refl ordinal _ _,
  le_trans := λ a b c, @le_trans ordinal _ _ _ _,
  lt_iff_le_not_le := λ a b, @lt_iff_le_not_le ordinal _ _ _ }

instance : has_zero nonote := ⟨⟨0, NF.zero⟩⟩
instance : inhabited nonote := ⟨0⟩

theorem wf : @well_founded nonote (<) := inv_image.wf repr ordinal.wf
instance : has_well_founded nonote := ⟨(<), wf⟩

/-- Convert a natural number to an ordinal notation -/
def of_nat (n : ℕ) : nonote := ⟨of_nat n, ⟨⟨_, NF_below_of_nat _⟩⟩⟩

/-- Compare ordinal notations -/
def cmp (a b : nonote) : ordering :=
cmp a.1 b.1

theorem cmp_compares : ∀ a b : nonote, (cmp a b).compares a b
| ⟨a, ha⟩ ⟨b, hb⟩ := begin
  resetI,
  dsimp [cmp], have := onote.cmp_compares a b,
  cases onote.cmp a b; try {exact this},
  exact subtype.mk_eq_mk.2 this
end

instance : linear_order nonote := linear_order_of_compares cmp cmp_compares

instance : is_well_order nonote (<) := ⟨wf⟩

/-- Asserts that `repr a < ω ^ repr b`. Used in `nonote.rec_on` -/
def below (a b : nonote) : Prop := NF_below a.1 (repr b)

/-- The `oadd` pseudo-constructor for `nonote` -/
def oadd (e : nonote) (n : ℕ+) (a : nonote) (h : below a e) : nonote := ⟨_, NF.oadd e.2 n h⟩

/-- This is a recursor-like theorem for `nonote` suggesting an
  inductive definition, which can't actually be defined this
  way due to conflicting dependencies. -/
@[elab_as_eliminator] def rec_on {C : nonote → Sort*} (o : nonote)
  (H0 : C 0)
  (H1 : ∀ e n a h, C e → C a → C (oadd e n a h)) : C o :=
begin
  cases o with o h, induction o with e n a IHe IHa,
  { exact H0 },
  { exact H1 ⟨e, h.fst⟩ n ⟨a, h.snd⟩ h.snd' (IHe _) (IHa _) }
end

/-- Addition of ordinal notations -/
instance : has_add nonote := ⟨λ x y, mk (x.1 + y.1)⟩

theorem repr_add (a b) : repr (a + b) = repr a + repr b :=
onote.repr_add a.1 b.1

/-- Subtraction of ordinal notations -/
instance : has_sub nonote := ⟨λ x y, mk (x.1 - y.1)⟩

theorem repr_sub (a b) : repr (a - b) = repr a - repr b :=
onote.repr_sub a.1 b.1

/-- Multiplication of ordinal notations -/
instance : has_mul nonote := ⟨λ x y, mk (x.1 * y.1)⟩

theorem repr_mul (a b) : repr (a * b) = repr a * repr b :=
onote.repr_mul a.1 b.1

/-- Exponentiation of ordinal notations -/
def opow (x y : nonote) := mk (x.1.opow y.1)

theorem repr_opow (a b) : repr (opow a b) = (repr a).opow (repr b) :=
onote.repr_opow a.1 b.1

end nonote


/-
Copyright (c) 2023 Tian Chen. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Tian Chen
-/

import ineq.majorize
import matrix.doubly_stochastic.basic
import algebra.order.group.min_max
import tactic.ring

open_locale big_operators

open finset

variables {α : Type*} [linear_ordered_field α] [@decidable_rel α (<)]

section

variables {n β : Type*} [linear_order n] [add_comm_monoid β]
variables (a : n) (s : finset n) (p : n → β)

private lemma sum_lt_le₁ :
  ∑ i in s, p i =
  ∑ i in s.filter (λ i, a ≤ i), p i +
  ∑ i in s.filter (λ i, i < a), p i :=
by simp_rw [← not_lt]; rw [add_comm, ← sum_ite]; simp_rw [if_t_t]

private lemma sum_lt_le₂ :
  ∑ i in s, p i =
  ∑ i in s.filter (λ i, a < i), p i +
  ∑ i in s.filter (λ i, i ≤ a), p i :=
by simp_rw [← not_lt, ← sum_ite, if_t_t]

example (P Q : Prop) (h : P → Q) : Q ∧ P ↔ P := and_iff_right_of_imp h

private lemma sum_lt_le₃ :
  ∑ i in s.filter (λ i, a ≤ i), p i =
  ∑ i in s.filter (λ i, a < i), p i +
  ∑ i in s.filter (λ i, i = a), p i :=
by rw [sum_lt_le₂ a, filter_filter, filter_filter];
  simp_rw [le_antisymm_iff, and_iff_right_of_imp (le_of_lt), and_comm]

end

private lemma and_imp_imp {a b c d e f : Prop} (h₁ : a → b → c) (h₂ : d → e → f) :
  (a ∧ d) → (b ∧ e) → (c ∧ f) := by itauto

lemma exists_fn_lt
  {n} (p q : fin n → α) (hpq : p ≠ q)
  (hp : antitone p)
  (hq : antitone q)
  (h₁ : ∑ i, p i = ∑ i, q i)
  (h₂ : ∀ i, ((list.of_fn q).take i).sum ≤ ((list.of_fn p).take i).sum) :
  ∃ p' : fin n → α,
    antitone p' ∧
    ∑ i, p' i = ∑ i, p i ∧
    (∀ i, ((list.of_fn q).take i).sum ≤ ((list.of_fn p').take i).sum ∧
      ((list.of_fn p').take i).sum ≤ ((list.of_fn p).take i).sum) ∧
    (univ.filter (λ i, p' i ≠ q i)).card <
    (univ.filter (λ i, p i ≠ q i)).card ∧
    ∃ M : matrix (fin n) (fin n) α,
      M.doubly_stochastic ∧
      p' = M.mul_vec p :=
begin
  obtain ⟨k, l, hkl, hqpk, hqpl, h⟩ := exists_lt_eq_gt hpq.symm h₁.symm h₂,
  have hqlk := hq hkl.le,
  set b := (p k + p l) / 2 with hb,
  set d := (p k - p l) / 2 with hd,
  set c := max (|q k - b|) (|q l - b|) with hc,
  have hbd₁ : b + d = p k,
  { rw [← add_div, add_add_sub_cancel, half_add_self] },
  have hbd₂ : b - d = p l,
  { rw [← sub_div, add_sub_sub_cancel, half_add_self] },
  have h0c : 0 ≤ c,
  { rw le_max_iff,
    left,
    exact abs_nonneg _ },
  have hcd : c < d,
   { rw [eq_comm, max_eq_iff] at hc,
    cases hc;
    rw [← hc.1, abs_lt, sub_lt_iff_lt_add', hbd₁,
      lt_sub_iff_add_lt', ← sub_eq_add_neg, hbd₂],
    { exact ⟨lt_of_lt_of_le hqpl hqlk, hqpk⟩ },
    { exact ⟨hqpl, lt_of_le_of_lt hqlk hqpk⟩ } },
  have hkbc₁ : b + c < p k := hbd₁ ▸ add_lt_add_left hcd b,
  have hkbc₂ : q k ≤ b + c,
  { rw [eq_comm, max_eq_iff] at hc,
    cases hc;
    rw [← hc.1, ← sub_le_iff_le_add'],
    { exact le_abs_self _ },
    { exact (le_abs_self _).trans hc.2 } },
  have hlbc₁ : p l < b - c := hbd₂ ▸ sub_lt_sub_left hcd b,
  have hlbc₂ : b - c ≤ q l,
  { rw [eq_comm, max_eq_iff] at hc,
    cases hc;
    rw [← hc.1, sub_le_comm, ← neg_sub],
    { exact (neg_le_abs_self _).trans hc.2 },
    { exact neg_le_abs_self _ } },
  let p' := λ j, ite (j = k) (b + c) (ite (j = l) (b - c) (p j)),
  have hp' : ∀ j, p' j = ite _ _ _ := λ _, rfl,
  have hk' : k ∈ univ.filter (λ x, ¬x = l) := mem_filter.2 ⟨mem_univ _, hkl.ne⟩,
  have hl' : l ∈ univ.filter (λ x, ¬x = k) := mem_filter.2 ⟨mem_univ _, hkl.ne.symm⟩,
  use p',
  refine ⟨_, _, _, _, _⟩,
  { intros i j hij,
    show ite _ _ _ ≤ ite _ _ _,
    split_ifs with h₁ h₂ h₃ h₄ h₅ h₆ h₇ h₈,
    { exact le_refl _ },
    { exfalso,
      rw [h₁, h₃] at hij,
      exact hkl.not_le hij },
    { rw h₁ at hij,
      exact hkbc₁.le.trans (hp hij) },
    { rw [sub_eq_add_neg, add_le_add_iff_left],
      exact neg_le_self h0c },
    { exact le_refl _ },
    { rw h₄ at hij,
      by_contra' h',
      have : k < i := hp.reflect_lt (
        calc p i < b - c : h'
        ... ≤ q l : hlbc₂
        ... ≤ q k : hqlk
        ... < p k : hqpk),
      rw ← h _ this (lt_of_le_of_ne hij h₆) at h',
      exact (lt_of_le_of_lt (hq hij) h').not_le hlbc₂ },
    { rw h₇ at hij,
      by_contra' h',
      have : j < l := hp.reflect_lt (
        calc p l < q l : hqpl
        ... ≤ q k : hqlk
        ... ≤ b + c : hkbc₂
        ... < p j : h' ),
      rw ← h _ (lt_of_le_of_ne' hij h₁) this at h',
      exact (lt_of_lt_of_le h' (hq hij)).not_le hkbc₂ },
    { rw h₈ at hij,
      exact (hp hij).trans hlbc₁.le },
    { exact hp hij } },
  { calc  ∑ i, ite (i = k) (b + c) (ite (i = l) (b - c) (p i))
        = (b + c) + ∑ i in univ.filter (λ i, ¬i = k), ite (i = l) (b - c) (p i) :
            by rw [sum_ite, filter_eq', if_pos (mem_univ _), sum_singleton]
    ... = p k + p l +
          ∑ i in (univ.filter (λ i, ¬i = k)).filter (λ i, ¬i = l), p i :
            by rw [sum_ite, filter_eq', if_pos hl', sum_singleton,
              ← add_assoc, add_add_sub_cancel, add_halves]
    ... = ∑ i in univ.filter (λ i, i = k), p i +
          ∑ i in (univ.filter (λ i, ¬i = k)).filter (λ i, i = l), p i +
          ∑ i in (univ.filter (λ i, ¬i = k)).filter (λ i, ¬i = l), p i :
            by rw [filter_eq', if_pos (mem_univ _), sum_singleton,
              filter_eq', if_pos hl', sum_singleton]
    ... = ∑ i, p i :
            by rw [add_assoc, ← sum_ite, ← sum_ite];
              simp_rw [if_t_t] },
  { have hp'₁ : ∀ {j}, j < k → p' j = p j,
    { intros j hj,
      rw [hp', if_neg hj.ne, if_neg (hj.trans hkl).ne] },
    have hp'₂ : ∀ {j}, l < j → p' j = p j,
    { intros j hj,
      rw [hp', if_neg (hkl.trans hj).ne', if_neg hj.ne'] },
    have hp'₃ : ∀ {j}, k < j → j < l → p' j = p j,
    { intros j hkj hjl,
      rw [hp', if_neg hkj.ne', if_neg hjl.ne] },
    have h_sum₁ : ∀ i : ℕ, i ≤ k →
      ∑ j in univ.filter (λ j, ↑j < i), p' j =
      ∑ j in univ.filter (λ j, ↑j < i), p j,
    { intros i hik,
      apply sum_congr rfl,
      intros j hj,
      rw mem_filter at hj,
      exact hp'₁ (show ↑j < ↑k, from lt_of_lt_of_le hj.2 hik) },
    have h_sum₂ :
      ∑ j in univ.filter (λ j, j ≤ l), p' j
      = ∑ j in univ.filter (λ j, j ≤ l), p j,
    { let s := univ.filter (λ j, j ≤ l),
      have hk : k ∈ s := mem_filter.2 ⟨mem_univ _, hkl.le⟩,
      have hl : l ∈ s.filter (λ j, ¬j = k) :=
        mem_filter.2 ⟨mem_filter.2 ⟨mem_univ _, le_rfl⟩, hkl.ne.symm⟩,
      calc  ∑ (j : fin n) in s, p' j
          = p k + p l + ∑ i in (s.filter (λ j, ¬j = k)).filter (λ j, ¬j = l), p i :
              by rw [sum_ite, filter_eq', if_pos hk, sum_singleton,
                sum_ite, filter_eq', if_pos hl, sum_singleton, ← add_assoc,
                add_add_sub_cancel, add_halves]
      ... = ∑ i in s.filter (λ j, j = k), p i +
            ∑ i in (s.filter (λ j, ¬j = k)).filter (λ j, j = l), p i +
            ∑ i in (s.filter (λ j, ¬j = k)).filter (λ j, ¬j = l), p i :
              by rw [filter_eq', if_pos hk, sum_singleton,
                filter_eq', if_pos hl, sum_singleton]
      ... = ∑ (j : fin n) in s, p j :
              by rw [add_assoc, ← sum_ite, ← sum_ite];
                simp_rw [if_t_t] },
    intros i,
    simp_rw [list.sum_take_of_fn] at ⊢ h₂,
    let s := univ.filter (λ j : fin n, ↑j < i),
    show ∑ _ in s, _ ≤ ∑ _ in s, p' _ ∧ ∑ _ in s, p' _ ≤ ∑ _ in s, _,
    rcases le_or_lt i k with hik | hki,
    { rw h_sum₁ _ hik,
      exact ⟨h₂ _, le_rfl⟩ },
    rcases le_or_lt i l with hil | hli,
    { have : k ∈ s := mem_filter.2 ⟨mem_univ _, hki⟩,
      iterate 3 { rw [sum_lt_le₁ k s, sum_lt_le₃, filter_eq', if_pos this, sum_singleton] },
      rw [hp' k, if_pos rfl],
      iterate { rw filter_filter },
      refine and_imp_imp add_le_add add_le_add _ _,
      refine and_imp_imp add_le_add add_le_add _ ⟨hkbc₂, hkbc₁.le⟩,
      { apply and.imp sum_le_sum sum_le_sum,
        rw ← forall_and_distrib,
        intro j,
        rw ← forall_and_distrib,
        intro hj,
        rw mem_filter at hj,
        have hjl : j < l := show ↑j < ↑l, from (lt_of_lt_of_le hj.2.1 hil),
        rw [hp'₃ hj.2.2 hjl, h _ hj.2.2 hjl],
        exact ⟨le_rfl, le_rfl⟩ },
      { simp_rw [fin.lt_iff_coe_lt_coe, ← lt_min_iff],
        rw h_sum₁ _ (min_le_right i k),
        exact ⟨h₂ _, le_rfl⟩ } },
    { iterate 3 { rw sum_lt_le₂ l s },
      iterate { rw filter_filter },
      have ha₁ : ∀ a, ↑a < i ∧ a ≤ l ↔ a ≤ l :=
        λ a, and_iff_right_of_imp (λ h, lt_of_le_of_lt h hli),
      simp_rw [ha₁],
      rw h_sum₂,
      convert and.intro (h₂ i) le_rfl using 2,
      all_goals { try {
        show _ = ∑ _ in s, _,
        rw sum_lt_le₂ l s,
        iterate { rw filter_filter },
        simp_rw [ha₁] } },
      all_goals { rw add_left_inj,
        apply sum_congr rfl,
        intros j hj,
        rw mem_filter at hj,
        rw hp'₂ hj.2.2 } } },
  { apply card_lt_card,
    rw ssubset_iff,
    have hc' : b + c = q k ∨ b - c = q l,
    { cases le_total (q k) b with hqkb hbqk,
      { have := abs_eq_neg_self.2 (sub_nonpos_of_le (hqlk.trans hqkb)),
        right,
        rw [hc, max_eq_right, this, sub_neg_eq_add, add_sub_cancel'_right],
        rw [this, abs_eq_neg_self.2 (sub_nonpos_of_le hqkb)],
        apply neg_le_neg,
        rwa sub_le_sub_iff_right },
      cases le_total b (q l) with hbql hqlb,
      { have := abs_eq_self.2 (sub_nonneg_of_le (hbql.trans hqlk)),
        left,
        rw [hc, max_eq_left, this, add_sub_cancel'_right],
        rw [this, abs_eq_self.2 (sub_nonneg_of_le hbql)],
        rwa sub_le_sub_iff_right },
      { rw [abs_eq_self.2 (sub_nonneg_of_le hbqk),
          abs_eq_neg_self.2 (sub_nonpos_of_le hqlb),
          neg_sub, eq_comm, max_eq_iff] at hc,
        cases hc;
        rw ← hc.1,
        { left,
          rw add_sub_cancel'_right },
        { right,
          rw sub_sub_cancel } } },
    cases hc',
    use k, swap, use l,
    all_goals { rw [mem_filter, insert_subset, mem_filter, subset_iff, ← hc'] },
    refine ⟨λ h', h'.2 _, ⟨mem_univ _, hlbc₁.ne⟩, _⟩,
    { rw [hp', if_neg hkl.ne.symm, if_pos rfl] },
    swap,
    refine ⟨λ h', h'.2 (if_pos rfl), ⟨mem_univ _, hkbc₁.ne.symm⟩, _⟩,
    all_goals { intros i hi,
      rw mem_filter at ⊢ hi,
      refine ⟨mem_univ _, _⟩,
      intros hi',
      apply hi.2,
      rw [← hi', hp', if_neg, if_neg] },
    all_goals { rintro rfl },
    repeat { exact hqpl.ne hi' },
    repeat { exact hqpk.ne hi'.symm } },
  { let M : matrix (fin n) (fin n) α := λ i j,
      if i = k ∧ j = l ∨ i = l ∧ j = k then (d - c) / (2 * d) else
        if i = j then (if i = k ∨ i = l then (d + c) / (2 * d) else 1) else 0,
    have hM : ∀ i j, M i j = ite _ _ _ := λ i j, rfl,
    have h0d : 0 < d := lt_of_le_of_lt h0c hcd,
    have h02d : 0 < 2 * d := mul_pos zero_lt_two h0d,
    use M,
    split,
    apply matrix.doubly_stochastic.of_transpose_eq_self,
    { ext i j,
      show ite _ _ _ = ite _ _ _,
      congr' 1,
      { rw [and_comm, or_comm, and_comm] },
      { by_cases hij : i = j,
        { rw hij },
        { rw [if_neg hij, if_neg (ne.symm hij)] } } },
    { intros i j,
      rw hM,
      split_ifs,
      { exact div_nonneg (sub_nonneg_of_le hcd.le) h02d.le },
      { exact div_nonneg (add_nonneg h0d.le h0c) h02d.le },
      { exact zero_le_one },
      { exact le_rfl } },
    { intro i,
      have hdc : (d - c) / (2 * d) + (d + c) / (2 * d) = 1,
      { rw [← add_div, sub_add_add_cancel, ← two_mul, div_self h02d.ne.symm] },
      rw [sum_ite, sum_ite, sum_ite, sum_const_zero, add_zero, sum_const, sum_const, sum_const],
      by_cases hik : i = k,
      simp_rw [hik, hkl.ne, eq_self_iff_true, true_and, false_and, or_false, not_true],
      swap,
      by_cases hil : i = l,
      simp_rw [hil, hkl.ne.symm, eq_self_iff_true, true_and, false_and, false_or, not_true],
      swap,
      { simp_rw [hik, hil, false_and, false_or, not_false_iff],
        iterate 2 { rw [filter_false, card_empty, zero_smul, zero_add, filter_true] },
        rw [filter_eq, if_pos (mem_univ _), card_singleton, one_smul] },
      all_goals {
        rw [filter_true, filter_false, card_empty, zero_smul, add_zero,
          filter_eq', if_pos (mem_univ _), card_singleton, one_smul,
          filter_eq, if_pos (mem_filter.2 ⟨mem_univ _, _⟩), card_singleton, one_smul, hdc] },
      { exact hkl.ne.symm },
      { exact hkl.ne } },
    { ext i,
      have hdc₁ : (d - c) / (2 * d) * p l + (d + c) / (2 * d) * p k = b + c,
      swap,
      have hdc₂ : (d - c) / (2 * d) * p k + (d + c) / (2 * d) * p l = b - c,
      all_goals { try {
        rw [← mul_div_right_comm, ← mul_div_right_comm,
          ← add_div, div_eq_iff h02d.ne.symm, hb, hd],
        ring } },
      rw [matrix.mul_vec, matrix.dot_product, hp'],
      simp_rw [hM, ite_mul, one_mul, zero_mul],
      rw [sum_ite, sum_ite, sum_ite, sum_const_zero, add_zero, ← mul_sum, ← mul_sum],
      split_ifs with hik hil,
      { simp_rw [hik, hkl.ne, eq_self_iff_true, true_and, true_or, false_and, or_false, not_true],
        rw [filter_false, sum_empty, add_zero,
          filter_true, filter_eq', if_pos (mem_univ _), sum_singleton,
          filter_eq, if_pos hk', sum_singleton, hdc₁] },
      { simp_rw [hil, hkl.ne.symm, eq_self_iff_true, true_and, or_true,
          false_and, false_or, not_true],
        rw [filter_false, sum_empty, add_zero,
          filter_true, filter_eq', if_pos (mem_univ _), sum_singleton,
          filter_eq, if_pos hl', sum_singleton, hdc₂] },
      { simp_rw [hik, hil, false_and, false_or, not_false_iff],
        iterate 2 { rw [filter_false, sum_empty, mul_zero, filter_true, zero_add] },
        rw [filter_eq, if_pos (mem_univ _), sum_singleton] } } }
end


/-
Copyright (c) 2022 Bhavik Mehta. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Bhavik Mehta
-/

import analysis.special_functions.integrals
import analysis.special_functions.pow
import measure_theory.integral.integral_eq_improper

noncomputable theory

open_locale big_operators nnreal filter topological_space

open asymptotics filter set real measure_theory

lemma integral_Ioi_rpow_tendsto_aux {a r : ℝ} (hr : r < -1) (ha : 0 < a)
  {ι : Type*} {b : ι → ℝ} {l : filter ι} (hb : tendsto b l at_top) :
  tendsto (λ i, ∫ x in a..b i, x ^ r) l (nhds (-a ^ (r + 1) / (r + 1))) :=
begin
  suffices :
    tendsto (λ i, ∫ x in a..b i, x ^ r) l (nhds (0 / (r + 1) - a ^ (r + 1) / (r + 1))),
  { simpa [neg_div] using this },
  have : ∀ᶠ i in l, ∫ x in a..b i, x ^ r = (b i) ^ (r + 1) / (r + 1) - a ^ (r + 1) / (r + 1),
  { filter_upwards [hb.eventually (eventually_ge_at_top a)],
    intros i hi,
    rw [←sub_div, ←integral_rpow (or.inr ⟨hr.ne, not_mem_interval_of_lt ha (ha.trans_le hi)⟩)], },
  rw tendsto_congr' this,
  refine tendsto.sub_const _ (tendsto.div_const _),
  rw ←neg_neg (r+1),
  apply (tendsto_rpow_neg_at_top _).comp hb,
  simpa using hr
end

-- TODO: Move to mathlib
lemma integrable_on_rpow_Ioi {a r : ℝ} (hr : r < -1) (ha : 0 < a) :
  integrable_on (λ x, x ^ r) (Ioi a) :=
begin
  have hb : tendsto (λ (x : ℝ≥0), a + x) at_top at_top :=
    tendsto_at_top_add_const_left _ _ (nnreal.tendsto_coe_at_top.2 tendsto_id),
  have : tendsto (λ (i : ℝ≥0), ∫ x in a..(a + i), ∥x ^ r∥) at_top (nhds (-a ^ (r + 1) / (r + 1))),
  { refine (integral_Ioi_rpow_tendsto_aux hr ha hb).congr (λ x, _),
    refine interval_integral.integral_congr (λ i hi, _),
    apply (real.norm_of_nonneg (real.rpow_nonneg_of_nonneg _ _)).symm,
    exact ha.le.trans ((by simp : _ ≤ _).trans hi.1) },
  refine integrable_on_Ioi_of_interval_integral_norm_tendsto _ _ (λ i, _) hb this,
  refine (continuous_on.integrable_on_Icc _).mono_set Ioc_subset_Icc_self,
  exact continuous_on_id.rpow_const (λ x hx, or.inl (ha.trans_le hx.1).ne'),
end

-- TODO: Move to mathlib
lemma integral_rpow_Ioi {a r : ℝ} (hr : r < -1) (ha : 0 < a) :
  ∫ x in Ioi a, x ^ r = - a ^ (r + 1) / (r + 1) :=
tendsto_nhds_unique
  (interval_integral_tendsto_integral_Ioi _ (integrable_on_rpow_Ioi hr ha) tendsto_id)
  (integral_Ioi_rpow_tendsto_aux hr ha tendsto_id)

-- TODO: Move to mathlib
lemma integrable_on_rpow_inv_Ioi {a r : ℝ} (hr : 1 < r) (ha : 0 < a) :
  integrable_on (λ x, (x ^ r)⁻¹) (Ioi a) :=
(integrable_on_rpow_Ioi (neg_lt_neg hr) ha).congr_fun (λ x hx, rpow_neg (ha.trans hx).le _)
  measurable_set_Ioi

-- TODO: Move to mathlib
lemma integral_rpow_inv {a r : ℝ} (hr : 1 < r) (ha : 0 < a) :
  ∫ x in Ioi a, (x ^ r)⁻¹ = a ^ (1 - r) / (r - 1) :=
begin
  rw [←set_integral_congr, integral_rpow_Ioi (neg_lt_neg hr) ha, neg_div, ←div_neg, neg_add',
    neg_neg, neg_add_eq_sub],
  { apply measurable_set_Ioi },
  exact λ x hx, (rpow_neg (ha.trans hx).le _)
end

-- TODO: Move to mathlib
lemma integrable_on_zpow_Ioi {a : ℝ} {n : ℤ} (hn : n < -1) (ha : 0 < a) :
  integrable_on (λ x, x ^ n) (Ioi a) :=
by exact_mod_cast integrable_on_rpow_Ioi (show (n : ℝ) < -1, by exact_mod_cast hn) ha

-- TODO: Move to mathlib
lemma integral_zpow_Ioi {a : ℝ} {n : ℤ} (hn : n < -1) (ha : 0 < a) :
  ∫ x in Ioi a, x ^ n = - a ^ (n + 1) / (n + 1) :=
by exact_mod_cast integral_rpow_Ioi (show (n : ℝ) < -1, by exact_mod_cast hn) ha

-- TODO: Move to mathlib
lemma integrable_on_zpow_inv_Ioi {a : ℝ} {n : ℤ} (hn : 1 < n) (ha : 0 < a) :
  integrable_on (λ x, (x ^ n)⁻¹) (Ioi a) :=
(integrable_on_zpow_Ioi (neg_lt_neg hn) ha).congr_fun (by simp) measurable_set_Ioi

-- TODO: Move to mathlib
lemma integral_zpow_inv_Ioi {a : ℝ} {n : ℤ} (hn : 1 < n) (ha : 0 < a) :
  ∫ x in Ioi a, (x ^ n)⁻¹ = a ^ (1 - n) / (n - 1) :=
begin
  simp_rw [←zpow_neg, integral_zpow_Ioi (neg_lt_neg hn) ha, neg_div, ←div_neg, neg_add',
    int.cast_neg, neg_neg, neg_add_eq_sub],
end

-- TODO: Move to mathlib
lemma integrable_on_pow_inv_Ioi {a : ℝ} {n : ℕ} (hn : 1 < n) (ha : 0 < a) :
  integrable_on (λ x, (x ^ n)⁻¹) (Ioi a) :=
by exact_mod_cast integrable_on_zpow_inv_Ioi (show 1 < (n : ℤ), by exact_mod_cast hn) ha

-- TODO: Move to mathlib
lemma integral_pow_inv_Ioi {a : ℝ} {n : ℕ} (hn : 1 < n) (ha : 0 < a) :
  ∫ x in Ioi a, (x ^ n)⁻¹ = (a ^ (n - 1))⁻¹ / (n - 1) :=
by simp_rw [←zpow_coe_nat, integral_zpow_inv_Ioi (show 1 < (n : ℤ), by exact_mod_cast hn) ha,
  int.cast_coe_nat, ←zpow_neg, int.coe_nat_sub hn.le, neg_sub, int.coe_nat_one]


import NBG.SetTheory.Defs
import NBG.SetTheory.Axioms.Pair

open Classical

-- 5. AxiomProduct
axiom AxiomProduct :
  ∀X Y: Class, ∃Z: Class,
    ∀z: Class, (z∈Z ↔ ∃x y: Class, ∃hx: x ∈ X,∃hy: y ∈ Y,
      (z ＝ (@OrdPair_mk x y (Set.mk₁ hx) (Set.mk₁ hy))))
noncomputable def ProductClass_mk (X Y: Class) : Class :=
  choose (AxiomProduct X Y)
noncomputable instance : HasProduct Class where
  Product := ProductClass_mk
noncomputable def ProductClass_def (X Y: Class):
  ∀z: Class, (z ∈ (ProductClass_mk X Y) ↔ ∃x y: Class, ∃hx: x ∈ X,∃hy: y ∈ Y,
    (z ＝ (@OrdPair_mk x y (Set.mk₁ hx) (Set.mk₁ hy)))) :=
  choose_spec (AxiomProduct X Y)
noncomputable def U₂ := ProductClass_mk U U
noncomputable def U₃ := ProductClass_mk U₂ U

-- Todo: ProductClassIntro

-- theorem SetProductIsSet (x y : Class) [Set x] [Set y]: isSet (x ✕ y) :=
--   sorry
-- noncomputable def SetProductSet (x y : Class) [Set x] [Set y] : Set (x ✕ y) :=
--   Set.mk (SetProductIsSet x y) (AllSetInU.1 (SetProductIsSet x y))

-- Relation type
def isRelation (R : Class) : Prop :=
  ∀z: Class, z∈R → ∃x y: Class, ∃_: Set x, ∃_: Set y,
    (z ＝ ＜x, y＞)
class Relation (R : Class) where
  isRelation: isRelation R

-- Function type
def isFunction (F : Class) [Relation F] : Prop :=
  ∀x x' y y': Class, ∀_: Set x, ∀_: Set x', ∀_: Set y, ∀_: Set y',
    ＜x, y＞ ∈ F → ＜x', y'＞ ∈ F → x ＝x' → y ＝ y'
class Function (F : Class) extends Relation F where
  isFunction : isFunction F


/-
Copyright (c) Sidharth Hariharan. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Kevin Buzzard, Sidharth Hariharan

! This file was ported from Lean 3 source module data.polynomial.partial_fractions
! leanprover-community/mathlib commit 6e70e0d419bf686784937d64ed4bfde866ff229e
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.Data.Polynomial.Div
import Mathbin.Data.Zmod.Basic
import Mathbin.Logic.Function.Basic
import Mathbin.RingTheory.Localization.FractionRing
import Mathbin.Tactic.FieldSimp
import Mathbin.Tactic.LinearCombination

/-!

# Partial fractions

These results were formalised by the Xena Project, at the suggestion
of Patrick Massot.

# The main theorem

* `div_eq_quo_add_sum_rem_div`: General partial fraction decomposition theorem for polynomials over
  an integral domain R :
  If f, g₁, g₂, ..., gₙ ∈ R[X] and the gᵢs are all monic and pairwise coprime, then ∃ q, r₁, ..., rₙ
  ∈ R[X] such that f / g₁g₂...gₙ = q + r₁/g₁ + ... + rₙ/gₙ and for all i, deg(rᵢ) < deg(gᵢ).

* The result is formalized here in slightly more generality, using finsets. That is, if ι is an
  arbitrary index type, g denotes a map from ι to R[X], and if s is an arbitrary finite subset of ι,
  with g i monic for all i ∈ s and for all i,j ∈ s, i ≠ j → g i is coprime to g j, then we have
  ∃ q ∈ R[X] , r : ι → R[X] such that ∀ i ∈ s, deg(r i) < deg(g i) and
  f / ∏ g i = q + ∑ (r i) / (g i), where the product and sum are over s.

* The proof is done by proving the two-denominator case and then performing finset induction for an
  arbitrary (finite) number of denominators.

## Scope for Expansion

* Proving uniqueness of the decomposition

-/

variable (R : Type) [CommRing R] [IsDomain R]

open Polynomial

open Polynomial

variable (K : Type) [Field K] [Algebra R[X] K] [IsFractionRing R[X] K]

section TwoDenominators

/- warning: div_eq_quo_add_rem_div_add_rem_div -> div_eq_quo_add_rem_div_add_rem_div is a dubious translation:
lean 3 declaration is
  forall (R : Type) [_inst_1 : CommRing.{0} R] [_inst_2 : IsDomain.{0} R (Ring.toSemiring.{0} R (CommRing.toRing.{0} R _inst_1))] (K : Type) [_inst_3 : Field.{0} K] [_inst_4 : Algebra.{0, 0} (Polynomial.{0} R (Ring.toSemiring.{0} R (CommRing.toRing.{0} R _inst_1))) K (Polynomial.commSemiring.{0} R (CommRing.toCommSemiring.{0} R _inst_1)) (Ring.toSemiring.{0} K (DivisionRing.toRing.{0} K (Field.toDivisionRing.{0} K _inst_3)))] [_inst_5 : IsFractionRing.{0, 0} (Polynomial.{0} R (Ring.toSemiring.{0} R (CommRing.toRing.{0} R _inst_1))) (Polynomial.commRing.{0} R _inst_1) K (Field.toCommRing.{0} K _inst_3) _inst_4] (f : Polynomial.{0} R (Ring.toSemiring.{0} R (CommRing.toRing.{0} R _inst_1))) {g₁ : Polynomial.{0} R (Ring.toSemiring.{0} R (CommRing.toRing.{0} R _inst_1))} {g₂ : Polynomial.{0} R (Ring.toSemiring.{0} R (CommRing.toRing.{0} R _inst_1))}, (Polynomial.Monic.{0} R (Ring.toSemiring.{0} R (CommRing.toRing.{0} R _inst_1)) g₁) -> (Polynomial.Monic.{0} R (Ring.toSemiring.{0} R (CommRing.toRing.{0} R _inst_1)) g₂) -> (IsCoprime.{0} (Polynomial.{0} R (Ring.toSemiring.{0} R (CommRing.toRing.{0} R _inst_1))) (Polynomial.commSemiring.{0} R (CommRing.toCommSemiring.{0} R _inst_1)) g₁ g₂) -> (Exists.{1} (Polynomial.{0} R (Ring.toSemiring.{0} R (CommRing.toRing.{0} R _inst_1))) (fun (q : Polynomial.{0} R (Ring.toSemiring.{0} R (CommRing.toRing.{0} R _inst_1))) => Exists.{1} (Polynomial.{0} R (Ring.toSemiring.{0} R (CommRing.toRing.{0} R _inst_1))) (fun (r₁ : Polynomial.{0} R (Ring.toSemiring.{0} R (CommRing.toRing.{0} R _inst_1))) => Exists.{1} (Polynomial.{0} R (Ring.toSemiring.{0} R (CommRing.toRing.{0} R _inst_1))) (fun (r₂ : Polynomial.{0} R (Ring.toSemiring.{0} R (CommRing.toRing.{0} R _inst_1))) => And (LT.lt.{0} (WithBot.{0} Nat) (Preorder.toLT.{0} (WithBot.{0} Nat) (WithBot.preorder.{0} Nat (PartialOrder.toPreorder.{0} Nat (OrderedCancelAddCommMonoid.toPartialOrder.{0} Nat (StrictOrderedSemiring.toOrderedCancelAddCommMonoid.{0} Nat Nat.strictOrderedSemiring))))) (Polynomial.degree.{0} R (Ring.toSemiring.{0} R (CommRing.toRing.{0} R _inst_1)) r₁) (Polynomial.degree.{0} R (Ring.toSemiring.{0} R (CommRing.toRing.{0} R _inst_1)) g₁)) (And (LT.lt.{0} (WithBot.{0} Nat) (Preorder.toLT.{0} (WithBot.{0} Nat) (WithBot.preorder.{0} Nat (PartialOrder.toPreorder.{0} Nat (OrderedCancelAddCommMonoid.toPartialOrder.{0} Nat (StrictOrderedSemiring.toOrderedCancelAddCommMonoid.{0} Nat Nat.strictOrderedSemiring))))) (Polynomial.degree.{0} R (Ring.toSemiring.{0} R (CommRing.toRing.{0} R _inst_1)) r₂) (Polynomial.degree.{0} R (Ring.toSemiring.{0} R (CommRing.toRing.{0} R _inst_1)) g₂)) (Eq.{1} K (HDiv.hDiv.{0, 0, 0} K K K (instHDiv.{0} K (DivInvMonoid.toHasDiv.{0} K (DivisionRing.toDivInvMonoid.{0} K (Field.toDivisionRing.{0} K _inst_3)))) ((fun (a : Type) (b : Type) [self : HasLiftT.{1, 1} a b] => self.0) (Polynomial.{0} R (Ring.toSemiring.{0} R (CommRing.toRing.{0} R _inst_1))) K (algebraMap.coeHTCT.{0, 0} (Polynomial.{0} R (Ring.toSemiring.{0} R (CommRing.toRing.{0} R _inst_1))) K (Polynomial.commSemiring.{0} R (CommRing.toCommSemiring.{0} R _inst_1)) (Ring.toSemiring.{0} K (DivisionRing.toRing.{0} K (Field.toDivisionRing.{0} K _inst_3))) _inst_4) f) (HMul.hMul.{0, 0, 0} K K K (instHMul.{0} K (Distrib.toHasMul.{0} K (Ring.toDistrib.{0} K (DivisionRing.toRing.{0} K (Field.toDivisionRing.{0} K _inst_3))))) ((fun (a : Type) (b : Type) [self : HasLiftT.{1, 1} a b] => self.0) (Polynomial.{0} R (Ring.toSemiring.{0} R (CommRing.toRing.{0} R _inst_1))) K (algebraMap.coeHTCT.{0, 0} (Polynomial.{0} R (Ring.toSemiring.{0} R (CommRing.toRing.{0} R _inst_1))) K (Polynomial.commSemiring.{0} R (CommRing.toCommSemiring.{0} R _inst_1)) (Ring.toSemiring.{0} K (DivisionRing.toRing.{0} K (Field.toDivisionRing.{0} K _inst_3))) _inst_4) g₁) ((fun (a : Type) (b : Type) [self : HasLiftT.{1, 1} a b] => self.0) (Polynomial.{0} R (Ring.toSemiring.{0} R (CommRing.toRing.{0} R _inst_1))) K (algebraMap.coeHTCT.{0, 0} (Polynomial.{0} R (Ring.toSemiring.{0} R (CommRing.toRing.{0} R _inst_1))) K (Polynomial.commSemiring.{0} R (CommRing.toCommSemiring.{0} R _inst_1)) (Ring.toSemiring.{0} K (DivisionRing.toRing.{0} K (Field.toDivisionRing.{0} K _inst_3))) _inst_4) g₂))) (HAdd.hAdd.{0, 0, 0} K K K (instHAdd.{0} K (Distrib.toHasAdd.{0} K (Ring.toDistrib.{0} K (DivisionRing.toRing.{0} K (Field.toDivisionRing.{0} K _inst_3))))) (HAdd.hAdd.{0, 0, 0} K K K (instHAdd.{0} K (Distrib.toHasAdd.{0} K (Ring.toDistrib.{0} K (DivisionRing.toRing.{0} K (Field.toDivisionRing.{0} K _inst_3))))) ((fun (a : Type) (b : Type) [self : HasLiftT.{1, 1} a b] => self.0) (Polynomial.{0} R (Ring.toSemiring.{0} R (CommRing.toRing.{0} R _inst_1))) K (algebraMap.coeHTCT.{0, 0} (Polynomial.{0} R (Ring.toSemiring.{0} R (CommRing.toRing.{0} R _inst_1))) K (Polynomial.commSemiring.{0} R (CommRing.toCommSemiring.{0} R _inst_1)) (Ring.toSemiring.{0} K (DivisionRing.toRing.{0} K (Field.toDivisionRing.{0} K _inst_3))) _inst_4) q) (HDiv.hDiv.{0, 0, 0} K K K (instHDiv.{0} K (DivInvMonoid.toHasDiv.{0} K (DivisionRing.toDivInvMonoid.{0} K (Field.toDivisionRing.{0} K _inst_3)))) ((fun (a : Type) (b : Type) [self : HasLiftT.{1, 1} a b] => self.0) (Polynomial.{0} R (Ring.toSemiring.{0} R (CommRing.toRing.{0} R _inst_1))) K (algebraMap.coeHTCT.{0, 0} (Polynomial.{0} R (Ring.toSemiring.{0} R (CommRing.toRing.{0} R _inst_1))) K (Polynomial.commSemiring.{0} R (CommRing.toCommSemiring.{0} R _inst_1)) (Ring.toSemiring.{0} K (DivisionRing.toRing.{0} K (Field.toDivisionRing.{0} K _inst_3))) _inst_4) r₁) ((fun (a : Type) (b : Type) [self : HasLiftT.{1, 1} a b] => self.0) (Polynomial.{0} R (Ring.toSemiring.{0} R (CommRing.toRing.{0} R _inst_1))) K (algebraMap.coeHTCT.{0, 0} (Polynomial.{0} R (Ring.toSemiring.{0} R (CommRing.toRing.{0} R _inst_1))) K (Polynomial.commSemiring.{0} R (CommRing.toCommSemiring.{0} R _inst_1)) (Ring.toSemiring.{0} K (DivisionRing.toRing.{0} K (Field.toDivisionRing.{0} K _inst_3))) _inst_4) g₁))) (HDiv.hDiv.{0, 0, 0} K K K (instHDiv.{0} K (DivInvMonoid.toHasDiv.{0} K (DivisionRing.toDivInvMonoid.{0} K (Field.toDivisionRing.{0} K _inst_3)))) ((fun (a : Type) (b : Type) [self : HasLiftT.{1, 1} a b] => self.0) (Polynomial.{0} R (Ring.toSemiring.{0} R (CommRing.toRing.{0} R _inst_1))) K (algebraMap.coeHTCT.{0, 0} (Polynomial.{0} R (Ring.toSemiring.{0} R (CommRing.toRing.{0} R _inst_1))) K (Polynomial.commSemiring.{0} R (CommRing.toCommSemiring.{0} R _inst_1)) (Ring.toSemiring.{0} K (DivisionRing.toRing.{0} K (Field.toDivisionRing.{0} K _inst_3))) _inst_4) r₂) ((fun (a : Type) (b : Type) [self : HasLiftT.{1, 1} a b] => self.0) (Polynomial.{0} R (Ring.toSemiring.{0} R (CommRing.toRing.{0} R _inst_1))) K (algebraMap.coeHTCT.{0, 0} (Polynomial.{0} R (Ring.toSemiring.{0} R (CommRing.toRing.{0} R _inst_1))) K (Polynomial.commSemiring.{0} R (CommRing.toCommSemiring.{0} R _inst_1)) (Ring.toSemiring.{0} K (DivisionRing.toRing.{0} K (Field.toDivisionRing.{0} K _inst_3))) _inst_4) g₂)))))))))
but is expected to have type
  forall (R : Type) [_inst_1 : CommRing.{0} R] [_inst_2 : IsDomain.{0} R (Ring.toSemiring.{0} R (CommRing.toRing.{0} R _inst_1))] (K : Type) [_inst_3 : Field.{0} K] [_inst_4 : Algebra.{0, 0} (Polynomial.{0} R (Ring.toSemiring.{0} R (CommRing.toRing.{0} R _inst_1))) K (Polynomial.commSemiring.{0} R (CommRing.toCommSemiring.{0} R _inst_1)) (DivisionSemiring.toSemiring.{0} K (Semifield.toDivisionSemiring.{0} K (Field.toSemifield.{0} K _inst_3)))] [_inst_5 : IsFractionRing.{0, 0} (Polynomial.{0} R (Ring.toSemiring.{0} R (CommRing.toRing.{0} R _inst_1))) (Polynomial.commRing.{0} R _inst_1) K (Field.toCommRing.{0} K _inst_3) _inst_4] (f : Polynomial.{0} R (Ring.toSemiring.{0} R (CommRing.toRing.{0} R _inst_1))) {g₁ : Polynomial.{0} R (Ring.toSemiring.{0} R (CommRing.toRing.{0} R _inst_1))} {g₂ : Polynomial.{0} R (Ring.toSemiring.{0} R (CommRing.toRing.{0} R _inst_1))}, (Polynomial.Monic.{0} R (Ring.toSemiring.{0} R (CommRing.toRing.{0} R _inst_1)) g₁) -> (Polynomial.Monic.{0} R (Ring.toSemiring.{0} R (CommRing.toRing.{0} R _inst_1)) g₂) -> (IsCoprime.{0} (Polynomial.{0} R (Ring.toSemiring.{0} R (CommRing.toRing.{0} R _inst_1))) (Polynomial.commSemiring.{0} R (CommRing.toCommSemiring.{0} R _inst_1)) g₁ g₂) -> (Exists.{1} (Polynomial.{0} R (Ring.toSemiring.{0} R (CommRing.toRing.{0} R _inst_1))) (fun (q : Polynomial.{0} R (Ring.toSemiring.{0} R (CommRing.toRing.{0} R _inst_1))) => Exists.{1} (Polynomial.{0} R (Ring.toSemiring.{0} R (CommRing.toRing.{0} R _inst_1))) (fun (r₁ : Polynomial.{0} R (Ring.toSemiring.{0} R (CommRing.toRing.{0} R _inst_1))) => Exists.{1} (Polynomial.{0} R (Ring.toSemiring.{0} R (CommRing.toRing.{0} R _inst_1))) (fun (r₂ : Polynomial.{0} R (Ring.toSemiring.{0} R (CommRing.toRing.{0} R _inst_1))) => And (LT.lt.{0} (WithBot.{0} Nat) (Preorder.toLT.{0} (WithBot.{0} Nat) (WithBot.preorder.{0} Nat (PartialOrder.toPreorder.{0} Nat (StrictOrderedSemiring.toPartialOrder.{0} Nat Nat.strictOrderedSemiring)))) (Polynomial.degree.{0} R (Ring.toSemiring.{0} R (CommRing.toRing.{0} R _inst_1)) r₁) (Polynomial.degree.{0} R (Ring.toSemiring.{0} R (CommRing.toRing.{0} R _inst_1)) g₁)) (And (LT.lt.{0} (WithBot.{0} Nat) (Preorder.toLT.{0} (WithBot.{0} Nat) (WithBot.preorder.{0} Nat (PartialOrder.toPreorder.{0} Nat (StrictOrderedSemiring.toPartialOrder.{0} Nat Nat.strictOrderedSemiring)))) (Polynomial.degree.{0} R (Ring.toSemiring.{0} R (CommRing.toRing.{0} R _inst_1)) r₂) (Polynomial.degree.{0} R (Ring.toSemiring.{0} R (CommRing.toRing.{0} R _inst_1)) g₂)) (Eq.{1} K (HDiv.hDiv.{0, 0, 0} K K K (instHDiv.{0} K (Field.toDiv.{0} K _inst_3)) (Algebra.cast.{0, 0} (Polynomial.{0} R (Ring.toSemiring.{0} R (CommRing.toRing.{0} R _inst_1))) K (Polynomial.commSemiring.{0} R (CommRing.toCommSemiring.{0} R _inst_1)) (DivisionSemiring.toSemiring.{0} K (Semifield.toDivisionSemiring.{0} K (Field.toSemifield.{0} K _inst_3))) _inst_4 f) (HMul.hMul.{0, 0, 0} K K K (instHMul.{0} K (NonUnitalNonAssocRing.toMul.{0} K (NonAssocRing.toNonUnitalNonAssocRing.{0} K (Ring.toNonAssocRing.{0} K (DivisionRing.toRing.{0} K (Field.toDivisionRing.{0} K _inst_3)))))) (Algebra.cast.{0, 0} (Polynomial.{0} R (Ring.toSemiring.{0} R (CommRing.toRing.{0} R _inst_1))) K (Polynomial.commSemiring.{0} R (CommRing.toCommSemiring.{0} R _inst_1)) (DivisionSemiring.toSemiring.{0} K (Semifield.toDivisionSemiring.{0} K (Field.toSemifield.{0} K _inst_3))) _inst_4 g₁) (Algebra.cast.{0, 0} (Polynomial.{0} R (Ring.toSemiring.{0} R (CommRing.toRing.{0} R _inst_1))) K (Polynomial.commSemiring.{0} R (CommRing.toCommSemiring.{0} R _inst_1)) (DivisionSemiring.toSemiring.{0} K (Semifield.toDivisionSemiring.{0} K (Field.toSemifield.{0} K _inst_3))) _inst_4 g₂))) (HAdd.hAdd.{0, 0, 0} K K K (instHAdd.{0} K (Distrib.toAdd.{0} K (NonUnitalNonAssocSemiring.toDistrib.{0} K (NonUnitalNonAssocRing.toNonUnitalNonAssocSemiring.{0} K (NonAssocRing.toNonUnitalNonAssocRing.{0} K (Ring.toNonAssocRing.{0} K (DivisionRing.toRing.{0} K (Field.toDivisionRing.{0} K _inst_3)))))))) (HAdd.hAdd.{0, 0, 0} K K K (instHAdd.{0} K (Distrib.toAdd.{0} K (NonUnitalNonAssocSemiring.toDistrib.{0} K (NonUnitalNonAssocRing.toNonUnitalNonAssocSemiring.{0} K (NonAssocRing.toNonUnitalNonAssocRing.{0} K (Ring.toNonAssocRing.{0} K (DivisionRing.toRing.{0} K (Field.toDivisionRing.{0} K _inst_3)))))))) (Algebra.cast.{0, 0} (Polynomial.{0} R (Ring.toSemiring.{0} R (CommRing.toRing.{0} R _inst_1))) K (Polynomial.commSemiring.{0} R (CommRing.toCommSemiring.{0} R _inst_1)) (DivisionSemiring.toSemiring.{0} K (Semifield.toDivisionSemiring.{0} K (Field.toSemifield.{0} K _inst_3))) _inst_4 q) (HDiv.hDiv.{0, 0, 0} K K K (instHDiv.{0} K (Field.toDiv.{0} K _inst_3)) (Algebra.cast.{0, 0} (Polynomial.{0} R (Ring.toSemiring.{0} R (CommRing.toRing.{0} R _inst_1))) K (Polynomial.commSemiring.{0} R (CommRing.toCommSemiring.{0} R _inst_1)) (DivisionSemiring.toSemiring.{0} K (Semifield.toDivisionSemiring.{0} K (Field.toSemifield.{0} K _inst_3))) _inst_4 r₁) (Algebra.cast.{0, 0} (Polynomial.{0} R (Ring.toSemiring.{0} R (CommRing.toRing.{0} R _inst_1))) K (Polynomial.commSemiring.{0} R (CommRing.toCommSemiring.{0} R _inst_1)) (DivisionSemiring.toSemiring.{0} K (Semifield.toDivisionSemiring.{0} K (Field.toSemifield.{0} K _inst_3))) _inst_4 g₁))) (HDiv.hDiv.{0, 0, 0} K K K (instHDiv.{0} K (Field.toDiv.{0} K _inst_3)) (Algebra.cast.{0, 0} (Polynomial.{0} R (Ring.toSemiring.{0} R (CommRing.toRing.{0} R _inst_1))) K (Polynomial.commSemiring.{0} R (CommRing.toCommSemiring.{0} R _inst_1)) (DivisionSemiring.toSemiring.{0} K (Semifield.toDivisionSemiring.{0} K (Field.toSemifield.{0} K _inst_3))) _inst_4 r₂) (Algebra.cast.{0, 0} (Polynomial.{0} R (Ring.toSemiring.{0} R (CommRing.toRing.{0} R _inst_1))) K (Polynomial.commSemiring.{0} R (CommRing.toCommSemiring.{0} R _inst_1)) (DivisionSemiring.toSemiring.{0} K (Semifield.toDivisionSemiring.{0} K (Field.toSemifield.{0} K _inst_3))) _inst_4 g₂)))))))))
Case conversion may be inaccurate. Consider using '#align div_eq_quo_add_rem_div_add_rem_div div_eq_quo_add_rem_div_add_rem_divₓ'. -/
/-- Let R be an integral domain and f, g₁, g₂ ∈ R[X]. Let g₁ and g₂ be monic and coprime.
Then, ∃ q, r₁, r₂ ∈ R[X] such that f / g₁g₂ = q + r₁/g₁ + r₂/g₂ and deg(r₁) < deg(g₁) and
deg(r₂) < deg(g₂).
-/
theorem div_eq_quo_add_rem_div_add_rem_div (f : R[X]) {g₁ g₂ : R[X]} (hg₁ : g₁.Monic)
    (hg₂ : g₂.Monic) (hcoprime : IsCoprime g₁ g₂) :
    ∃ q r₁ r₂ : R[X],
      r₁.degree < g₁.degree ∧
        r₂.degree < g₂.degree ∧ (↑f : K) / (↑g₁ * ↑g₂) = ↑q + ↑r₁ / ↑g₁ + ↑r₂ / ↑g₂ :=
  by
  rcases hcoprime with ⟨c, d, hcd⟩
  refine'
    ⟨f * d /ₘ g₁ + f * c /ₘ g₂, f * d %ₘ g₁, f * c %ₘ g₂, degree_mod_by_monic_lt _ hg₁,
      degree_mod_by_monic_lt _ hg₂, _⟩
  have hg₁' : (↑g₁ : K) ≠ 0 := by
    norm_cast
    exact hg₁.ne_zero_of_ne zero_ne_one
  have hg₂' : (↑g₂ : K) ≠ 0 := by
    norm_cast
    exact hg₂.ne_zero_of_ne zero_ne_one
  have hfc := mod_by_monic_add_div (f * c) hg₂
  have hfd := mod_by_monic_add_div (f * d) hg₁
  field_simp
  norm_cast
  linear_combination -1 * f * hcd + -1 * g₁ * hfc + -1 * g₂ * hfd
#align div_eq_quo_add_rem_div_add_rem_div div_eq_quo_add_rem_div_add_rem_div

end TwoDenominators

section NDenominators

open BigOperators Classical

/- warning: div_eq_quo_add_sum_rem_div -> div_eq_quo_add_sum_rem_div is a dubious translation:
lean 3 declaration is
  forall (R : Type) [_inst_1 : CommRing.{0} R] [_inst_2 : IsDomain.{0} R (Ring.toSemiring.{0} R (CommRing.toRing.{0} R _inst_1))] (K : Type) [_inst_3 : Field.{0} K] [_inst_4 : Algebra.{0, 0} (Polynomial.{0} R (Ring.toSemiring.{0} R (CommRing.toRing.{0} R _inst_1))) K (Polynomial.commSemiring.{0} R (CommRing.toCommSemiring.{0} R _inst_1)) (Ring.toSemiring.{0} K (DivisionRing.toRing.{0} K (Field.toDivisionRing.{0} K _inst_3)))] [_inst_5 : IsFractionRing.{0, 0} (Polynomial.{0} R (Ring.toSemiring.{0} R (CommRing.toRing.{0} R _inst_1))) (Polynomial.commRing.{0} R _inst_1) K (Field.toCommRing.{0} K _inst_3) _inst_4] (f : Polynomial.{0} R (Ring.toSemiring.{0} R (CommRing.toRing.{0} R _inst_1))) {ι : Type.{u1}} {g : ι -> (Polynomial.{0} R (Ring.toSemiring.{0} R (CommRing.toRing.{0} R _inst_1)))} {s : Finset.{u1} ι}, (forall (i : ι), (Membership.Mem.{u1, u1} ι (Finset.{u1} ι) (Finset.hasMem.{u1} ι) i s) -> (Polynomial.Monic.{0} R (Ring.toSemiring.{0} R (CommRing.toRing.{0} R _inst_1)) (g i))) -> (Set.Pairwise.{u1} ι ((fun (a : Type.{u1}) (b : Type.{u1}) [self : HasLiftT.{succ u1, succ u1} a b] => self.0) (Finset.{u1} ι) (Set.{u1} ι) (HasLiftT.mk.{succ u1, succ u1} (Finset.{u1} ι) (Set.{u1} ι) (CoeTCₓ.coe.{succ u1, succ u1} (Finset.{u1} ι) (Set.{u1} ι) (Finset.Set.hasCoeT.{u1} ι))) s) (fun (i : ι) (j : ι) => IsCoprime.{0} (Polynomial.{0} R (Ring.toSemiring.{0} R (CommRing.toRing.{0} R _inst_1))) (Polynomial.commSemiring.{0} R (CommRing.toCommSemiring.{0} R _inst_1)) (g i) (g j))) -> (Exists.{1} (Polynomial.{0} R (Ring.toSemiring.{0} R (CommRing.toRing.{0} R _inst_1))) (fun (q : Polynomial.{0} R (Ring.toSemiring.{0} R (CommRing.toRing.{0} R _inst_1))) => Exists.{succ u1} (ι -> (Polynomial.{0} R (Ring.toSemiring.{0} R (CommRing.toRing.{0} R _inst_1)))) (fun (r : ι -> (Polynomial.{0} R (Ring.toSemiring.{0} R (CommRing.toRing.{0} R _inst_1)))) => And (forall (i : ι), (Membership.Mem.{u1, u1} ι (Finset.{u1} ι) (Finset.hasMem.{u1} ι) i s) -> (LT.lt.{0} (WithBot.{0} Nat) (Preorder.toLT.{0} (WithBot.{0} Nat) (WithBot.preorder.{0} Nat (PartialOrder.toPreorder.{0} Nat (OrderedCancelAddCommMonoid.toPartialOrder.{0} Nat (StrictOrderedSemiring.toOrderedCancelAddCommMonoid.{0} Nat Nat.strictOrderedSemiring))))) (Polynomial.degree.{0} R (Ring.toSemiring.{0} R (CommRing.toRing.{0} R _inst_1)) (r i)) (Polynomial.degree.{0} R (Ring.toSemiring.{0} R (CommRing.toRing.{0} R _inst_1)) (g i)))) (Eq.{1} K (HDiv.hDiv.{0, 0, 0} K K K (instHDiv.{0} K (DivInvMonoid.toHasDiv.{0} K (DivisionRing.toDivInvMonoid.{0} K (Field.toDivisionRing.{0} K _inst_3)))) ((fun (a : Type) (b : Type) [self : HasLiftT.{1, 1} a b] => self.0) (Polynomial.{0} R (Ring.toSemiring.{0} R (CommRing.toRing.{0} R _inst_1))) K (algebraMap.coeHTCT.{0, 0} (Polynomial.{0} R (Ring.toSemiring.{0} R (CommRing.toRing.{0} R _inst_1))) K (Polynomial.commSemiring.{0} R (CommRing.toCommSemiring.{0} R _inst_1)) (Ring.toSemiring.{0} K (DivisionRing.toRing.{0} K (Field.toDivisionRing.{0} K _inst_3))) _inst_4) f) (Finset.prod.{0, u1} K ι (CommRing.toCommMonoid.{0} K (Field.toCommRing.{0} K _inst_3)) s (fun (i : ι) => (fun (a : Type) (b : Type) [self : HasLiftT.{1, 1} a b] => self.0) (Polynomial.{0} R (Ring.toSemiring.{0} R (CommRing.toRing.{0} R _inst_1))) K (algebraMap.coeHTCT.{0, 0} (Polynomial.{0} R (Ring.toSemiring.{0} R (CommRing.toRing.{0} R _inst_1))) K (Polynomial.commSemiring.{0} R (CommRing.toCommSemiring.{0} R _inst_1)) (Ring.toSemiring.{0} K (DivisionRing.toRing.{0} K (Field.toDivisionRing.{0} K _inst_3))) _inst_4) (g i)))) (HAdd.hAdd.{0, 0, 0} K K K (instHAdd.{0} K (Distrib.toHasAdd.{0} K (Ring.toDistrib.{0} K (DivisionRing.toRing.{0} K (Field.toDivisionRing.{0} K _inst_3))))) ((fun (a : Type) (b : Type) [self : HasLiftT.{1, 1} a b] => self.0) (Polynomial.{0} R (Ring.toSemiring.{0} R (CommRing.toRing.{0} R _inst_1))) K (algebraMap.coeHTCT.{0, 0} (Polynomial.{0} R (Ring.toSemiring.{0} R (CommRing.toRing.{0} R _inst_1))) K (Polynomial.commSemiring.{0} R (CommRing.toCommSemiring.{0} R _inst_1)) (Ring.toSemiring.{0} K (DivisionRing.toRing.{0} K (Field.toDivisionRing.{0} K _inst_3))) _inst_4) q) (Finset.sum.{0, u1} K ι (AddCommGroup.toAddCommMonoid.{0} K (NonUnitalNonAssocRing.toAddCommGroup.{0} K (NonAssocRing.toNonUnitalNonAssocRing.{0} K (Ring.toNonAssocRing.{0} K (DivisionRing.toRing.{0} K (Field.toDivisionRing.{0} K _inst_3)))))) s (fun (i : ι) => HDiv.hDiv.{0, 0, 0} K K K (instHDiv.{0} K (DivInvMonoid.toHasDiv.{0} K (DivisionRing.toDivInvMonoid.{0} K (Field.toDivisionRing.{0} K _inst_3)))) ((fun (a : Type) (b : Type) [self : HasLiftT.{1, 1} a b] => self.0) (Polynomial.{0} R (Ring.toSemiring.{0} R (CommRing.toRing.{0} R _inst_1))) K (algebraMap.coeHTCT.{0, 0} (Polynomial.{0} R (Ring.toSemiring.{0} R (CommRing.toRing.{0} R _inst_1))) K (Polynomial.commSemiring.{0} R (CommRing.toCommSemiring.{0} R _inst_1)) (Ring.toSemiring.{0} K (DivisionRing.toRing.{0} K (Field.toDivisionRing.{0} K _inst_3))) _inst_4) (r i)) ((fun (a : Type) (b : Type) [self : HasLiftT.{1, 1} a b] => self.0) (Polynomial.{0} R (Ring.toSemiring.{0} R (CommRing.toRing.{0} R _inst_1))) K (algebraMap.coeHTCT.{0, 0} (Polynomial.{0} R (Ring.toSemiring.{0} R (CommRing.toRing.{0} R _inst_1))) K (Polynomial.commSemiring.{0} R (CommRing.toCommSemiring.{0} R _inst_1)) (Ring.toSemiring.{0} K (DivisionRing.toRing.{0} K (Field.toDivisionRing.{0} K _inst_3))) _inst_4) (g i)))))))))
but is expected to have type
  forall (R : Type) [_inst_1 : CommRing.{0} R] [_inst_2 : IsDomain.{0} R (Ring.toSemiring.{0} R (CommRing.toRing.{0} R _inst_1))] (K : Type) [_inst_3 : Field.{0} K] [_inst_4 : Algebra.{0, 0} (Polynomial.{0} R (Ring.toSemiring.{0} R (CommRing.toRing.{0} R _inst_1))) K (Polynomial.commSemiring.{0} R (CommRing.toCommSemiring.{0} R _inst_1)) (DivisionSemiring.toSemiring.{0} K (Semifield.toDivisionSemiring.{0} K (Field.toSemifield.{0} K _inst_3)))] [_inst_5 : IsFractionRing.{0, 0} (Polynomial.{0} R (Ring.toSemiring.{0} R (CommRing.toRing.{0} R _inst_1))) (Polynomial.commRing.{0} R _inst_1) K (Field.toCommRing.{0} K _inst_3) _inst_4] (f : Polynomial.{0} R (Ring.toSemiring.{0} R (CommRing.toRing.{0} R _inst_1))) {ι : Type.{u1}} {g : ι -> (Polynomial.{0} R (Ring.toSemiring.{0} R (CommRing.toRing.{0} R _inst_1)))} {s : Finset.{u1} ι}, (forall (i : ι), (Membership.mem.{u1, u1} ι (Finset.{u1} ι) (Finset.instMembershipFinset.{u1} ι) i s) -> (Polynomial.Monic.{0} R (Ring.toSemiring.{0} R (CommRing.toRing.{0} R _inst_1)) (g i))) -> (Set.Pairwise.{u1} ι (Finset.toSet.{u1} ι s) (fun (i : ι) (j : ι) => IsCoprime.{0} (Polynomial.{0} R (Ring.toSemiring.{0} R (CommRing.toRing.{0} R _inst_1))) (Polynomial.commSemiring.{0} R (CommRing.toCommSemiring.{0} R _inst_1)) (g i) (g j))) -> (Exists.{1} (Polynomial.{0} R (Ring.toSemiring.{0} R (CommRing.toRing.{0} R _inst_1))) (fun (q : Polynomial.{0} R (Ring.toSemiring.{0} R (CommRing.toRing.{0} R _inst_1))) => Exists.{succ u1} (ι -> (Polynomial.{0} R (Ring.toSemiring.{0} R (CommRing.toRing.{0} R _inst_1)))) (fun (r : ι -> (Polynomial.{0} R (Ring.toSemiring.{0} R (CommRing.toRing.{0} R _inst_1)))) => And (forall (i : ι), (Membership.mem.{u1, u1} ι (Finset.{u1} ι) (Finset.instMembershipFinset.{u1} ι) i s) -> (LT.lt.{0} (WithBot.{0} Nat) (Preorder.toLT.{0} (WithBot.{0} Nat) (WithBot.preorder.{0} Nat (PartialOrder.toPreorder.{0} Nat (StrictOrderedSemiring.toPartialOrder.{0} Nat Nat.strictOrderedSemiring)))) (Polynomial.degree.{0} R (Ring.toSemiring.{0} R (CommRing.toRing.{0} R _inst_1)) (r i)) (Polynomial.degree.{0} R (Ring.toSemiring.{0} R (CommRing.toRing.{0} R _inst_1)) (g i)))) (Eq.{1} K (HDiv.hDiv.{0, 0, 0} K K K (instHDiv.{0} K (Field.toDiv.{0} K _inst_3)) (Algebra.cast.{0, 0} (Polynomial.{0} R (Ring.toSemiring.{0} R (CommRing.toRing.{0} R _inst_1))) K (Polynomial.commSemiring.{0} R (CommRing.toCommSemiring.{0} R _inst_1)) (DivisionSemiring.toSemiring.{0} K (Semifield.toDivisionSemiring.{0} K (Field.toSemifield.{0} K _inst_3))) _inst_4 f) (Finset.prod.{0, u1} K ι (CommRing.toCommMonoid.{0} K (Field.toCommRing.{0} K _inst_3)) s (fun (i : ι) => Algebra.cast.{0, 0} (Polynomial.{0} R (Ring.toSemiring.{0} R (CommRing.toRing.{0} R _inst_1))) K (Polynomial.commSemiring.{0} R (CommRing.toCommSemiring.{0} R _inst_1)) (DivisionSemiring.toSemiring.{0} K (Semifield.toDivisionSemiring.{0} K (Field.toSemifield.{0} K _inst_3))) _inst_4 (g i)))) (HAdd.hAdd.{0, 0, 0} K K K (instHAdd.{0} K (Distrib.toAdd.{0} K (NonUnitalNonAssocSemiring.toDistrib.{0} K (NonUnitalNonAssocRing.toNonUnitalNonAssocSemiring.{0} K (NonAssocRing.toNonUnitalNonAssocRing.{0} K (Ring.toNonAssocRing.{0} K (DivisionRing.toRing.{0} K (Field.toDivisionRing.{0} K _inst_3)))))))) (Algebra.cast.{0, 0} (Polynomial.{0} R (Ring.toSemiring.{0} R (CommRing.toRing.{0} R _inst_1))) K (Polynomial.commSemiring.{0} R (CommRing.toCommSemiring.{0} R _inst_1)) (DivisionSemiring.toSemiring.{0} K (Semifield.toDivisionSemiring.{0} K (Field.toSemifield.{0} K _inst_3))) _inst_4 q) (Finset.sum.{0, u1} K ι (NonUnitalNonAssocSemiring.toAddCommMonoid.{0} K (NonUnitalNonAssocRing.toNonUnitalNonAssocSemiring.{0} K (NonAssocRing.toNonUnitalNonAssocRing.{0} K (Ring.toNonAssocRing.{0} K (DivisionRing.toRing.{0} K (Field.toDivisionRing.{0} K _inst_3)))))) s (fun (i : ι) => HDiv.hDiv.{0, 0, 0} K K K (instHDiv.{0} K (Field.toDiv.{0} K _inst_3)) (Algebra.cast.{0, 0} (Polynomial.{0} R (Ring.toSemiring.{0} R (CommRing.toRing.{0} R _inst_1))) K (Polynomial.commSemiring.{0} R (CommRing.toCommSemiring.{0} R _inst_1)) (DivisionSemiring.toSemiring.{0} K (Semifield.toDivisionSemiring.{0} K (Field.toSemifield.{0} K _inst_3))) _inst_4 (r i)) (Algebra.cast.{0, 0} (Polynomial.{0} R (Ring.toSemiring.{0} R (CommRing.toRing.{0} R _inst_1))) K (Polynomial.commSemiring.{0} R (CommRing.toCommSemiring.{0} R _inst_1)) (DivisionSemiring.toSemiring.{0} K (Semifield.toDivisionSemiring.{0} K (Field.toSemifield.{0} K _inst_3))) _inst_4 (g i)))))))))
Case conversion may be inaccurate. Consider using '#align div_eq_quo_add_sum_rem_div div_eq_quo_add_sum_rem_divₓ'. -/
/-- Let R be an integral domain and f ∈ R[X]. Let s be a finite index set.
Then, a fraction of the form f / ∏ (g i) can be rewritten as q + ∑ (r i) / (g i), where
deg(r i) < deg(g i), provided that the g i are monic and pairwise coprime.
-/
theorem div_eq_quo_add_sum_rem_div (f : R[X]) {ι : Type _} {g : ι → R[X]} {s : Finset ι}
    (hg : ∀ i ∈ s, (g i).Monic) (hcop : Set.Pairwise ↑s fun i j => IsCoprime (g i) (g j)) :
    ∃ (q : R[X])(r : ι → R[X]),
      (∀ i ∈ s, (r i).degree < (g i).degree) ∧
        ((↑f : K) / ∏ i in s, ↑(g i)) = ↑q + ∑ i in s, ↑(r i) / ↑(g i) :=
  by
  induction' s using Finset.induction_on with a b hab Hind f generalizing f
  · refine' ⟨f, fun i : ι => (0 : R[X]), fun i => _, by simp⟩
    rintro ⟨⟩
  obtain ⟨q₀, r₁, r₂, hdeg₁, hdeg₂, hf : (↑f : K) / _ = _⟩ :=
    div_eq_quo_add_rem_div_add_rem_div R K f (_ : monic (g a)) (_ : monic (∏ i : ι in b, g i)) _
  · obtain ⟨q, r, hrdeg, IH⟩ :=
      Hind (fun i hi => hg i (Finset.mem_insert_of_mem hi))
        (Set.Pairwise.mono (Finset.coe_subset.2 fun i hi => Finset.mem_insert_of_mem hi) hcop) r₂
    refine' ⟨q₀ + q, fun i => if i = a then r₁ else r i, _, _⟩
    · intro i
      split_ifs with h1
      · cases h1
        intro
        exact hdeg₁
      · intro hi
        exact hrdeg i (Finset.mem_of_mem_insert_of_ne hi h1)
    norm_cast  at hf IH⊢
    rw [Finset.prod_insert hab, hf, IH, Finset.sum_insert hab, if_pos rfl]
    trans (↑(q₀ + q : R[X]) : K) + (↑r₁ / ↑(g a) + ∑ i : ι in b, ↑(r i) / ↑(g i))
    · push_cast
      ring
    congr 2
    refine' Finset.sum_congr rfl fun x hxb => _
    rw [if_neg]
    rintro rfl
    exact hab hxb
  · exact hg a (b.mem_insert_self a)
  · exact monic_prod_of_monic _ _ fun i hi => hg i (Finset.mem_insert_of_mem hi)
  · refine'
      IsCoprime.prod_right fun i hi =>
        hcop (Finset.mem_coe.2 (b.mem_insert_self a))
          (Finset.mem_coe.2 (Finset.mem_insert_of_mem hi)) _
    rintro rfl
    exact hab hi
#align div_eq_quo_add_sum_rem_div div_eq_quo_add_sum_rem_div

end NDenominators