import set_theory.zfc set_theory.ordinal

universe u

attribute [elab_as_eliminator] well_founded.induction

def Well_order.to_pSet (w : Well_order.{u}) : pSet.{u} :=
pSet.mk w.1 $ well_founded.fix (@is_well_order.wf w.1 w.2 w.3) $ λ x ih,
pSet.mk { y | w.r y x } $ λ p, ih p.1 p.2

theorem Well_order.to_pSet.def (w : Well_order.{u}) (x : w.1) :
  w.to_pSet.func x = pSet.mk { y | w.r y x } (λ p, w.to_pSet.func p.1) :=
well_founded.fix_eq _ _ x

theorem ordinal.to_Set.aux (v w : Well_order.{u}) (e : v.2 ≃o w.2) (x : v.1) :
  (Well_order.to_pSet v).func x ≈ (Well_order.to_pSet w).func (e x) :=
show pSet.equiv
  (well_founded.fix (@is_well_order.wf v.1 v.2 v.3)
    (λ x ih, pSet.mk { y | v.r y x } $ λ p, ih p.1 p.2) x)
  (well_founded.fix (@is_well_order.wf w.1 w.2 w.3)
    (λ x ih, pSet.mk { y | w.r y x } $ λ p, ih p.1 p.2) (e x)),
from well_founded.induction (@is_well_order.wf v.1 v.2 v.3) x $ λ x ih,
by rw [well_founded.fix_eq, well_founded.fix_eq];
from ⟨λ ⟨y, hy⟩, ⟨⟨e y, (order_iso.ord e).1 hy⟩, ih y hy⟩,
λ ⟨y, hy⟩, ⟨⟨e.symm y, by simpa using (order_iso.ord e.symm).1 hy⟩,
  by have := ih (e.symm y) (by simpa using (order_iso.ord e.symm).1 hy); rw [order_iso.apply_inverse_apply] at this; from this⟩⟩

def ordinal.to_Set (o : ordinal.{u}) : Set.{u} :=
quotient.lift_on o (λ w, ⟦Well_order.to_pSet w⟧) $ λ ⟨v1, v2, v3⟩ ⟨w1, w2, w3⟩ ⟨e⟩, quotient.sound
⟨λ x, ⟨e x, ordinal.to_Set.aux _ _ e x⟩,
λ x, ⟨e.symm x, by simpa using ordinal.to_Set.aux ⟨v1, v2, v3⟩ ⟨w1, w2, w3⟩ e (e.symm x)⟩⟩

def pSet.type.setoid (p : pSet.{u}) : setoid p.type :=
⟨λ i j, ⟦p.func i⟧ = ⟦p.func j⟧, λ i, rfl, λ i j, eq.symm, λ i j k, eq.trans⟩

local attribute [instance] pSet.type.setoid

def Set.to_cardinal (s : Set.{u}) : cardinal.{u} :=
quotient.lift_on s (λ p, cardinal.mk $ quotient $ pSet.type.setoid p) $
λ ⟨p1, p2⟩ ⟨q1, q2⟩ H, quotient.sound $ nonempty.intro
{ to_fun := λ x, quotient.lift_on x (λ i, @@quotient.mk (pSet.type.setoid $ pSet.mk q1 q2) (classical.some (H.1 i))) $ λ i j H',
    quotient.sound $
    calc  ⟦q2 (classical.some (H.1 i))⟧
        = ⟦p2 i⟧ : eq.symm (quotient.sound $ classical.some_spec (H.1 i))
    ... = ⟦p2 j⟧ : H'
    ... = ⟦q2 (classical.some (H.1 j))⟧ : quotient.sound (classical.some_spec (H.1 j)),
  inv_fun := λ x, quotient.lift_on x (λ i, @@quotient.mk (pSet.type.setoid $ pSet.mk p1 p2) $ classical.some $ H.2 i) $ λ i j H',
    quotient.sound $
    calc  ⟦p2 (classical.some (H.2 i))⟧
        = ⟦q2 i⟧ : quotient.sound (classical.some_spec (H.2 i))
    ... = ⟦q2 j⟧ : H'
    ... = ⟦p2 (classical.some (H.2 j))⟧ : eq.symm (quotient.sound $ classical.some_spec (H.2 j)),
  left_inv := λ i, quotient.induction_on i $ λ i, quotient.sound $
    calc  ⟦p2 (classical.some (H.2 (classical.some (H.1 i))))⟧
        = ⟦q2 (classical.some (H.1 i))⟧ : quotient.sound (classical.some_spec (H.2 _))
    ... = ⟦p2 i⟧ : eq.symm (quotient.sound $ classical.some_spec (H.1 i)),
  right_inv := λ i, quotient.induction_on i $ λ i, quotient.sound $
    calc  ⟦q2 (classical.some (H.1 (classical.some (H.2 i))))⟧
        = ⟦p2 (classical.some (H.2 i))⟧ : eq.symm (quotient.sound $ classical.some_spec (H.1 _))
    ... = ⟦q2 i⟧ : quotient.sound (classical.some_spec (H.2 i)) }

theorem Well_order.to_pSet.exact (w : Well_order.{u}) (x : w.1) :
  ∀ y, ⟦w.to_pSet.func x⟧ = ⟦w.to_pSet.func y⟧ → x = y :=
well_founded.induction (@is_well_order.wf w.1 w.2 w.3) x $ λ x ih y H,
begin
  replace H := quotient.exact H,
  rw [Well_order.to_pSet.def, Well_order.to_pSet.def] at H,
  letI := w.3,
  rcases is_trichotomous.trichotomous w.2 x y with h | h | h,
  { rcases H.2 ⟨x, h⟩ with ⟨⟨z, hzx⟩, h1⟩,
    specialize ih z hzx x (quotient.sound h1),
    exfalso,
    subst ih,
    exact is_irrefl.irrefl w.r _ hzx },
  { exact h },
  { rcases H.1 ⟨y, h⟩ with ⟨⟨z, hzy⟩, h1⟩,
    specialize ih y h z (quotient.sound h1),
    exfalso,
    subst ih,
    exact is_irrefl.irrefl w.r _ hzy }
end

example (c : cardinal.{u}) : c.ord.to_Set.to_cardinal = c :=
begin
  apply quotient.induction_on c,
  intro c,
  have := cardinal.ord_eq c,
  rcases this with ⟨r, wo, H⟩,
  simp [H, ordinal.type, ordinal.to_Set],
  rw [Set.mk, Set.to_cardinal, quotient.lift_on_beta],
  apply quotient.sound,
  split,
  fapply equiv.mk,
  { fapply quotient.lift,
    { exact id },
    { intros x y H,
      exact Well_order.to_pSet.exact _ _ _ H } },
  { exact quotient.mk },
  { intro x,
    apply quotient.induction_on x,
    intro x,
    refl },
  { intro x, refl }
end

example : ordinal.to_Set 0 = ∅ :=
quotient.sound $ ⟨λ ⟨d⟩, match d with end, λ ⟨d⟩, match d with end⟩

theorem Well_order.to_pSet.sum (v w : Well_order.{u}) (x : v.1) :
  (⟨v.1 ⊕ w.1, sum.lex v.2 w.2, by letI := v.3; letI := w.3; exactI sum.lex.is_well_order⟩ : Well_order).to_pSet.func (sum.inl x) ≈ v.to_pSet.func x :=
begin
  cases v with v1 v2 v3,
  cases w with w1 w2 w3,
  resetI,
  dsimp [Well_order.to_pSet, pSet.func],
  rw [well_founded.fix_eq, well_founded.fix_eq],
  apply well_founded.induction (is_well_order.wf v2) x,
  intros x ih,
  split,
  { intro z,
    rcases z with ⟨z | z, hz | hz | hz⟩,
    fapply exists.intro,
    { refine ⟨z, _⟩,
      assumption },
    dsimp,
    rw [well_founded.fix_eq, well_founded.fix_eq],
    exact ih z (by assumption) },
  intro z,
  cases z with z hz,
  refine ⟨⟨sum.inl z, _⟩, _⟩,
  { constructor,
    assumption },
  dsimp,
  rw [well_founded.fix_eq, well_founded.fix_eq],
  exact ih z (by assumption)
end

example (o : ordinal.{u}) : o.succ.to_Set = insert o.to_Set o.to_Set :=
begin
  apply quotient.induction_on o,
  intro w,
  cases w with w1 w2 w3, resetI,
  apply quotient.sound,
  dsimp [pSet.resp.f, Well_order.to_pSet, pSet.insert],
  split,
  { intro s,
    cases s with s s,
    { existsi (some s),
      exact Well_order.to_pSet.sum (Well_order.mk w1 w2 w3)
        ⟨ulift unit, empty_relation, by apply_instance⟩ s },
    existsi none,
    dsimp,
    rw [well_founded.fix_eq],
    split,
    { intro s,
      rcases s with ⟨s | s, hs | hs | hs⟩,
      { existsi s,
        exact Well_order.to_pSet.sum (Well_order.mk w1 w2 w3)
          ⟨ulift unit, empty_relation, by apply_instance⟩ s },
      exfalso,
      assumption },
    intro s,
    refine ⟨⟨sum.inl s, _⟩, _⟩,
    { constructor },
    exact Well_order.to_pSet.sum (Well_order.mk w1 w2 w3)
      ⟨ulift unit, empty_relation, by apply_instance⟩ s },
  intro s,
  cases s,
  { existsi (sum.inr (ulift.up unit.star)),
    dsimp,
    split,
    { intro s,
      rcases s with ⟨s | s, hs | hs | hs⟩,
      { existsi s,
        exact Well_order.to_pSet.sum (Well_order.mk w1 w2 w3)
          ⟨ulift unit, empty_relation, by apply_instance⟩ s },
      exfalso,
      assumption },
    intro s,
    refine ⟨⟨sum.inl s, _⟩, _⟩,
    { constructor },
    exact Well_order.to_pSet.sum (Well_order.mk w1 w2 w3)
      ⟨ulift unit, empty_relation, by apply_instance⟩ s },
  existsi (sum.inl s),
  exact Well_order.to_pSet.sum (Well_order.mk w1 w2 w3)
    ⟨ulift unit, empty_relation, by apply_instance⟩ s
end

theorem Well_order.to_pSet.subrel (w : Well_order.{u}) (x : w.1) :
  ⟦w.to_pSet.func x⟧ = (@ordinal.typein w.1 w.2 w.3 x).to_Set :=
begin
  letI := w.3,
  apply quotient.sound,
  rw [Well_order.to_pSet.def],
  split;
  { intro y,
    existsi y,
    dsimp,
    apply well_founded.induction (is_well_order.wf (subrel w.r _)) y,
    intros y ih,
    rw [Well_order.to_pSet.def, well_founded.fix_eq],
    split,
    { intro z,
      exact ⟨⟨⟨z.1, is_trans.trans _ _ _ z.2 y.2⟩, z.2⟩, ih ⟨_, _⟩ z.2⟩ },
    intro z,
    exact ⟨⟨z.1, z.2⟩, ih _ z.2⟩ }
end/-
#check cardinal.omega.succ.ord.to_Set
def ordinal.to_Set.inj.aux1 (p : set.range Well_order.to_pSet.{u}) : Well_order.{u+1} :=
{ α := set.range p.1.func,
  r := subrel pSet.mem.{u} _,
  wo :=
  { wf := _ } }

theorem ordinal.to_Set.inj (p q : ordinal.{u}) (H : p.to_Set = q.to_Set) : p = q :=
begin
  revert H,
  apply quotient.induction_on₂ p q,
  intros v w H,
  replace H := quotient.exact H,
  apply quotient.sound,
  suffices : v.2 ≃o w.2,
  { cases v, cases w, constructor, exact this },
  fapply order_iso.mk,
  fapply equiv.mk,
  { intro x,
    exact classical.some (H.1 x) },
  { intro y,
    exact classical.some (H.2 y) },
  { intro x,
    apply Well_order.to_pSet.exact,
    have h1 : ⟦pSet.func (Well_order.to_pSet _) _⟧ = ⟦pSet.func (Well_order.to_pSet _) _⟧ :=
      quotient.sound (classical.some_spec (H.2 (classical.some (H.1 x)))),
    have h2 : ⟦pSet.func (Well_order.to_pSet _) _⟧ = ⟦pSet.func (Well_order.to_pSet _) _⟧ :=
      quotient.sound (classical.some_spec (H.1 x)),
    rw [h1, h2] },
  { intro y,
    apply Well_order.to_pSet.exact,
    have h1 : ⟦pSet.func (Well_order.to_pSet _) _⟧ = ⟦pSet.func (Well_order.to_pSet _) _⟧ :=
      quotient.sound (classical.some_spec (H.1 (classical.some (H.2 y)))),
    have h2 : ⟦pSet.func (Well_order.to_pSet _) _⟧ = ⟦pSet.func (Well_order.to_pSet _) _⟧ :=
      quotient.sound (classical.some_spec (H.2 y)),
    rw [← h1, ← h2] },
end-/

example (v w : Well_order.{u}) (t : w.1) (H : v.to_pSet ≈ w.to_pSet.func t) :
  ⟦v⟧ = @ordinal.typein w.1 w.2 w.3 t :=
begin
  apply quotient.sound,
  letI := w.3,
  suffices : v.2 ≃o subrel (w.r) {b : w.α | w.r b t},
  { cases v, constructor, exact this },
  revert v,
  apply well_founded.recursion (is_well_order.wf w.2) t,
  intros t ih v H,
end

example (p q : ordinal.{u}) : p < q ↔ p.to_Set ∈ q.to_Set :=
begin
  apply quotient.induction_on₂ p q,
  intros v w,
  letI := v.3,
  letI := w.3,
  have hv : v = {α := v.α, r := v.r, wo := by apply_instance},
  { cases v, congr },
  have hw : w = {α := w.α, r := w.r, wo := by apply_instance},
  { cases w, congr },
  split,
  { intro e,
    replace e : nonempty (principal_seg v.2 w.2),
    { cases v, cases w, exact e },
    cases e,
    have := congr_arg ordinal.to_Set (ordinal.typein_top e),
    existsi e.top,
    suffices : (_ : pSet) ≈ _,
    { unfold has_equiv.equiv setoid.r at this,
      exact this },
    apply quotient.exact,
    replace this := quotient.sound (quotient.exact this),
    rw ← hv at this, rw ← this, symmetry,
    exact Well_order.to_pSet.subrel _ e.top },
  intro H,
  cases H with t ht,
  change Well_order.to_pSet v ≈ pSet.func (Well_order.to_pSet _) _ at ht,
  suffices : principal_seg v.2 w.2,
  { cases v, cases w, constructor, exact this },
  revert ht,
  apply well_founded.recursion (is_well_order.wf w.2) t,
  intros t ih H,
/-  rw well_founded.fix_eq at hx,
  fapply principal_seg.mk,
  fapply order_embedding.mk,
  fapply function.embedding.mk,
  { intro x,
    exact (classical.some (hx.1 x)).1, },
  { intros x y h,
    have h1 : ⟦pSet.func (Well_order.to_pSet _) _⟧ = ⟦pSet.func (Well_order.to_pSet _) _⟧ :=
      quotient.sound (classical.some_spec (hx.1 x)),
    have h2 : ⟦pSet.func (Well_order.to_pSet _) _⟧ = ⟦pSet.func (Well_order.to_pSet _) _⟧ :=
      quotient.sound (classical.some_spec (hx.1 y)),
    apply Well_order.to_pSet.exact,
    rw [h1, h2, h] },
  { intros x y,
    have : Well_order.to_pSet v ≈ pSet.func (Well_order.to_pSet _) _ := hx' },-/
end

--TODO: is ordinal iff transitive and linearly ordered


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

! This file was ported from Lean 3 source module analysis.normed_space.extend
! leanprover-community/mathlib commit 468b141b14016d54b479eb7a0fff1e360b7e3cf6
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.Analysis.NormedSpace.OperatorNorm
import Mathbin.Algebra.Algebra.RestrictScalars
import Mathbin.Data.IsROrC.Basic

/-!
# Extending a continuous `ℝ`-linear map to a continuous `𝕜`-linear map

In this file we provide a way to extend a continuous `ℝ`-linear map to a continuous `𝕜`-linear map
in a way that bounds the norm by the norm of the original map, when `𝕜` is either `ℝ` (the
extension is trivial) or `ℂ`. We formulate the extension uniformly, by assuming `is_R_or_C 𝕜`.

We motivate the form of the extension as follows. Note that `fc : F →ₗ[𝕜] 𝕜` is determined fully by
`Re fc`: for all `x : F`, `fc (I • x) = I * fc x`, so `Im (fc x) = -Re (fc (I • x))`. Therefore,
given an `fr : F →ₗ[ℝ] ℝ`, we define `fc x = fr x - fr (I • x) * I`.

## Main definitions

* `linear_map.extend_to_𝕜`
* `continuous_linear_map.extend_to_𝕜`

## Implementation details

For convenience, the main definitions above operate in terms of `restrict_scalars ℝ 𝕜 F`.
Alternate forms which operate on `[is_scalar_tower ℝ 𝕜 F]` instead are provided with a primed name.

-/

open IsROrC

variable {𝕜 : Type _} [IsROrC 𝕜] {F : Type _} [SeminormedAddCommGroup F] [NormedSpace 𝕜 F]

-- mathport name: exprabs𝕜
local notation "abs𝕜" => @IsROrC.abs 𝕜 _

/-- Extend `fr : F →ₗ[ℝ] ℝ` to `F →ₗ[𝕜] 𝕜` in a way that will also be continuous and have its norm
bounded by `‖fr‖` if `fr` is continuous. -/
noncomputable def LinearMap.extendTo𝕜' [Module ℝ F] [IsScalarTower ℝ 𝕜 F] (fr : F →ₗ[ℝ] ℝ) :
    F →ₗ[𝕜] 𝕜 :=
  by
  let fc : F → 𝕜 := fun x => (fr x : 𝕜) - (I : 𝕜) * fr ((I : 𝕜) • x)
  have add : ∀ x y : F, fc (x + y) = fc x + fc y :=
    by
    intro x y
    simp only [fc]
    simp only [smul_add, LinearMap.map_add, of_real_add]
    rw [mul_add]
    abel
  have A : ∀ (c : ℝ) (x : F), (fr ((c : 𝕜) • x) : 𝕜) = (c : 𝕜) * (fr x : 𝕜) :=
    by
    intro c x
    rw [← of_real_mul]
    congr 1
    rw [IsROrC.of_real_alg, smul_assoc, fr.map_smul, Algebra.id.smul_eq_mul, one_smul]
  have smul_ℝ : ∀ (c : ℝ) (x : F), fc ((c : 𝕜) • x) = (c : 𝕜) * fc x :=
    by
    intro c x
    simp only [fc, A]
    rw [A c x]
    rw [smul_smul, mul_comm I (c : 𝕜), ← smul_smul, A, mul_sub]
    ring
  have smul_I : ∀ x : F, fc ((I : 𝕜) • x) = (I : 𝕜) * fc x :=
    by
    intro x
    simp only [fc]
    cases' @I_mul_I_ax 𝕜 _ with h h
    · simp [h]
    rw [mul_sub, ← mul_assoc, smul_smul, h]
    simp only [neg_mul, LinearMap.map_neg, one_mul, one_smul, mul_neg, of_real_neg, neg_smul,
      sub_neg_eq_add, add_comm]
  have smul_𝕜 : ∀ (c : 𝕜) (x : F), fc (c • x) = c • fc x :=
    by
    intro c x
    rw [← re_add_im c, add_smul, add_smul, add, smul_ℝ, ← smul_smul, smul_ℝ, smul_I, ← mul_assoc]
    rfl
  exact
    { toFun := fc
      map_add' := add
      map_smul' := smul_𝕜 }
#align linear_map.extend_to_𝕜' LinearMap.extendTo𝕜'

theorem LinearMap.extendTo𝕜'_apply [Module ℝ F] [IsScalarTower ℝ 𝕜 F] (fr : F →ₗ[ℝ] ℝ) (x : F) :
    fr.extendTo𝕜' x = (fr x : 𝕜) - (i : 𝕜) * fr ((i : 𝕜) • x) :=
  rfl
#align linear_map.extend_to_𝕜'_apply LinearMap.extendTo𝕜'_apply

/-- The norm of the extension is bounded by `‖fr‖`. -/
theorem norm_bound [NormedSpace ℝ F] [IsScalarTower ℝ 𝕜 F] (fr : F →L[ℝ] ℝ) (x : F) :
    ‖(fr.toLinearMap.extendTo𝕜' x : 𝕜)‖ ≤ ‖fr‖ * ‖x‖ :=
  by
  let lm : F →ₗ[𝕜] 𝕜 := fr.to_linear_map.extend_to_𝕜'
  classical
    -- We aim to find a `t : 𝕜` such that
    -- * `lm (t • x) = fr (t • x)` (so `lm (t • x) = t * lm x ∈ ℝ`)
    -- * `‖lm x‖ = ‖lm (t • x)‖` (so `t.abs` must be 1)
    -- If `lm x ≠ 0`, `(lm x)⁻¹` satisfies the first requirement, and after normalizing, it
    -- satisfies the second.
    -- (If `lm x = 0`, the goal is trivial.)
    by_cases h : lm x = 0
    · rw [h, norm_zero]
      apply mul_nonneg <;> exact norm_nonneg _
    let fx := (lm x)⁻¹
    let t := fx / (abs𝕜 fx : 𝕜)
    have ht : abs𝕜 t = 1 := by
      field_simp [abs_of_real, of_real_inv, IsROrC.abs_inv, IsROrC.abs_div, IsROrC.abs_abs, h]
    have h1 : (fr (t • x) : 𝕜) = lm (t • x) := by
      apply ext
      · simp only [lm, of_real_re, LinearMap.extendTo𝕜'_apply, mul_re, I_re, of_real_im,
          MulZeroClass.zero_mul, AddMonoidHom.map_sub, sub_zero, MulZeroClass.mul_zero]
        rfl
      · symm
        calc
          im (lm (t • x)) = im (t * lm x) := by rw [lm.map_smul, smul_eq_mul]
          _ = im ((lm x)⁻¹ / abs𝕜 (lm x)⁻¹ * lm x) := rfl
          _ = im (1 / (abs𝕜 (lm x)⁻¹ : 𝕜)) := by rw [div_mul_eq_mul_div, inv_mul_cancel h]
          _ = 0 := by rw [← of_real_one, ← of_real_div, of_real_im]
          _ = im (fr (t • x) : 𝕜) := by rw [of_real_im]

    calc
      ‖lm x‖ = abs𝕜 t * ‖lm x‖ := by rw [ht, one_mul]
      _ = ‖t * lm x‖ := by rw [← norm_eq_abs, norm_mul]
      _ = ‖lm (t • x)‖ := by rw [← smul_eq_mul, lm.map_smul]
      _ = ‖(fr (t • x) : 𝕜)‖ := by rw [h1]
      _ = ‖fr (t • x)‖ := by rw [norm_eq_abs, abs_of_real, norm_eq_abs, abs_to_real]
      _ ≤ ‖fr‖ * ‖t • x‖ := (ContinuousLinearMap.le_op_norm _ _)
      _ = ‖fr‖ * (‖t‖ * ‖x‖) := by rw [norm_smul]
      _ ≤ ‖fr‖ * ‖x‖ := by rw [norm_eq_abs, ht, one_mul]

#align norm_bound norm_bound

/-- Extend `fr : F →L[ℝ] ℝ` to `F →L[𝕜] 𝕜`. -/
noncomputable def ContinuousLinearMap.extendTo𝕜' [NormedSpace ℝ F] [IsScalarTower ℝ 𝕜 F]
    (fr : F →L[ℝ] ℝ) : F →L[𝕜] 𝕜 :=
  LinearMap.mkContinuous _ ‖fr‖ (norm_bound _)
#align continuous_linear_map.extend_to_𝕜' ContinuousLinearMap.extendTo𝕜'

theorem ContinuousLinearMap.extendTo𝕜'_apply [NormedSpace ℝ F] [IsScalarTower ℝ 𝕜 F]
    (fr : F →L[ℝ] ℝ) (x : F) : fr.extendTo𝕜' x = (fr x : 𝕜) - (i : 𝕜) * fr ((i : 𝕜) • x) :=
  rfl
#align continuous_linear_map.extend_to_𝕜'_apply ContinuousLinearMap.extendTo𝕜'_apply

/-- Extend `fr : restrict_scalars ℝ 𝕜 F →ₗ[ℝ] ℝ` to `F →ₗ[𝕜] 𝕜`. -/
noncomputable def LinearMap.extendTo𝕜 (fr : RestrictScalars ℝ 𝕜 F →ₗ[ℝ] ℝ) : F →ₗ[𝕜] 𝕜 :=
  fr.extendTo𝕜'
#align linear_map.extend_to_𝕜 LinearMap.extendTo𝕜

theorem LinearMap.extendTo𝕜_apply (fr : RestrictScalars ℝ 𝕜 F →ₗ[ℝ] ℝ) (x : F) :
    fr.extendTo𝕜 x = (fr x : 𝕜) - (i : 𝕜) * fr ((i : 𝕜) • x : _) :=
  rfl
#align linear_map.extend_to_𝕜_apply LinearMap.extendTo𝕜_apply

/-- Extend `fr : restrict_scalars ℝ 𝕜 F →L[ℝ] ℝ` to `F →L[𝕜] 𝕜`. -/
noncomputable def ContinuousLinearMap.extendTo𝕜 (fr : RestrictScalars ℝ 𝕜 F →L[ℝ] ℝ) : F →L[𝕜] 𝕜 :=
  fr.extendTo𝕜'
#align continuous_linear_map.extend_to_𝕜 ContinuousLinearMap.extendTo𝕜

theorem ContinuousLinearMap.extendTo𝕜_apply (fr : RestrictScalars ℝ 𝕜 F →L[ℝ] ℝ) (x : F) :
    fr.extendTo𝕜 x = (fr x : 𝕜) - (i : 𝕜) * fr ((i : 𝕜) • x : _) :=
  rfl
#align continuous_linear_map.extend_to_𝕜_apply ContinuousLinearMap.extendTo𝕜_apply


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

import data.rat.meta_defs
import tactic.norm_num
import data.tree
import meta.expr

/-!
# A tactic for canceling numeric denominators

This file defines tactics that cancel numeric denominators from field expressions.

As an example, we want to transform a comparison `5*(a/3 + b/4) < c/3` into the equivalent
`5*(4*a + 3*b) < 4*c`.

## Implementation notes

The tooling here was originally written for `linarith`, not intended as an interactive tactic.
The interactive version has been split off because it is sometimes convenient to use on its own.
There are likely some rough edges to it.

Improving this tactic would be a good project for someone interested in learning tactic programming.
-/

namespace cancel_factors

/-! ### Lemmas used in the procedure -/

lemma mul_subst {α} [comm_ring α] {n1 n2 k e1 e2 t1 t2 : α} (h1 : n1 * e1 = t1) (h2 : n2 * e2 = t2)
     (h3 : n1*n2 = k) : k * (e1 * e2) = t1 * t2 :=
have h3 : n1 * n2 = k, from h3,
by rw [←h3, mul_comm n1, mul_assoc n2, ←mul_assoc n1, h1, ←mul_assoc n2, mul_comm n2, mul_assoc, h2]

lemma div_subst {α} [field α] {n1 n2 k e1 e2 t1 : α} (h1 : n1 * e1 = t1) (h2 : n2 / e2 = 1)
   (h3 : n1*n2 = k) : k * (e1 / e2) = t1 :=
by rw [←h3, mul_assoc, mul_div_comm, h2, ←mul_assoc, h1, mul_comm, one_mul]

lemma cancel_factors_eq_div {α} [field α] {n e e' : α} (h : n*e = e') (h2 : n ≠ 0) :
  e = e' / n :=
eq_div_of_mul_eq h2 $ by rwa mul_comm at h

lemma add_subst {α} [ring α] {n e1 e2 t1 t2 : α} (h1 : n * e1 = t1) (h2 : n * e2 = t2) :
      n * (e1 + e2) = t1 + t2 := by simp [left_distrib, *]

lemma sub_subst {α} [ring α] {n e1 e2 t1 t2 : α} (h1 : n * e1 = t1) (h2 : n * e2 = t2) :
      n * (e1 - e2) = t1 - t2 := by simp [left_distrib, *, sub_eq_add_neg]

lemma neg_subst {α} [ring α] {n e t : α} (h1 : n * e = t) : n * (-e) = -t := by simp *

lemma cancel_factors_lt {α} [linear_ordered_field α] {a b ad bd a' b' gcd : α} (ha : ad*a = a')
  (hb : bd*b = b') (had : 0 < ad) (hbd : 0 < bd) (hgcd : 0 < gcd) :
  a < b = ((1/gcd)*(bd*a') < (1/gcd)*(ad*b')) :=
begin
  rw [mul_lt_mul_left, ←ha, ←hb, ←mul_assoc, ←mul_assoc, mul_comm bd, mul_lt_mul_left],
  exact mul_pos had hbd,
  exact one_div_pos.2 hgcd
end

lemma cancel_factors_le {α} [linear_ordered_field α] {a b ad bd a' b' gcd : α} (ha : ad*a = a')
  (hb : bd*b = b') (had : 0 < ad) (hbd : 0 < bd) (hgcd : 0 < gcd)  :
  a ≤ b = ((1/gcd)*(bd*a') ≤ (1/gcd)*(ad*b')) :=
begin
  rw [mul_le_mul_left, ←ha, ←hb, ←mul_assoc, ←mul_assoc, mul_comm bd, mul_le_mul_left],
  exact mul_pos had hbd,
  exact one_div_pos.2 hgcd
end

lemma cancel_factors_eq {α} [linear_ordered_field α] {a b ad bd a' b' gcd : α} (ha : ad*a = a')
  (hb : bd*b = b') (had : 0 < ad) (hbd : 0 < bd) (hgcd : 0 < gcd) :
  a = b = ((1/gcd)*(bd*a') = (1/gcd)*(ad*b')) :=
begin
  rw [←ha, ←hb, ←mul_assoc bd, ←mul_assoc ad, mul_comm bd],
  ext, split,
  { rintro rfl, refl },
  { intro h,
    simp only [←mul_assoc] at h,
    refine mul_left_cancel' (mul_ne_zero _ _) h,
    apply mul_ne_zero, apply div_ne_zero,
    all_goals {apply ne_of_gt; assumption <|> exact zero_lt_one}}
end

open tactic expr

/-! ### Computing cancelation factors -/

open tree

/--
`find_cancel_factor e` produces a natural number `n`, such that multiplying `e` by `n` will
be able to cancel all the numeric denominators in `e`. The returned `tree` describes how to
distribute the value `n` over products inside `e`.
-/
meta def find_cancel_factor : expr → ℕ × tree ℕ
| `(%%e1 + %%e2) :=
  let (v1, t1) := find_cancel_factor e1, (v2, t2) := find_cancel_factor e2, lcm := v1.lcm v2 in
  (lcm, node lcm t1 t2)
| `(%%e1 - %%e2) :=
  let (v1, t1) := find_cancel_factor e1, (v2, t2) := find_cancel_factor e2, lcm := v1.lcm v2 in
  (lcm, node lcm t1 t2)
| `(%%e1 * %%e2) :=
  let (v1, t1) := find_cancel_factor e1, (v2, t2) := find_cancel_factor e2, pd := v1*v2 in
  (pd, node pd t1 t2)
| `(%%e1 / %%e2) :=
  match e2.to_nonneg_rat with
  | some q := let (v1, t1) := find_cancel_factor e1, n := v1.lcm q.num.nat_abs in
    (n, node n t1 (node q.num.nat_abs tree.nil tree.nil))
  | none := (1, node 1 tree.nil tree.nil)
  end
| `(-%%e) := find_cancel_factor e
| _ := (1, node 1 tree.nil tree.nil)

/--
`mk_prod_prf n tr e` produces a proof of `n*e = e'`, where numeric denominators have been
canceled in `e'`, distributing `n` proportionally according to `tr`.
-/
meta def mk_prod_prf : ℕ → tree ℕ → expr → tactic expr
| v (node _ lhs rhs) `(%%e1 + %%e2) :=
  do v1 ← mk_prod_prf v lhs e1, v2 ← mk_prod_prf v rhs e2, mk_app ``add_subst [v1, v2]
| v (node _ lhs rhs) `(%%e1 - %%e2) :=
  do v1 ← mk_prod_prf v lhs e1, v2 ← mk_prod_prf v rhs e2, mk_app ``sub_subst [v1, v2]
| v (node n lhs@(node ln _ _) rhs) `(%%e1 * %%e2) :=
  do tp ← infer_type e1, v1 ← mk_prod_prf ln lhs e1, v2 ← mk_prod_prf (v/ln) rhs e2,
     ln' ← tp.of_nat ln, vln' ← tp.of_nat (v/ln), v' ← tp.of_nat v,
     ntp ← to_expr ``(%%ln' * %%vln' = %%v'),
     (_, npf) ← solve_aux ntp `[norm_num, done],
     mk_app ``mul_subst [v1, v2, npf]
| v (node n lhs rhs@(node rn _ _)) `(%%e1 / %%e2) :=
  do tp ← infer_type e1, v1 ← mk_prod_prf (v/rn) lhs e1,
     rn' ← tp.of_nat rn, vrn' ← tp.of_nat (v/rn), n' ← tp.of_nat n, v' ← tp.of_nat v,
     ntp ← to_expr ``(%%rn' / %%e2 = 1),
     (_, npf) ← solve_aux ntp `[norm_num, done],
     ntp2 ← to_expr ``(%%vrn' * %%n' = %%v'),
     (_, npf2) ← solve_aux ntp2 `[norm_num, done],
     mk_app ``div_subst [v1, npf, npf2]
| v t `(-%%e) := do v' ← mk_prod_prf v t e, mk_app ``neg_subst [v']
| v _ e :=
  do tp ← infer_type e,
     v' ← tp.of_nat v,
     e' ← to_expr ``(%%v' * %%e),
     mk_app `eq.refl [e']

/--
Given `e`, a term with rational division, produces a natural number `n` and a proof of `n*e = e'`,
where `e'` has no division. Assumes "well-behaved" division.
-/
meta def derive (e : expr) : tactic (ℕ × expr) :=
let (n, t) := find_cancel_factor e in
prod.mk n <$> mk_prod_prf n t e <|>
  fail!"cancel_factors.derive failed to normalize {e}. Are you sure this is well-behaved division?"

/--
Given `e`, a term with rational divison, produces a natural number `n` and a proof of `e = e' / n`,
where `e'` has no divison. Assumes "well-behaved" division.
-/
meta def derive_div (e : expr) : tactic (ℕ × expr) :=
do (n, p) ← derive e,
   tp ← infer_type e,
   n' ← tp.of_nat n, tgt ← to_expr ``(%%n' ≠ 0),
   (_, pn) ← solve_aux tgt `[norm_num, done],
   infer_type p >>= trace, infer_type pn >>= trace,
   prod.mk n <$> mk_mapp ``cancel_factors_eq_div [none, none, n', none, none, p, pn]

/--
`find_comp_lemma e` arranges `e` in the form `lhs R rhs`, where `R ∈ {<, ≤, =}`, and returns
`lhs`, `rhs`, and the `cancel_factors` lemma corresponding to `R`.
-/
meta def find_comp_lemma : expr → option (expr × expr × name)
| `(%%a < %%b) := (a, b, ``cancel_factors_lt)
| `(%%a ≤ %%b) := (a, b, ``cancel_factors_le)
| `(%%a = %%b) := (a, b, ``cancel_factors_eq)
| `(%%a ≥ %%b) := (b, a, ``cancel_factors_le)
| `(%%a > %%b) := (b, a, ``cancel_factors_lt)
| _ := none

/--
`cancel_denominators_in_type h` assumes that `h` is of the form `lhs R rhs`,
where `R ∈ {<, ≤, =, ≥, >}`.
It produces an expression `h'` of the form `lhs' R rhs'` and a proof that `h = h'`.
Numeric denominators have been canceled in `lhs'` and `rhs'`.
-/
meta def cancel_denominators_in_type (h : expr) : tactic (expr × expr) :=
do some (lhs, rhs, lem) ← return $ find_comp_lemma h | fail "cannot kill factors",
   (al, lhs_p) ← derive lhs,
   (ar, rhs_p) ← derive rhs,
   let gcd := al.gcd ar,
   tp ← infer_type lhs,
   al ← tp.of_nat al,
   ar ← tp.of_nat ar,
   gcd ← tp.of_nat gcd,
   al_pos ← to_expr ``(0 < %%al),
   ar_pos ← to_expr ``(0 < %%ar),
   gcd_pos ← to_expr ``(0 < %%gcd),
   (_, al_pos) ← solve_aux al_pos `[norm_num, done],
   (_, ar_pos) ← solve_aux ar_pos `[norm_num, done],
   (_, gcd_pos) ← solve_aux gcd_pos `[norm_num, done],
   pf ← mk_app lem [lhs_p, rhs_p, al_pos, ar_pos, gcd_pos],
   pf_tp ← infer_type pf,
   return ((find_comp_lemma pf_tp).elim (default _) (prod.fst ∘ prod.snd), pf)

end cancel_factors

/-! ### Interactive version -/

setup_tactic_parser
open tactic expr cancel_factors

/--
`cancel_denoms` attempts to remove numerals from the denominators of fractions.
It works on propositions that are field-valued inequalities.

```lean
variables {α : Type} [linear_ordered_field α] (a b c : α)

example (h : a / 5 + b / 4 < c) : 4*a + 5*b < 20*c :=
begin
  cancel_denoms at h,
  exact h
end

example (h : a > 0) : a / 5 > 0 :=
begin
  cancel_denoms,
  exact h
end
```
-/
meta def tactic.interactive.cancel_denoms (l : parse location) : tactic unit :=
do locs ← l.get_locals,
   tactic.replace_at cancel_denominators_in_type locs l.include_goal >>= guardb
     <|> fail "failed to cancel any denominators",
   tactic.interactive.norm_num [simp_arg_type.symm_expr ``(mul_assoc)] l

add_tactic_doc
{ name := "cancel_denoms",
  category := doc_category.tactic,
  decl_names := [`tactic.interactive.cancel_denoms],
  tags := ["simplification"] }


variables p q r : Prop

theorem t2 (h₁ : q → r) (h₂ : p → q) : p → r :=
  assume h₃ : p,
  show r, from h₁ (h₂ h₃)


/- Some theorems about list intersection -/

namespace list

@[simp]
theorem nil_inter {α : Type} [decidable_eq α] (x : list α) : list.nil ∩ x = [] := rfl

@[simp]
theorem cons_inter {α : Type} [decidable_eq α] (a : α) (x y : list α)
: (a::x) ∩ y = if a ∈ y then a :: (x ∩ y) else x ∩ y := rfl

@[simp]
theorem inter_nil {α : Type} [decidable_eq α] (x : list α) : x ∩ list.nil = [] :=
begin
  induction x with v xr ind,
  { refl, },
  { simp [cons_inter, ind], },
end

theorem inter_conjunction {α : Type} [decidable_eq α] (e : α) (x y : list α)
: e ∈ (x ∩ y) ↔ e ∈ x ∧ e ∈ y :=
begin
  induction x,
  case list.nil { simp, },
  case list.cons v xr ind {
    simp,
    by_cases (v ∈ y) with h,
    all_goals {
      simp [h, ind],
      by_cases (e = v) with e_eq_v,
      all_goals { simp [*], },
    },
  },
end

end list


/-
Copyright (c) 2019 The Flypitch Project. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.

Authors: Jesse Han, Floris van Doorn
-/
import .fol .zfc' .completeness

local attribute [instance, priority 0] classical.prop_decidable

open fol lattice

section independence

/- ¬ (T ⊢' f) is implied by ∃ M : Model T, M ⊢ ∼ f -/
lemma unprovable_of_model_negation {L : Language} {T : Theory L} {hT : is_consistent T} {f : sentence L} (S : Structure L) (hS : S ⊨ T) {h_nonempty : nonempty S} (hS' : S ⊨ ∼f) : ¬ (T ⊢' f) :=
begin
  revert hS', by_contra, have H : ¬S ⊨ f ∧ T ⊢' f, by {simp at a, exact a},
  suffices : S ⊨ f, by {apply false_of_Model_absurd ⟨S, hS⟩ this (by exact H.left)},
  apply (completeness T f).mp H.right, repeat{assumption}
end

lemma independence_of_exhibit_models {L : Language} {T : Theory L} {hT : is_consistent T} {f : sentence L} (M1 : Model T) (H1 : M1 ⊨ f) (M2 : Model T) (H2 : M2 ⊨ ∼f) {h_nonempty1 : nonempty M1.fst} {h_nonempty2 : nonempty M2.fst} : ((¬ T ⊢' f) ∧ (¬ T ⊢' ∼f)) :=
by exact ⟨by {apply unprovable_of_model_negation, exact hT, exact M2.snd, repeat{assumption}},
         by {apply unprovable_of_model_negation, exact hT, exact M1.snd, assumption, simpa}⟩

--TODO(everyone)
theorem CH_consistent {β} [nontrivial_complete_boolean_algebra β] : ∃ M : bModel β ZFC', (nonempty M.fst) ∧ ⊤ ⊩[M.1] CH_f := sorry

--TODO(jesse)
theorem neg_CH_consistent {β} [nontrivial_complete_boolean_algebra β] : ∃ M : bModel β ZFC', (nonempty M.fst) ∧ ⊤ ⊩[M.1] ∼ CH_f := sorry

-- theorem independence_of_CH : (¬ ZFC' ⊢' CH_f) ∧ (¬ ZFC' ⊢' ∼ CH_f) :=
-- begin
--   have := CH_consistent, have := neg_CH_consistent, repeat{auto_cases},
--   apply @independence_of_exhibit_models L_ZFC' ZFC' ZFC'_consistent CH_f,
--   show Model ZFC', exact this_w_1, show Model ZFC', exact this_w, repeat{assumption}
-- end

end independence


/-
Copyright (c) 2018 Chris Hughes. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Chris Hughes, Johannes Hölzl, Scott Morrison, Jens Wagemaker
-/
import algebra.gcd_monoid.basic
import data.polynomial.derivative
import data.polynomial.ring_division
import data.set.pairwise
import ring_theory.coprime.lemmas
import ring_theory.euclidean_domain

/-!
# Theory of univariate polynomials

This file starts looking like the ring theory of $ R[X] $

-/

noncomputable theory
open_locale classical big_operators

namespace polynomial
universes u v w y z
variables {R : Type u} {S : Type v} {k : Type y} {A : Type z} {a b : R} {n : ℕ}

section is_domain
variables [comm_ring R] [is_domain R]

section normalization_monoid
variables [normalization_monoid R]

instance : normalization_monoid (polynomial R) :=
{ norm_unit := λ p, ⟨C ↑(norm_unit (p.leading_coeff)), C ↑(norm_unit (p.leading_coeff))⁻¹,
    by rw [← ring_hom.map_mul, units.mul_inv, C_1], by rw [← ring_hom.map_mul, units.inv_mul, C_1]⟩,
  norm_unit_zero := units.ext (by simp),
  norm_unit_mul := λ p q hp0 hq0, units.ext (begin
      dsimp,
      rw [ne.def, ← leading_coeff_eq_zero] at *,
      rw [leading_coeff_mul, norm_unit_mul hp0 hq0, units.coe_mul, C_mul],
    end),
  norm_unit_coe_units := λ u,
    units.ext begin
      rw [← mul_one u⁻¹, units.coe_mul, units.eq_inv_mul_iff_mul_eq],
      dsimp,
      rcases polynomial.is_unit_iff.1 ⟨u, rfl⟩ with ⟨_, ⟨w, rfl⟩, h2⟩,
      rw [← h2, leading_coeff_C, norm_unit_coe_units, ← C_mul, units.mul_inv, C_1],
    end }

@[simp]
lemma coe_norm_unit {p : polynomial R} :
  (norm_unit p : polynomial R) = C ↑(norm_unit p.leading_coeff) :=
by simp [norm_unit]

lemma leading_coeff_normalize (p : polynomial R) :
  leading_coeff (normalize p) = normalize (leading_coeff p) := by simp

lemma monic.normalize_eq_self {p : polynomial R} (hp : p.monic) :
  normalize p = p :=
by simp only [polynomial.coe_norm_unit, normalize_apply, hp.leading_coeff, norm_unit_one,
  units.coe_one, polynomial.C.map_one, mul_one]

end normalization_monoid

lemma prod_multiset_root_eq_finset_root {p : polynomial R} :
  (multiset.map (λ (a : R), X - C a) p.roots).prod =
  ∏ a in p.roots.to_finset, (X - C a) ^ root_multiplicity a p :=
by simp only [count_roots, finset.prod_multiset_map_count]

lemma roots_C_mul (p : polynomial R) {a : R} (hzero : a ≠ 0) : (C a * p).roots = p.roots :=
begin
  by_cases hpzero : p = 0,
  { simp only [hpzero, mul_zero] },
  rw multiset.ext,
  intro b,
  have prodzero : C a * p ≠ 0,
  { simp only [hpzero, or_false, ne.def, mul_eq_zero, C_eq_zero, hzero, not_false_iff] },
  rw [count_roots, count_roots, root_multiplicity_mul prodzero],
  have mulzero : root_multiplicity b (C a) = 0,
  { simp only [hzero, root_multiplicity_eq_zero, eval_C, is_root.def, not_false_iff] },
  simp only [mulzero, zero_add]
end

lemma roots_normalize [normalization_monoid R] {p : polynomial R} : (normalize p).roots = p.roots :=
by rw [normalize_apply, mul_comm, coe_norm_unit,
  roots_C_mul _ (norm_unit (leading_coeff p)).ne_zero]

end is_domain

section division_ring
variables [division_ring R] {p q : polynomial R}

lemma degree_pos_of_ne_zero_of_nonunit (hp0 : p ≠ 0) (hp : ¬is_unit p) :
  0 < degree p :=
lt_of_not_ge (λ h, begin
  rw [eq_C_of_degree_le_zero h] at hp0 hp,
  exact hp (is_unit.map (C.to_monoid_hom : R →* _)
    (is_unit.mk0 (coeff p 0) (mt C_inj.2 (by simpa using hp0)))),
end)

lemma monic_mul_leading_coeff_inv (h : p ≠ 0) :
  monic (p * C (leading_coeff p)⁻¹) :=
by rw [monic, leading_coeff_mul, leading_coeff_C,
  mul_inv_cancel (show leading_coeff p ≠ 0, from mt leading_coeff_eq_zero.1 h)]

lemma degree_mul_leading_coeff_inv (p : polynomial R) (h : q ≠ 0) :
  degree (p * C (leading_coeff q)⁻¹) = degree p :=
have h₁ : (leading_coeff q)⁻¹ ≠ 0 :=
  inv_ne_zero (mt leading_coeff_eq_zero.1 h),
by rw [degree_mul, degree_C h₁, add_zero]

end division_ring

section field
variables [field R] {p q : polynomial R}

lemma is_unit_iff_degree_eq_zero : is_unit p ↔ degree p = 0 :=
⟨degree_eq_zero_of_is_unit,
  λ h, have degree p ≤ 0, by simp [*, le_refl],
    have hc : coeff p 0 ≠ 0, from λ hc,
        by rw [eq_C_of_degree_le_zero this, hc] at h;
        simpa using h,
    is_unit_iff_dvd_one.2 ⟨C (coeff p 0)⁻¹, begin
      conv in p { rw eq_C_of_degree_le_zero this },
      rw [← C_mul, _root_.mul_inv_cancel hc, C_1]
    end⟩⟩

theorem irreducible_of_monic {p : polynomial R} (hp1 : p.monic) (hp2 : p ≠ 1) :
  irreducible p ↔ (∀ f g : polynomial R, f.monic → g.monic → f * g = p → f = 1 ∨ g = 1) :=
⟨λ hp3 f g hf hg hfg, or.cases_on (hp3.is_unit_or_is_unit hfg.symm)
  (assume huf : is_unit f, or.inl $ eq_one_of_is_unit_of_monic hf huf)
  (assume hug : is_unit g, or.inr $ eq_one_of_is_unit_of_monic hg hug),
λ hp3, ⟨mt (eq_one_of_is_unit_of_monic hp1) hp2, λ f g hp,
have hf : f ≠ 0, from λ hf, by { rw [hp, hf, zero_mul] at hp1, exact not_monic_zero hp1 },
have hg : g ≠ 0, from λ hg, by { rw [hp, hg, mul_zero] at hp1, exact not_monic_zero hp1 },
or.imp (λ hf, is_unit_of_mul_eq_one _ _ hf) (λ hg, is_unit_of_mul_eq_one _ _ hg) $
hp3 (f * C f.leading_coeff⁻¹) (g * C g.leading_coeff⁻¹)
  (monic_mul_leading_coeff_inv hf) (monic_mul_leading_coeff_inv hg) $
by rw [mul_assoc, mul_left_comm _ g, ← mul_assoc, ← C_mul, ← mul_inv₀, ← leading_coeff_mul,
    ← hp, monic.def.1 hp1, inv_one, C_1, mul_one]⟩⟩

/-- Division of polynomials. See polynomial.div_by_monic for more details.-/
def div (p q : polynomial R) :=
C (leading_coeff q)⁻¹ * (p /ₘ (q * C (leading_coeff q)⁻¹))

/-- Remainder of polynomial division, see the lemma `quotient_mul_add_remainder_eq_aux`.
See polynomial.mod_by_monic for more details. -/
def mod (p q : polynomial R) :=
p %ₘ (q * C (leading_coeff q)⁻¹)

private lemma quotient_mul_add_remainder_eq_aux (p q : polynomial R) :
  q * div p q + mod p q = p :=
if h : q = 0 then by simp only [h, zero_mul, mod, mod_by_monic_zero, zero_add]
else begin
  conv {to_rhs, rw ← mod_by_monic_add_div p (monic_mul_leading_coeff_inv h)},
  rw [div, mod, add_comm, mul_assoc]
end

private lemma remainder_lt_aux (p : polynomial R) (hq : q ≠ 0) :
  degree (mod p q) < degree q :=
by rw ← degree_mul_leading_coeff_inv q hq; exact
  degree_mod_by_monic_lt p (monic_mul_leading_coeff_inv hq)

instance : has_div (polynomial R) := ⟨div⟩

instance : has_mod (polynomial R) := ⟨mod⟩

lemma div_def : p / q = C (leading_coeff q)⁻¹ * (p /ₘ (q * C (leading_coeff q)⁻¹)) := rfl

lemma mod_def : p % q = p %ₘ (q * C (leading_coeff q)⁻¹) := rfl

lemma mod_by_monic_eq_mod (p : polynomial R) (hq : monic q) : p %ₘ q = p % q :=
show p %ₘ q = p %ₘ (q * C (leading_coeff q)⁻¹), by simp only [monic.def.1 hq, inv_one, mul_one, C_1]

lemma div_by_monic_eq_div (p : polynomial R) (hq : monic q) : p /ₘ q = p / q :=
show p /ₘ q = C (leading_coeff q)⁻¹ * (p /ₘ (q * C (leading_coeff q)⁻¹)),
by simp only [monic.def.1 hq, inv_one, C_1, one_mul, mul_one]

lemma mod_X_sub_C_eq_C_eval (p : polynomial R) (a : R) : p % (X - C a) = C (p.eval a) :=
mod_by_monic_eq_mod p (monic_X_sub_C a) ▸ mod_by_monic_X_sub_C_eq_C_eval _ _

lemma mul_div_eq_iff_is_root : (X - C a) * (p / (X - C a)) = p ↔ is_root p a :=
div_by_monic_eq_div p (monic_X_sub_C a) ▸ mul_div_by_monic_eq_iff_is_root

instance : euclidean_domain (polynomial R) :=
{ quotient := (/),
  quotient_zero := by simp [div_def],
  remainder := (%),
  r := _,
  r_well_founded := degree_lt_wf,
  quotient_mul_add_remainder_eq := quotient_mul_add_remainder_eq_aux,
  remainder_lt := λ p q hq, remainder_lt_aux _ hq,
  mul_left_not_lt := λ p q hq, not_lt_of_ge (degree_le_mul_left _ hq),
  .. polynomial.comm_ring,
  .. polynomial.nontrivial }

lemma mod_eq_self_iff (hq0 : q ≠ 0) : p % q = p ↔ degree p < degree q :=
⟨λ h, h ▸ euclidean_domain.mod_lt _ hq0,
λ h, have ¬degree (q * C (leading_coeff q)⁻¹) ≤ degree p :=
  not_le_of_gt $ by rwa degree_mul_leading_coeff_inv q hq0,
begin
  rw [mod_def, mod_by_monic, dif_pos (monic_mul_leading_coeff_inv hq0)],
  unfold div_mod_by_monic_aux,
  simp only [this, false_and, if_false]
end⟩

lemma div_eq_zero_iff (hq0 : q ≠ 0) : p / q = 0 ↔ degree p < degree q :=
⟨λ h, by have := euclidean_domain.div_add_mod p q;
  rwa [h, mul_zero, zero_add, mod_eq_self_iff hq0] at this,
λ h, have hlt : degree p < degree (q * C (leading_coeff q)⁻¹),
    by rwa degree_mul_leading_coeff_inv q hq0,
  have hm : monic (q * C (leading_coeff q)⁻¹) := monic_mul_leading_coeff_inv hq0,
  by rw [div_def, (div_by_monic_eq_zero_iff hm).2 hlt, mul_zero]⟩

lemma degree_add_div (hq0 : q ≠ 0) (hpq : degree q ≤ degree p) :
  degree q + degree (p / q) = degree p :=
have degree (p % q) < degree (q * (p / q)) :=
  calc degree (p % q) < degree q : euclidean_domain.mod_lt _ hq0
  ... ≤ _ : degree_le_mul_left _ (mt (div_eq_zero_iff hq0).1 (not_lt_of_ge hpq)),
by conv_rhs { rw [← euclidean_domain.div_add_mod p q,
    degree_add_eq_left_of_degree_lt this, degree_mul] }

lemma degree_div_le (p q : polynomial R) : degree (p / q) ≤ degree p :=
if hq : q = 0 then by simp [hq]
else by rw [div_def, mul_comm, degree_mul_leading_coeff_inv _ hq];
  exact degree_div_by_monic_le _ _

lemma degree_div_lt (hp : p ≠ 0) (hq : 0 < degree q) : degree (p / q) < degree p :=
have hq0 : q ≠ 0, from λ hq0, by simpa [hq0] using hq,
by rw [div_def, mul_comm, degree_mul_leading_coeff_inv _ hq0];
  exact degree_div_by_monic_lt _ (monic_mul_leading_coeff_inv hq0) hp
    (by rw degree_mul_leading_coeff_inv _ hq0; exact hq)

@[simp] lemma degree_map [field k] (p : polynomial R) (f : R →+* k) :
  degree (p.map f) = degree p :=
p.degree_map_eq_of_injective f.injective

@[simp] lemma nat_degree_map [field k] (f : R →+* k) :
  nat_degree (p.map f) = nat_degree p :=
nat_degree_eq_of_degree_eq (degree_map _ f)

@[simp] lemma leading_coeff_map [field k] (f : R →+* k) :
  leading_coeff (p.map f) = f (leading_coeff p) :=
by simp only [← coeff_nat_degree, coeff_map f, nat_degree_map]

theorem monic_map_iff [field k] {f : R →+* k} {p : polynomial R} :
  (p.map f).monic ↔ p.monic :=
by rw [monic, leading_coeff_map, ← f.map_one, function.injective.eq_iff f.injective, monic]

theorem is_unit_map [field k] (f : R →+* k) :
  is_unit (p.map f) ↔ is_unit p :=
by simp_rw [is_unit_iff_degree_eq_zero, degree_map]

lemma map_mod [field k] (f : R →+* k) :
  (p % q).map f = p.map f % q.map f :=
if hq0 : q = 0 then by simp [hq0]
else by rw [mod_def, mod_def, leading_coeff_map f, ← f.map_inv, ← map_C f,
  ← map_mul f, map_mod_by_monic f (monic_mul_leading_coeff_inv hq0)]

section
open euclidean_domain
theorem gcd_map [field k] (f : R →+* k) :
  gcd (p.map f) (q.map f) = (gcd p q).map f :=
gcd.induction p q (λ x, by simp_rw [map_zero, euclidean_domain.gcd_zero_left]) $ λ x y hx ih,
by rw [gcd_val, ← map_mod, ih, ← gcd_val]
end

lemma eval₂_gcd_eq_zero [comm_semiring k] {ϕ : R →+* k} {f g : polynomial R} {α : k}
  (hf : f.eval₂ ϕ α = 0) (hg : g.eval₂ ϕ α = 0) : (euclidean_domain.gcd f g).eval₂ ϕ α = 0 :=
by rw [euclidean_domain.gcd_eq_gcd_ab f g, polynomial.eval₂_add, polynomial.eval₂_mul,
       polynomial.eval₂_mul, hf, hg, zero_mul, zero_mul, zero_add]

lemma eval_gcd_eq_zero {f g : polynomial R} {α : R} (hf : f.eval α = 0) (hg : g.eval α = 0) :
  (euclidean_domain.gcd f g).eval α = 0 := eval₂_gcd_eq_zero hf hg

lemma root_left_of_root_gcd [comm_semiring k] {ϕ : R →+* k} {f g : polynomial R} {α : k}
  (hα : (euclidean_domain.gcd f g).eval₂ ϕ α = 0) : f.eval₂ ϕ α = 0 :=
by { cases euclidean_domain.gcd_dvd_left f g with p hp,
     rw [hp, polynomial.eval₂_mul, hα, zero_mul] }

lemma root_right_of_root_gcd [comm_semiring k] {ϕ : R →+* k} {f g : polynomial R} {α : k}
  (hα : (euclidean_domain.gcd f g).eval₂ ϕ α = 0) : g.eval₂ ϕ α = 0 :=
by { cases euclidean_domain.gcd_dvd_right f g with p hp,
     rw [hp, polynomial.eval₂_mul, hα, zero_mul] }

lemma root_gcd_iff_root_left_right [comm_semiring k] {ϕ : R →+* k} {f g : polynomial R} {α : k} :
  (euclidean_domain.gcd f g).eval₂ ϕ α = 0 ↔ (f.eval₂ ϕ α = 0) ∧ (g.eval₂ ϕ α = 0) :=
⟨λ h, ⟨root_left_of_root_gcd h, root_right_of_root_gcd h⟩, λ h, eval₂_gcd_eq_zero h.1 h.2⟩

lemma is_root_gcd_iff_is_root_left_right {f g : polynomial R} {α : R} :
  (euclidean_domain.gcd f g).is_root α ↔ f.is_root α ∧ g.is_root α :=
root_gcd_iff_root_left_right

theorem is_coprime_map [field k] (f : R →+* k) :
  is_coprime (p.map f) (q.map f) ↔ is_coprime p q :=
by rw [← euclidean_domain.gcd_is_unit_iff, ← euclidean_domain.gcd_is_unit_iff, gcd_map, is_unit_map]

@[simp] lemma map_eq_zero [semiring S] [nontrivial S] (f : R →+* S) :
  p.map f = 0 ↔ p = 0 :=
by simp only [polynomial.ext_iff, f.map_eq_zero, coeff_map, coeff_zero]

lemma map_ne_zero [semiring S] [nontrivial S] {f : R →+* S} (hp : p ≠ 0) : p.map f ≠ 0 :=
mt (map_eq_zero f).1 hp

lemma mem_roots_map [field k] {f : R →+* k} {x : k} (hp : p ≠ 0) :
  x ∈ (p.map f).roots ↔ p.eval₂ f x = 0 :=
begin
  rw mem_roots (show p.map f ≠ 0, by exact map_ne_zero hp),
  dsimp only [is_root],
  rw polynomial.eval_map,
end

lemma mem_root_set [field k] [algebra R k] {x : k} (hp : p ≠ 0) :
  x ∈ p.root_set k ↔ aeval x p = 0 :=
iff.trans multiset.mem_to_finset (mem_roots_map hp)

lemma root_set_C_mul_X_pow {R S : Type*} [field R] [field S] [algebra R S]
  {n : ℕ} (hn : n ≠ 0) {a : R} (ha : a ≠ 0) : (C a * X ^ n).root_set S = {0} :=
begin
  ext x,
  rw [set.mem_singleton_iff, mem_root_set, aeval_mul, aeval_C, aeval_X_pow, mul_eq_zero],
  { simp_rw [ring_hom.map_eq_zero, pow_eq_zero_iff (nat.pos_of_ne_zero hn), or_iff_right_iff_imp],
    exact λ ha', (ha ha').elim },
  { exact mul_ne_zero (mt C_eq_zero.mp ha) (pow_ne_zero n X_ne_zero) },
end

lemma root_set_monomial {R S : Type*} [field R] [field S] [algebra R S]
  {n : ℕ} (hn : n ≠ 0) {a : R} (ha : a ≠ 0) : (monomial n a).root_set S = {0} :=
by rw [←C_mul_X_pow_eq_monomial, root_set_C_mul_X_pow hn ha]

lemma root_set_X_pow {R S : Type*} [field R] [field S] [algebra R S]
  {n : ℕ} (hn : n ≠ 0) : (X ^ n : polynomial R).root_set S = {0} :=
by { rw [←one_mul (X ^ n : polynomial R), ←C_1, root_set_C_mul_X_pow hn], exact one_ne_zero }

lemma exists_root_of_degree_eq_one (h : degree p = 1) : ∃ x, is_root p x :=
⟨-(p.coeff 0 / p.coeff 1),
  have p.coeff 1 ≠ 0,
    by rw ← nat_degree_eq_of_degree_eq_some h;
    exact mt leading_coeff_eq_zero.1 (λ h0, by simpa [h0] using h),
  by conv in p { rw [eq_X_add_C_of_degree_le_one (show degree p ≤ 1, by rw h; exact le_rfl)] };
    simp [is_root, mul_div_cancel' _ this]⟩

lemma coeff_inv_units (u : (polynomial R)ˣ) (n : ℕ) :
  ((↑u : polynomial R).coeff n)⁻¹ = ((↑u⁻¹ : polynomial R).coeff n) :=
begin
  rw [eq_C_of_degree_eq_zero (degree_coe_units u), eq_C_of_degree_eq_zero (degree_coe_units u⁻¹),
    coeff_C, coeff_C, inv_eq_one_div],
  split_ifs,
  { rw [div_eq_iff_mul_eq (coeff_coe_units_zero_ne_zero u), coeff_zero_eq_eval_zero,
      coeff_zero_eq_eval_zero, ← eval_mul, ← units.coe_mul, inv_mul_self];
    simp },
  { simp }
end

lemma monic_normalize (hp0 : p ≠ 0) : monic (normalize p) :=
begin
  rw [ne.def, ← leading_coeff_eq_zero, ← ne.def, ← is_unit_iff_ne_zero] at hp0,
  rw [monic, leading_coeff_normalize, normalize_eq_one],
  apply hp0,
end

lemma leading_coeff_div (hpq : q.degree ≤ p.degree) :
  (p / q).leading_coeff = p.leading_coeff / q.leading_coeff :=
begin
  by_cases hq : q = 0, { simp [hq] },
  rw [div_def, leading_coeff_mul, leading_coeff_C,
      leading_coeff_div_by_monic_of_monic (monic_mul_leading_coeff_inv hq) _,
      mul_comm, div_eq_mul_inv],
  rwa [degree_mul_leading_coeff_inv q hq]
end

lemma div_C_mul : p / (C a * q) = C a⁻¹ * (p / q) :=
begin
  by_cases ha : a = 0,
  { simp [ha] },
  simp only [div_def, leading_coeff_mul, mul_inv₀,
    leading_coeff_C, C.map_mul, mul_assoc],
  congr' 3,
  rw [mul_left_comm q, ← mul_assoc, ← C.map_mul, mul_inv_cancel ha,
      C.map_one, one_mul]
end

lemma C_mul_dvd (ha : a ≠ 0) : C a * p ∣ q ↔ p ∣ q :=
⟨λ h, dvd_trans (dvd_mul_left _ _) h, λ ⟨r, hr⟩, ⟨C a⁻¹ * r,
  by rw [mul_assoc, mul_left_comm p, ← mul_assoc, ← C.map_mul, _root_.mul_inv_cancel ha,
         C.map_one, one_mul, hr]⟩⟩

lemma dvd_C_mul (ha : a ≠ 0) : p ∣ polynomial.C a * q ↔ p ∣ q :=
⟨λ ⟨r, hr⟩, ⟨C a⁻¹ * r,
  by rw [mul_left_comm p, ← hr, ← mul_assoc, ← C.map_mul, _root_.inv_mul_cancel ha,
         C.map_one, one_mul]⟩,
 λ h, dvd_trans h (dvd_mul_left _ _)⟩

lemma coe_norm_unit_of_ne_zero (hp : p ≠ 0) : (norm_unit p : polynomial R) = C p.leading_coeff⁻¹ :=
have p.leading_coeff ≠ 0 := mt leading_coeff_eq_zero.mp hp,
by simp [comm_group_with_zero.coe_norm_unit _ this]

lemma normalize_monic (h : monic p) : normalize p = p := by simp [h]

theorem map_dvd_map' [field k] (f : R →+* k) {x y : polynomial R} : x.map f ∣ y.map f ↔ x ∣ y :=
if H : x = 0 then by rw [H, map_zero, zero_dvd_iff, zero_dvd_iff, map_eq_zero]
else by rw [← normalize_dvd_iff, ← @normalize_dvd_iff (polynomial R),
    normalize_apply, normalize_apply,
    coe_norm_unit_of_ne_zero H, coe_norm_unit_of_ne_zero (mt (map_eq_zero f).1 H),
    leading_coeff_map, ← f.map_inv, ← map_C, ← map_mul,
    map_dvd_map _ f.injective (monic_mul_leading_coeff_inv H)]

lemma degree_normalize : degree (normalize p) = degree p := by simp

lemma prime_of_degree_eq_one (hp1 : degree p = 1) : prime p :=
have prime (normalize p),
  from monic.prime_of_degree_eq_one (hp1 ▸ degree_normalize)
    (monic_normalize (λ hp0, absurd hp1 (hp0.symm ▸ by simp; exact dec_trivial))),
(normalize_associated _).prime this

lemma irreducible_of_degree_eq_one (hp1 : degree p = 1) : irreducible p :=
(prime_of_degree_eq_one hp1).irreducible

theorem not_irreducible_C (x : R) : ¬irreducible (C x) :=
if H : x = 0 then by { rw [H, C_0], exact not_irreducible_zero }
else λ hx, irreducible.not_unit hx $ is_unit_C.2 $ is_unit_iff_ne_zero.2 H

theorem degree_pos_of_irreducible (hp : irreducible p) : 0 < p.degree :=
lt_of_not_ge $ λ hp0, have _ := eq_C_of_degree_le_zero hp0,
  not_irreducible_C (p.coeff 0) $ this ▸ hp

theorem pairwise_coprime_X_sub {α : Type u} [field α] {I : Type v}
  {s : I → α} (H : function.injective s) :
  pairwise (is_coprime on (λ i : I, polynomial.X - polynomial.C (s i))) :=
λ i j hij, have h : s j - s i ≠ 0, from sub_ne_zero_of_ne $ function.injective.ne H hij.symm,
⟨polynomial.C (s j - s i)⁻¹, -polynomial.C (s j - s i)⁻¹,
by rw [neg_mul_eq_neg_mul_symm, ← sub_eq_add_neg, ← mul_sub, sub_sub_sub_cancel_left,
    ← polynomial.C_sub, ← polynomial.C_mul, inv_mul_cancel h, polynomial.C_1]⟩

/-- If `f` is a polynomial over a field, and `a : K` satisfies `f' a ≠ 0`,
then `f / (X - a)` is coprime with `X - a`.
Note that we do not assume `f a = 0`, because `f / (X - a) = (f - f a) / (X - a)`. -/
lemma is_coprime_of_is_root_of_eval_derivative_ne_zero {K : Type*} [field K]
  (f : polynomial K) (a : K) (hf' : f.derivative.eval a ≠ 0) :
  is_coprime (X - C a : polynomial K) (f /ₘ (X - C a)) :=
begin
  refine or.resolve_left (euclidean_domain.dvd_or_coprime (X - C a) (f /ₘ (X - C a))
    (irreducible_of_degree_eq_one (polynomial.degree_X_sub_C a))) _,
  contrapose! hf' with h,
  have key : (X - C a) * (f /ₘ (X - C a)) = f - (f %ₘ (X - C a)),
  { rw [eq_sub_iff_add_eq, ← eq_sub_iff_add_eq', mod_by_monic_eq_sub_mul_div],
    exact monic_X_sub_C a },
  replace key := congr_arg derivative key,
  simp only [derivative_X, derivative_mul, one_mul, sub_zero, derivative_sub,
    mod_by_monic_X_sub_C_eq_C_eval, derivative_C] at key,
  have : (X - C a) ∣ derivative f := key ▸ (dvd_add h (dvd_mul_right _ _)),
  rw [← dvd_iff_mod_by_monic_eq_zero (monic_X_sub_C _), mod_by_monic_X_sub_C_eq_C_eval] at this,
  rw [← C_inj, this, C_0],
end

/-- The product `∏ (X - a)` for `a` inside the multiset `p.roots` divides `p`. -/
lemma prod_multiset_X_sub_C_dvd (p : polynomial R) :
  (multiset.map (λ (a : R), X - C a) p.roots).prod ∣ p :=
begin
  rw prod_multiset_root_eq_finset_root,
  have hcoprime : pairwise (is_coprime on λ (a : R), polynomial.X - C (id a)) :=
    pairwise_coprime_X_sub function.injective_id,
  have H : pairwise (is_coprime on λ (a : R), (polynomial.X - C (id a)) ^ (root_multiplicity a p)),
  { intros a b hdiff, exact (hcoprime a b hdiff).pow },
  apply finset.prod_dvd_of_coprime (H.set_pairwise (↑(multiset.to_finset p.roots) : set R)),
  intros a h,
  rw multiset.mem_to_finset at h,
  exact pow_root_multiplicity_dvd p a
end

end field
end polynomial


namespace hidden

/-
4. Below, we have put definitions of divides and even in a special namespace to avoid conflicts with definitions in the library. The instance declaration makes it possible to use the notation m | n for divides m n. Don’t worry about how it works; you will learn about that later.
-/

def divides (m n : ℕ) : Prop := ∃ k, m * k = n

instance : has_dvd nat := ⟨divides⟩

def even (n : ℕ) : Prop := 2 ∣ n -- You can enter the '∣' character by typing \mid

section
  variables m n : ℕ

  #check m ∣ n
  #check m^n
  #check even (m^n +3)
end

/-
Remember that, without any parameters, an expression of type Prop is just an assertion. Fill in the definitions of prime and Fermat_prime below, and construct the given assertion. For example, you can say that there are infinitely many primes by asserting that for every natural number n, there is a prime number greater than n. Goldbach’s weak conjecture states that every odd number greater than 5 is the sum of three primes. Look up the definition of a Fermat prime or any of the other statements, if necessary.
-/

def prime (n : ℕ) : Prop := sorry

def infinitely_many_primes : Prop := sorry

def Fermat_prime (n : ℕ) : Prop := sorry

def infinitely_many_Fermat_primes : Prop := sorry

def goldbach_conjecture : Prop := sorry

def Goldbach's_weak_conjecture : Prop := sorry

def Fermat's_last_theorem : Prop := sorry

end hidden


/-
Copyright (c) 2018 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Scott Morrison, Bhavik Mehta
-/
import category_theory.limits.has_limits
import category_theory.discrete_category

/-!
# Categorical (co)products

This file defines (co)products as special cases of (co)limits.

A product is the categorical generalization of the object `Π i, f i` where `f : ι → C`. It is a
limit cone over the diagram formed by `f`, implemented by converting `f` into a functor
`discrete ι ⥤ C`.

A coproduct is the dual concept.

## Main definitions

* a `fan` is a cone over a discrete category
* `fan.mk` constructs a fan from an indexed collection of maps
* a `pi` is a `limit (discrete.functor f)`

Each of these has a dual.

## Implementation notes
As with the other special shapes in the limits library, all the definitions here are given as
`abbreviation`s of the general statements for limits, so all the `simp` lemmas and theorems about
general limits can be used.
-/

noncomputable theory

universes w v u u₂

open category_theory

namespace category_theory.limits

variables {β : Type w}
variables {C : Type u} [category.{v} C]

-- We don't need an analogue of `pair` (for binary products), `parallel_pair` (for equalizers),
-- or `(co)span`, since we already have `discrete.functor`.

/-- A fan over `f : β → C` consists of a collection of maps from an object `P` to every `f b`. -/
abbreviation fan (f : β → C) := cone (discrete.functor f)
/-- A cofan over `f : β → C` consists of a collection of maps from every `f b` to an object `P`. -/
abbreviation cofan (f : β → C) := cocone (discrete.functor f)

/-- A fan over `f : β → C` consists of a collection of maps from an object `P` to every `f b`. -/
@[simps]
def fan.mk {f : β → C} (P : C) (p : Π b, P ⟶ f b) : fan f :=
{ X := P,
  π := { app := p } }

/-- A cofan over `f : β → C` consists of a collection of maps from every `f b` to an object `P`. -/
@[simps]
def cofan.mk {f : β → C} (P : C) (p : Π b, f b ⟶ P) : cofan f :=
{ X := P,
  ι := { app := p } }

/-- An abbreviation for `has_limit (discrete.functor f)`. -/
abbreviation has_product (f : β → C) := has_limit (discrete.functor f)

/-- An abbreviation for `has_colimit (discrete.functor f)`. -/
abbreviation has_coproduct (f : β → C) := has_colimit (discrete.functor f)

section
variables (C)

/-- An abbreviation for `has_limits_of_shape (discrete f)`. -/
abbreviation has_products_of_shape (β : Type v) := has_limits_of_shape.{v} (discrete β)
/-- An abbreviation for `has_colimits_of_shape (discrete f)`. -/
abbreviation has_coproducts_of_shape (β : Type v) := has_colimits_of_shape.{v} (discrete β)
end

/-- `pi_obj f` computes the product of a family of elements `f`.
(It is defined as an abbreviation for `limit (discrete.functor f)`,
so for most facts about `pi_obj f`, you will just use general facts about limits.) -/
abbreviation pi_obj (f : β → C) [has_product f] := limit (discrete.functor f)
/-- `sigma_obj f` computes the coproduct of a family of elements `f`.
(It is defined as an abbreviation for `colimit (discrete.functor f)`,
so for most facts about `sigma_obj f`, you will just use general facts about colimits.) -/
abbreviation sigma_obj (f : β → C) [has_coproduct f] := colimit (discrete.functor f)

notation `∏ ` f:20 := pi_obj f
notation `∐ ` f:20 := sigma_obj f

/-- The `b`-th projection from the pi object over `f` has the form `∏ f ⟶ f b`. -/
abbreviation pi.π (f : β → C) [has_product f] (b : β) : ∏ f ⟶ f b :=
limit.π (discrete.functor f) b
/-- The `b`-th inclusion into the sigma object over `f` has the form `f b ⟶ ∐ f`. -/
abbreviation sigma.ι (f : β → C) [has_coproduct f] (b : β) : f b ⟶ ∐ f :=
colimit.ι (discrete.functor f) b

/-- The fan constructed of the projections from the product is limiting. -/
def product_is_product (f : β → C) [has_product f] :
  is_limit (fan.mk _ (pi.π f)) :=
is_limit.of_iso_limit (limit.is_limit (discrete.functor f)) (cones.ext (iso.refl _) (by tidy))

/-- The cofan constructed of the inclusions from the coproduct is colimiting. -/
def coproduct_is_coproduct (f : β → C) [has_coproduct f] :
  is_colimit (cofan.mk _ (sigma.ι f)) :=
is_colimit.of_iso_colimit (colimit.is_colimit (discrete.functor f)) (cocones.ext (iso.refl _)
  (by tidy))

/-- A collection of morphisms `P ⟶ f b` induces a morphism `P ⟶ ∏ f`. -/
abbreviation pi.lift {f : β → C} [has_product f] {P : C} (p : Π b, P ⟶ f b) : P ⟶ ∏ f :=
limit.lift _ (fan.mk P p)
/-- A collection of morphisms `f b ⟶ P` induces a morphism `∐ f ⟶ P`. -/
abbreviation sigma.desc {f : β → C} [has_coproduct f] {P : C} (p : Π b, f b ⟶ P) : ∐ f ⟶ P :=
colimit.desc _ (cofan.mk P p)

/--
Construct a morphism between categorical products (indexed by the same type)
from a family of morphisms between the factors.
-/
abbreviation pi.map {f g : β → C} [has_product f] [has_product g]
  (p : Π b, f b ⟶ g b) : ∏ f ⟶ ∏ g :=
lim_map (discrete.nat_trans p)
/--
Construct an isomorphism between categorical products (indexed by the same type)
from a family of isomorphisms between the factors.
-/
abbreviation pi.map_iso {f g : β → C} [has_products_of_shape β C]
  (p : Π b, f b ≅ g b) : ∏ f ≅ ∏ g :=
lim.map_iso (discrete.nat_iso p)
/--
Construct a morphism between categorical coproducts (indexed by the same type)
from a family of morphisms between the factors.
-/
abbreviation sigma.map {f g : β → C} [has_coproduct f] [has_coproduct g]
  (p : Π b, f b ⟶ g b) : ∐ f ⟶ ∐ g :=
colim_map (discrete.nat_trans p)
/--
Construct an isomorphism between categorical coproducts (indexed by the same type)
from a family of isomorphisms between the factors.
-/
abbreviation sigma.map_iso {f g : β → C} [has_coproducts_of_shape β C]
  (p : Π b, f b ≅ g b) : ∐ f ≅ ∐ g :=
colim.map_iso (discrete.nat_iso p)

section comparison

variables {D : Type u₂} [category.{v} D] (G : C ⥤ D)
variables (f : β → C)

/-- The comparison morphism for the product of `f`. This is an iso iff `G` preserves the product
of `f`, see `preserves_product.of_iso_comparison`. -/
def pi_comparison [has_product f] [has_product (λ b, G.obj (f b))] :
  G.obj (∏ f) ⟶ ∏ (λ b, G.obj (f b)) :=
pi.lift (λ b, G.map (pi.π f b))

@[simp, reassoc]
lemma pi_comparison_comp_π [has_product f] [has_product (λ b, G.obj (f b))] (b : β) :
  pi_comparison G f ≫ pi.π _ b = G.map (pi.π f b) :=
limit.lift_π _ b

@[simp, reassoc]
lemma map_lift_pi_comparison [has_product f] [has_product (λ b, G.obj (f b))]
  (P : C) (g : Π j, P ⟶ f j) :
  G.map (pi.lift g) ≫ pi_comparison G f = pi.lift (λ j, G.map (g j)) :=
by { ext, simp [← G.map_comp] }

/-- The comparison morphism for the coproduct of `f`. This is an iso iff `G` preserves the coproduct
of `f`, see `preserves_coproduct.of_iso_comparison`. -/
def sigma_comparison [has_coproduct f] [has_coproduct (λ b, G.obj (f b))] :
  ∐ (λ b, G.obj (f b)) ⟶ G.obj (∐ f) :=
sigma.desc (λ b, G.map (sigma.ι f b))

@[simp, reassoc]
lemma ι_comp_sigma_comparison [has_coproduct f] [has_coproduct (λ b, G.obj (f b))] (b : β) :
  sigma.ι _ b ≫ sigma_comparison G f = G.map (sigma.ι f b) :=
colimit.ι_desc _ b

@[simp, reassoc]
lemma sigma_comparison_map_desc [has_coproduct f] [has_coproduct (λ b, G.obj (f b))]
  (P : C) (g : Π j, f j ⟶ P) :
  sigma_comparison G f ≫ G.map (sigma.desc g) = sigma.desc (λ j, G.map (g j)) :=
by { ext, simp [← G.map_comp] }

end comparison

variables (C)

/-- An abbreviation for `Π J, has_limits_of_shape (discrete J) C` -/
abbreviation has_products := Π (J : Type v), has_limits_of_shape (discrete J) C
/-- An abbreviation for `Π J, has_colimits_of_shape (discrete J) C` -/
abbreviation has_coproducts := Π (J : Type v), has_colimits_of_shape (discrete J) C

end category_theory.limits