/-
Copyright (c) 2014 Jeremy Avigad. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Jeremy Avigad, Leonardo de Moura

Various multiplicative and additive structures.
-/
import tactic.interactive data.option.defs

section pending_1857

/- Transport multiplicative to additive -/
section transport
open tactic

@[user_attribute]
meta def to_additive_attr : user_attribute (name_map name) name :=
{ name      := `to_additive,
  descr     := "Transport multiplicative to additive",
  cache_cfg := ⟨λ ns, ns.mfoldl (λ dict n, do
    val ← to_additive_attr.get_param n,
    pure $ dict.insert n val) mk_name_map, []⟩,
  parser    := lean.parser.ident,
  after_set := some $ λ src _ _, do
    env ← get_env,
    dict ← to_additive_attr.get_cache,
    tgt ← to_additive_attr.get_param src,
    (get_decl tgt >> skip) <|>
      transport_with_dict dict src tgt }

end transport

/- map operations -/
attribute [to_additive has_add.add] has_mul.mul
attribute [to_additive has_zero.zero] has_one.one
attribute [to_additive has_neg.neg] has_inv.inv
attribute [to_additive has_add] has_mul
attribute [to_additive has_zero] has_one
attribute [to_additive has_neg] has_inv

/- map constructors -/
attribute [to_additive has_add.mk] has_mul.mk
attribute [to_additive has_zero.mk] has_one.mk
attribute [to_additive has_neg.mk] has_inv.mk

/- map structures -/
attribute [to_additive add_semigroup] semigroup
attribute [to_additive add_semigroup.mk] semigroup.mk
attribute [to_additive add_semigroup.to_has_add] semigroup.to_has_mul
attribute [to_additive add_semigroup.add_assoc] semigroup.mul_assoc
attribute [to_additive add_semigroup.add] semigroup.mul

attribute [to_additive add_comm_semigroup] comm_semigroup
attribute [to_additive add_comm_semigroup.mk] comm_semigroup.mk
attribute [to_additive add_comm_semigroup.to_add_semigroup] comm_semigroup.to_semigroup
attribute [to_additive add_comm_semigroup.add_comm] comm_semigroup.mul_comm

attribute [to_additive add_left_cancel_semigroup] left_cancel_semigroup
attribute [to_additive add_left_cancel_semigroup.mk] left_cancel_semigroup.mk
attribute [to_additive add_left_cancel_semigroup.to_add_semigroup] left_cancel_semigroup.to_semigroup
attribute [to_additive add_left_cancel_semigroup.add_left_cancel] left_cancel_semigroup.mul_left_cancel

attribute [to_additive add_right_cancel_semigroup] right_cancel_semigroup
attribute [to_additive add_right_cancel_semigroup.mk] right_cancel_semigroup.mk
attribute [to_additive add_right_cancel_semigroup.to_add_semigroup] right_cancel_semigroup.to_semigroup
attribute [to_additive add_right_cancel_semigroup.add_right_cancel] right_cancel_semigroup.mul_right_cancel

attribute [to_additive add_monoid] monoid
attribute [to_additive add_monoid.mk] monoid.mk
attribute [to_additive add_monoid.to_has_zero] monoid.to_has_one
attribute [to_additive add_monoid.to_add_semigroup] monoid.to_semigroup
attribute [to_additive add_monoid.add] monoid.mul
attribute [to_additive add_monoid.add_assoc] monoid.mul_assoc
attribute [to_additive add_monoid.zero] monoid.one
attribute [to_additive add_monoid.zero_add] monoid.one_mul
attribute [to_additive add_monoid.add_zero] monoid.mul_one

attribute [to_additive add_comm_monoid] comm_monoid
attribute [to_additive add_comm_monoid.mk] comm_monoid.mk
attribute [to_additive add_comm_monoid.to_add_monoid] comm_monoid.to_monoid
attribute [to_additive add_comm_monoid.to_add_comm_semigroup] comm_monoid.to_comm_semigroup

attribute [to_additive add_group] group
attribute [to_additive add_group.mk] group.mk
attribute [to_additive add_group.to_has_neg] group.to_has_inv
attribute [to_additive add_group.to_add_monoid] group.to_monoid
attribute [to_additive add_group.add_left_neg] group.mul_left_inv
attribute [to_additive add_group.add] group.mul
attribute [to_additive add_group.add_assoc] group.mul_assoc
attribute [to_additive add_group.zero] group.one
attribute [to_additive add_group.zero_add] group.one_mul
attribute [to_additive add_group.add_zero] group.mul_one
attribute [to_additive add_group.neg] group.inv

attribute [to_additive add_comm_group] comm_group
attribute [to_additive add_comm_group.mk] comm_group.mk
attribute [to_additive add_comm_group.to_add_group] comm_group.to_group
attribute [to_additive add_comm_group.to_add_comm_monoid] comm_group.to_comm_monoid

/- map theorems -/
attribute [to_additive add_assoc] mul_assoc
attribute [to_additive add_semigroup_to_is_associative] semigroup_to_is_associative
attribute [to_additive add_comm] mul_comm
attribute [to_additive add_comm_semigroup_to_is_commutative] comm_semigroup_to_is_commutative
attribute [to_additive add_left_comm] mul_left_comm
attribute [to_additive add_right_comm] mul_right_comm
attribute [to_additive add_left_cancel] mul_left_cancel
attribute [to_additive add_right_cancel] mul_right_cancel
attribute [to_additive add_left_cancel_iff] mul_left_cancel_iff
attribute [to_additive add_right_cancel_iff] mul_right_cancel_iff
attribute [to_additive zero_add] one_mul
attribute [to_additive add_zero] mul_one
attribute [to_additive add_left_neg] mul_left_inv
attribute [to_additive neg_add_self] inv_mul_self
attribute [to_additive neg_add_cancel_left] inv_mul_cancel_left
attribute [to_additive neg_add_cancel_right] inv_mul_cancel_right
attribute [to_additive neg_eq_of_add_eq_zero] inv_eq_of_mul_eq_one
attribute [to_additive neg_zero] one_inv
attribute [to_additive neg_neg] inv_inv
attribute [to_additive add_right_neg] mul_right_inv
attribute [to_additive add_neg_self] mul_inv_self
attribute [to_additive neg_inj] inv_inj
attribute [to_additive add_group.add_left_cancel] group.mul_left_cancel
attribute [to_additive add_group.add_right_cancel] group.mul_right_cancel
attribute [to_additive add_group.to_left_cancel_add_semigroup] group.to_left_cancel_semigroup
attribute [to_additive add_group.to_right_cancel_add_semigroup] group.to_right_cancel_semigroup
attribute [to_additive add_neg_cancel_left] mul_inv_cancel_left
attribute [to_additive add_neg_cancel_right] mul_inv_cancel_right
attribute [to_additive neg_add_rev] mul_inv_rev
attribute [to_additive eq_neg_of_eq_neg] eq_inv_of_eq_inv
attribute [to_additive eq_neg_of_add_eq_zero] eq_inv_of_mul_eq_one
attribute [to_additive eq_add_neg_of_add_eq] eq_mul_inv_of_mul_eq
attribute [to_additive eq_neg_add_of_add_eq] eq_inv_mul_of_mul_eq
attribute [to_additive neg_add_eq_of_eq_add] inv_mul_eq_of_eq_mul
attribute [to_additive add_neg_eq_of_eq_add] mul_inv_eq_of_eq_mul
attribute [to_additive eq_add_of_add_neg_eq] eq_mul_of_mul_inv_eq
attribute [to_additive eq_add_of_neg_add_eq] eq_mul_of_inv_mul_eq
attribute [to_additive add_eq_of_eq_neg_add] mul_eq_of_eq_inv_mul
attribute [to_additive add_eq_of_eq_add_neg] mul_eq_of_eq_mul_inv
attribute [to_additive neg_add] mul_inv

end pending_1857

instance monoid_to_is_left_id {α : Type*} [monoid α]
: is_left_id α (*) 1 :=
⟨ monoid.one_mul ⟩

instance monoid_to_is_right_id {α : Type*} [monoid α]
: is_right_id α (*) 1 :=
⟨ monoid.mul_one ⟩

instance add_monoid_to_is_left_id {α : Type*} [add_monoid α]
: is_left_id α (+) 0 :=
⟨ add_monoid.zero_add ⟩

instance add_monoid_to_is_right_id {α : Type*} [add_monoid α]
: is_right_id α (+) 0 :=
⟨ add_monoid.add_zero ⟩

universes u v
variables {α : Type u} {β : Type v}

def additive (α : Type*) := α
def multiplicative (α : Type*) := α

instance [semigroup α] : add_semigroup (additive α) :=
{ add := ((*) : α → α → α),
  add_assoc := @mul_assoc _ _ }

instance [add_semigroup α] : semigroup (multiplicative α) :=
{ mul := ((+) : α → α → α),
  mul_assoc := @add_assoc _ _ }

instance [comm_semigroup α] : add_comm_semigroup (additive α) :=
{ add_comm := @mul_comm _ _,
  ..additive.add_semigroup }

instance [add_comm_semigroup α] : comm_semigroup (multiplicative α) :=
{ mul_comm := @add_comm _ _,
  ..multiplicative.semigroup }

instance [left_cancel_semigroup α] : add_left_cancel_semigroup (additive α) :=
{ add_left_cancel := @mul_left_cancel _ _,
  ..additive.add_semigroup }

instance [add_left_cancel_semigroup α] : left_cancel_semigroup (multiplicative α) :=
{ mul_left_cancel := @add_left_cancel _ _,
  ..multiplicative.semigroup }

instance [right_cancel_semigroup α] : add_right_cancel_semigroup (additive α) :=
{ add_right_cancel := @mul_right_cancel _ _,
  ..additive.add_semigroup }

instance [add_right_cancel_semigroup α] : right_cancel_semigroup (multiplicative α) :=
{ mul_right_cancel := @add_right_cancel _ _,
  ..multiplicative.semigroup }

@[simp, to_additive add_left_inj]
theorem mul_left_inj [left_cancel_semigroup α] (a : α) {b c : α} : a * b = a * c ↔ b = c :=
⟨mul_left_cancel, congr_arg _⟩

@[simp, to_additive add_right_inj]
theorem mul_right_inj [right_cancel_semigroup α] (a : α) {b c : α} : b * a = c * a ↔ b = c :=
⟨mul_right_cancel, congr_arg _⟩

structure units (α : Type u) [monoid α] :=
(val : α)
(inv : α)
(val_inv : val * inv = 1)
(inv_val : inv * val = 1)

namespace units
variables [monoid α] {a b c : units α}

instance : has_coe (units α) α := ⟨val⟩

@[extensionality] theorem ext : ∀ {a b : units α}, (a : α) = b → a = b
| ⟨v, i₁, vi₁, iv₁⟩ ⟨v', i₂, vi₂, iv₂⟩ e :=
  by change v = v' at e; subst v'; congr;
      simpa only [iv₂, vi₁, one_mul, mul_one] using mul_assoc i₂ v i₁

theorem ext_iff {a b : units α} : a = b ↔ (a : α) = b :=
⟨congr_arg _, ext⟩

instance [decidable_eq α] : decidable_eq (units α)
| a b := decidable_of_iff' _ ext_iff

protected def mul (u₁ u₂ : units α) : units α :=
⟨u₁.val * u₂.val, u₂.inv * u₁.inv,
  have u₁.val * (u₂.val * u₂.inv) * u₁.inv = 1,
    by rw [u₂.val_inv]; rw [mul_one, u₁.val_inv],
  by simpa only [mul_assoc],
  have u₂.inv * (u₁.inv * u₁.val) * u₂.val = 1,
    by rw [u₁.inv_val]; rw [mul_one, u₂.inv_val],
  by simpa only [mul_assoc]⟩

protected def inv' (u : units α) : units α :=
⟨u.inv, u.val, u.inv_val, u.val_inv⟩

instance : has_mul (units α) := ⟨units.mul⟩
instance : has_one (units α) := ⟨⟨1, 1, mul_one 1, one_mul 1⟩⟩
instance : has_inv (units α) := ⟨units.inv'⟩

variables (a b)
@[simp] lemma coe_mul : (↑(a * b) : α) = a * b := rfl
@[simp] lemma coe_one : ((1 : units α) : α) = 1 := rfl
lemma val_coe : (↑a : α) = a.val := rfl
lemma coe_inv : ((a⁻¹ : units α) : α) = a.inv := rfl
@[simp] lemma inv_mul : (↑a⁻¹ * a : α) = 1 := inv_val _
@[simp] lemma mul_inv : (a * ↑a⁻¹ : α) = 1 := val_inv _

@[simp] lemma mul_inv_cancel_left (a : units α) (b : α) : (a:α) * (↑a⁻¹ * b) = b :=
by rw [← mul_assoc, mul_inv, one_mul]

@[simp] lemma inv_mul_cancel_left (a : units α) (b : α) : (↑a⁻¹:α) * (a * b) = b :=
by rw [← mul_assoc, inv_mul, one_mul]

@[simp] lemma mul_inv_cancel_right (a : α) (b : units α) : a * b * ↑b⁻¹ = a :=
by rw [mul_assoc, mul_inv, mul_one]

@[simp] lemma inv_mul_cancel_right (a : α) (b : units α) : a * ↑b⁻¹ * b = a :=
by rw [mul_assoc, inv_mul, mul_one]

instance : group (units α) :=
by refine {mul := (*), one := 1, inv := has_inv.inv, ..};
  { intros, apply ext, simp only [coe_mul, coe_one,
      mul_assoc, one_mul, mul_one, inv_mul] }

instance {α} [comm_monoid α] : comm_group (units α) :=
{ mul_comm := λ u₁ u₂, ext $ mul_comm _ _, ..units.group }

instance [has_repr α] : has_repr (units α) := ⟨repr ∘ val⟩

@[simp] theorem mul_left_inj (a : units α) {b c : α} : (a:α) * b = a * c ↔ b = c :=
⟨λ h, by simpa only [inv_mul_cancel_left] using congr_arg ((*) ↑(a⁻¹ : units α)) h, congr_arg _⟩

@[simp] theorem mul_right_inj (a : units α) {b c : α} : b * a = c * a ↔ b = c :=
⟨λ h, by simpa only [mul_inv_cancel_right] using congr_arg (* ↑(a⁻¹ : units α)) h, congr_arg _⟩

end units

theorem nat.units_eq_one (u : units ℕ) : u = 1 :=
units.ext $ nat.eq_one_of_dvd_one ⟨u.inv, u.val_inv.symm⟩

def units.mk_of_mul_eq_one [comm_monoid α] (a b : α) (hab : a * b = 1) : units α :=
⟨a, b, hab, (mul_comm b a).trans hab⟩

instance [monoid α] : add_monoid (additive α) :=
{ zero     := (1 : α),
  zero_add := @one_mul _ _,
  add_zero := @mul_one _ _,
  ..additive.add_semigroup }

instance [add_monoid α] : monoid (multiplicative α) :=
{ one     := (0 : α),
  one_mul := @zero_add _ _,
  mul_one := @add_zero _ _,
  ..multiplicative.semigroup }

def free_monoid (α) := list α

instance {α} : monoid (free_monoid α) :=
{ one := [],
  mul := λ x y, (x ++ y : list α),
  mul_one := by intros; apply list.append_nil,
  one_mul := by intros; refl,
  mul_assoc := by intros; apply list.append_assoc }

@[simp] lemma free_monoid.one_def {α} : (1 : free_monoid α) = [] := rfl

@[simp] lemma free_monoid.mul_def {α} (xs ys : list α) : (xs * ys : free_monoid α) = (xs ++ ys : list α) := rfl

def free_add_monoid (α) := list α

instance {α} : add_monoid (free_add_monoid α) :=
{ zero := [],
  add := λ x y, (x ++ y : list α),
  add_zero := by intros; apply list.append_nil,
  zero_add := by intros; refl,
  add_assoc := by intros; apply list.append_assoc }

@[simp] lemma free_add_monoid.zero_def {α} : (1 : free_monoid α) = [] := rfl

@[simp] lemma free_add_monoid.add_def {α} (xs ys : list α) : (xs * ys : free_monoid α) = (xs ++ ys : list α) := rfl

section monoid
  variables [monoid α] {a b c : α}

  /-- Partial division. It is defined when the
    second argument is invertible, and unlike the division operator
    in `division_ring` it is not totalized at zero. -/
  def divp (a : α) (u) : α := a * (u⁻¹ : units α)

  infix ` /ₚ `:70 := divp

  @[simp] theorem divp_self (u : units α) : (u : α) /ₚ u = 1 := units.mul_inv _

  @[simp] theorem divp_one (a : α) : a /ₚ 1 = a := mul_one _

  theorem divp_assoc (a b : α) (u : units α) : a * b /ₚ u = a * (b /ₚ u) :=
  mul_assoc _ _ _

  @[simp] theorem divp_mul_cancel (a : α) (u : units α) : a /ₚ u * u = a :=
  (mul_assoc _ _ _).trans $ by rw [units.inv_mul, mul_one]

  @[simp] theorem mul_divp_cancel (a : α) (u : units α) : (a * u) /ₚ u = a :=
  (mul_assoc _ _ _).trans $ by rw [units.mul_inv, mul_one]

  @[simp] theorem divp_right_inj (u : units α) {a b : α} : a /ₚ u = b /ₚ u ↔ a = b :=
  units.mul_right_inj _

  theorem divp_eq_one (a : α) (u : units α) : a /ₚ u = 1 ↔ a = u :=
  (units.mul_right_inj u).symm.trans $ by rw [divp_mul_cancel, one_mul]

  @[simp] theorem one_divp (u : units α) : 1 /ₚ u = ↑u⁻¹ :=
  one_mul _

end monoid

instance [comm_monoid α] : add_comm_monoid (additive α) :=
{ add_comm := @mul_comm α _,
  ..additive.add_monoid }

instance [add_comm_monoid α] : comm_monoid (multiplicative α) :=
{ mul_comm := @add_comm α _,
  ..multiplicative.monoid }

instance [group α] : add_group (additive α) :=
{ neg := @has_inv.inv α _,
  add_left_neg := @mul_left_inv _ _,
  ..additive.add_monoid }

instance [add_group α] : group (multiplicative α) :=
{ inv := @has_neg.neg α _,
  mul_left_inv := @add_left_neg _ _,
  ..multiplicative.monoid }

section group
  variables [group α] {a b c : α}

  instance : has_lift α (units α) :=
  ⟨λ a, ⟨a, a⁻¹, mul_inv_self _, inv_mul_self _⟩⟩

  @[simp, to_additive neg_inj']
  theorem inv_inj' : a⁻¹ = b⁻¹ ↔ a = b :=
  ⟨λ h, by rw [← inv_inv a, h, inv_inv], congr_arg _⟩

  @[to_additive eq_of_neg_eq_neg]
  theorem eq_of_inv_eq_inv : a⁻¹ = b⁻¹ → a = b :=
  inv_inj'.1

  @[simp, to_additive add_self_iff_eq_zero]
  theorem mul_self_iff_eq_one : a * a = a ↔ a = 1 :=
  by have := @mul_left_inj _ _ a a 1; rwa mul_one at this

  @[simp, to_additive neg_eq_zero]
  theorem inv_eq_one : a⁻¹ = 1 ↔ a = 1 :=
  by rw [← @inv_inj' _ _ a 1, one_inv]

  @[simp, to_additive neg_ne_zero]
  theorem inv_ne_one : a⁻¹ ≠ 1 ↔ a ≠ 1 :=
  not_congr inv_eq_one

  @[to_additive left_inverse_neg]
  theorem left_inverse_inv (α) [group α] :
    function.left_inverse (λ a : α, a⁻¹) (λ a, a⁻¹) :=
  assume a, inv_inv a

  attribute [simp] mul_inv_cancel_left add_neg_cancel_left
                   mul_inv_cancel_right add_neg_cancel_right

  @[to_additive eq_neg_iff_eq_neg]
  theorem eq_inv_iff_eq_inv : a = b⁻¹ ↔ b = a⁻¹ :=
  ⟨eq_inv_of_eq_inv, eq_inv_of_eq_inv⟩

  @[to_additive neg_eq_iff_neg_eq]
  theorem inv_eq_iff_inv_eq : a⁻¹ = b ↔ b⁻¹ = a :=
  by rw [eq_comm, @eq_comm _ _ a, eq_inv_iff_eq_inv]

  @[to_additive add_eq_zero_iff_eq_neg]
  theorem mul_eq_one_iff_eq_inv : a * b = 1 ↔ a = b⁻¹ :=
  by simpa [mul_left_inv, -mul_right_inj] using @mul_right_inj _ _ b a (b⁻¹)

  @[to_additive add_eq_zero_iff_neg_eq]
  theorem mul_eq_one_iff_inv_eq : a * b = 1 ↔ a⁻¹ = b :=
  by rw [mul_eq_one_iff_eq_inv, eq_inv_iff_eq_inv, eq_comm]

  @[to_additive eq_neg_iff_add_eq_zero]
  theorem eq_inv_iff_mul_eq_one : a = b⁻¹ ↔ a * b = 1 :=
  mul_eq_one_iff_eq_inv.symm

  @[to_additive neg_eq_iff_add_eq_zero]
  theorem inv_eq_iff_mul_eq_one : a⁻¹ = b ↔ a * b = 1 :=
  mul_eq_one_iff_inv_eq.symm

  @[to_additive eq_add_neg_iff_add_eq]
  theorem eq_mul_inv_iff_mul_eq : a = b * c⁻¹ ↔ a * c = b :=
  ⟨λ h, by rw [h, inv_mul_cancel_right], λ h, by rw [← h, mul_inv_cancel_right]⟩

  @[to_additive eq_neg_add_iff_add_eq]
  theorem eq_inv_mul_iff_mul_eq : a = b⁻¹ * c ↔ b * a = c :=
  ⟨λ h, by rw [h, mul_inv_cancel_left], λ h, by rw [← h, inv_mul_cancel_left]⟩

  @[to_additive neg_add_eq_iff_eq_add]
  theorem inv_mul_eq_iff_eq_mul : a⁻¹ * b = c ↔ b = a * c :=
  ⟨λ h, by rw [← h, mul_inv_cancel_left], λ h, by rw [h, inv_mul_cancel_left]⟩

  @[to_additive add_neg_eq_iff_eq_add]
  theorem mul_inv_eq_iff_eq_mul : a * b⁻¹ = c ↔ a = c * b :=
  ⟨λ h, by rw [← h, inv_mul_cancel_right], λ h, by rw [h, mul_inv_cancel_right]⟩

  @[to_additive add_neg_eq_zero]
  theorem mul_inv_eq_one {a b : α} : a * b⁻¹ = 1 ↔ a = b :=
  by rw [mul_eq_one_iff_eq_inv, inv_inv]

  @[to_additive neg_comm_of_comm]
  theorem inv_comm_of_comm {a b : α} (H : a * b = b * a) : a⁻¹ * b = b * a⁻¹ :=
  begin
    have : a⁻¹ * (b * a) * a⁻¹ = a⁻¹ * (a * b) * a⁻¹ :=
      congr_arg (λ x:α, a⁻¹ * x * a⁻¹) H.symm,
    rwa [inv_mul_cancel_left, mul_assoc, mul_inv_cancel_right] at this
  end

end group

instance [comm_group α] : add_comm_group (additive α) :=
{ add_comm := @mul_comm α _,
  ..additive.add_group }

instance [add_comm_group α] : comm_group (multiplicative α) :=
{ mul_comm := @add_comm α _,
  ..multiplicative.group }

section add_monoid
  variables [add_monoid α] {a b c : α}

  @[simp] lemma bit0_zero : bit0 (0 : α) = 0 := add_zero _
  @[simp] lemma bit1_zero [has_one α] : bit1 (0 : α) = 1 :=
  show 0+0+1=(1:α), by rw [zero_add, zero_add]

end add_monoid

section add_group
  variables [add_group α] {a b c : α}

  local attribute [simp] sub_eq_add_neg

  def sub_sub_cancel := @sub_sub_self

  @[simp] lemma sub_left_inj : a - b = a - c ↔ b = c :=
  (add_left_inj _).trans neg_inj'

  @[simp] lemma sub_right_inj : b - a = c - a ↔ b = c :=
  add_right_inj _

  lemma sub_add_sub_cancel (a b c : α) : (a - b) + (b - c) = a - c :=
  by rw [← add_sub_assoc, sub_add_cancel]

  lemma sub_sub_sub_cancel_right (a b c : α) : (a - c) - (b - c) = a - b :=
  by rw [← neg_sub c b, sub_neg_eq_add, sub_add_sub_cancel]

  theorem sub_eq_zero : a - b = 0 ↔ a = b :=
  ⟨eq_of_sub_eq_zero, λ h, by rw [h, sub_self]⟩

  theorem sub_ne_zero : a - b ≠ 0 ↔ a ≠ b :=
  not_congr sub_eq_zero

  theorem eq_sub_iff_add_eq : a = b - c ↔ a + c = b :=
  eq_add_neg_iff_add_eq

  theorem sub_eq_iff_eq_add : a - b = c ↔ a = c + b :=
  add_neg_eq_iff_eq_add

  theorem eq_iff_eq_of_sub_eq_sub {a b c d : α} (H : a - b = c - d) : a = b ↔ c = d :=
  by rw [← sub_eq_zero, H, sub_eq_zero]

  theorem left_inverse_sub_add_left (c : α) : function.left_inverse (λ x, x - c) (λ x, x + c) :=
  assume x, add_sub_cancel x c

  theorem left_inverse_add_left_sub (c : α) : function.left_inverse (λ x, x + c) (λ x, x - c) :=
  assume x, sub_add_cancel x c

  theorem left_inverse_add_right_neg_add (c : α) :
      function.left_inverse (λ x, c + x) (λ x, - c + x) :=
  assume x, add_neg_cancel_left c x

  theorem left_inverse_neg_add_add_right (c : α) :
      function.left_inverse (λ x, - c + x) (λ x, c + x) :=
  assume x, neg_add_cancel_left c x
end add_group

section add_comm_group
  variables [add_comm_group α] {a b c : α}

  lemma sub_eq_neg_add (a b : α) : a - b = -b + a :=
  add_comm _ _

  theorem neg_add' (a b : α) : -(a + b) = -a - b := neg_add a b

  lemma neg_sub_neg (a b : α) : -a - -b = b - a := by simp

  lemma eq_sub_iff_add_eq' : a = b - c ↔ c + a = b :=
  by rw [eq_sub_iff_add_eq, add_comm]

  lemma sub_eq_iff_eq_add' : a - b = c ↔ a = b + c :=
  by rw [sub_eq_iff_eq_add, add_comm]

  lemma add_sub_cancel' (a b : α) : a + b - a = b :=
  by rw [sub_eq_neg_add, neg_add_cancel_left]

  lemma add_sub_cancel'_right (a b : α) : a + (b - a) = b :=
  by rw [← add_sub_assoc, add_sub_cancel']

  lemma sub_right_comm (a b c : α) : a - b - c = a - c - b :=
  add_right_comm _ _ _

  lemma sub_add_sub_cancel' (a b c : α) : (a - b) + (c - a) = c - b :=
  by rw add_comm; apply sub_add_sub_cancel

  lemma sub_sub_sub_cancel_left (a b c : α) : (c - a) - (c - b) = b - a :=
  by rw [← neg_sub b c, sub_neg_eq_add, add_comm, sub_add_sub_cancel]

  lemma sub_eq_sub_iff_sub_eq_sub {d : α} :
  a - b = c - d ↔ a - c = b - d :=
  ⟨λ h, by rw eq_add_of_sub_eq h; simp, λ h, by rw eq_add_of_sub_eq h; simp⟩

end add_comm_group

section is_conj
variables [group α] [group β]

def is_conj (a b : α) := ∃ c : α, c * a * c⁻¹ = b

@[refl] lemma is_conj_refl (a : α) : is_conj a a :=
⟨1, by rw [one_mul, one_inv, mul_one]⟩

@[symm] lemma is_conj_symm {a b : α} : is_conj a b → is_conj b a
| ⟨c, hc⟩ := ⟨c⁻¹, by rw [← hc, mul_assoc, mul_inv_cancel_right, inv_mul_cancel_left]⟩

@[trans] lemma is_conj_trans {a b c : α} : is_conj a b → is_conj b c → is_conj a c
| ⟨c₁, hc₁⟩ ⟨c₂, hc₂⟩ := ⟨c₂ * c₁, by rw [← hc₂, ← hc₁, mul_inv_rev]; simp only [mul_assoc]⟩

@[simp] lemma is_conj_one_right {a : α} : is_conj 1 a  ↔ a = 1 :=
⟨by simp [is_conj, is_conj_refl] {contextual := tt}, by simp [is_conj_refl] {contextual := tt}⟩

@[simp] lemma is_conj_one_left {a : α} : is_conj a 1 ↔ a = 1 :=
calc is_conj a 1 ↔ is_conj 1 a : ⟨is_conj_symm, is_conj_symm⟩
... ↔ a = 1 : is_conj_one_right

@[simp] lemma is_conj_iff_eq {α : Type*} [comm_group α] {a b : α} : is_conj a b ↔ a = b :=
⟨λ ⟨c, hc⟩, by rw [← hc, mul_right_comm, mul_inv_self, one_mul], λ h, by rw h⟩

end is_conj

class is_mul_hom {α β : Type*} [has_mul α] [has_mul β] (f : α → β) : Prop :=
(map_mul : ∀ {x y}, f (x * y) = f x * f y)

class is_add_hom {α β : Type*} [has_add α] [has_add β] (f : α → β) : Prop :=
(map_add : ∀ {x y}, f (x + y) = f x + f y)

attribute [to_additive is_add_hom] is_mul_hom
attribute [to_additive is_add_hom.cases_on] is_mul_hom.cases_on
attribute [to_additive is_add_hom.dcases_on] is_mul_hom.dcases_on
attribute [to_additive is_add_hom.drec] is_mul_hom.drec
attribute [to_additive is_add_hom.drec_on] is_mul_hom.drec_on
attribute [to_additive is_add_hom.map_add] is_mul_hom.map_mul
attribute [to_additive is_add_hom.mk] is_mul_hom.mk
attribute [to_additive is_add_hom.rec] is_mul_hom.rec
attribute [to_additive is_add_hom.rec_on] is_mul_hom.rec_on

namespace is_mul_hom
variables [has_mul α] [has_mul β] {γ : Type*} [has_mul γ]

@[to_additive is_add_hom.id]
lemma id : is_mul_hom (id : α → α) := {map_mul := λ _ _, rfl}

@[to_additive is_add_hom.comp]
lemma comp {f : α → β} {g : β → γ} (hf : is_mul_hom f) (hg : is_mul_hom g) : is_mul_hom (g ∘ f) :=
⟨λ x y, by show _ = g _ * g _; rw [←hg.map_mul, ←hf.map_mul]⟩

@[to_additive is_add_hom.comp']
lemma comp' {f : α → β} {g : β → γ} (hf : is_mul_hom f) (hg : is_mul_hom g) :
  is_mul_hom (λ x, g (f x)) :=
⟨λ x y, by rw [←hg.map_mul, ←hf.map_mul]⟩

end is_mul_hom

class is_monoid_hom [monoid α] [monoid β] (f : α → β) : Prop :=
(map_one : f 1 = 1)
(map_mul : ∀ {x y}, f (x * y) = f x * f y)

class is_add_monoid_hom [add_monoid α] [add_monoid β] (f : α → β) : Prop :=
(map_zero : f 0 = 0)
(map_add : ∀ {x y}, f (x + y) = f x + f y)

attribute [to_additive is_add_monoid_hom] is_monoid_hom
attribute [to_additive is_add_monoid_hom.map_add] is_monoid_hom.map_mul
attribute [to_additive is_add_monoid_hom.mk] is_monoid_hom.mk
attribute [to_additive is_add_monoid_hom.cases_on] is_monoid_hom.cases_on
attribute [to_additive is_add_monoid_hom.dcases_on] is_monoid_hom.dcases_on
attribute [to_additive is_add_monoid_hom.rec] is_monoid_hom.rec
attribute [to_additive is_add_monoid_hom.drec] is_monoid_hom.drec
attribute [to_additive is_add_monoid_hom.rec_on] is_monoid_hom.rec_on
attribute [to_additive is_add_monoid_hom.drec_on] is_monoid_hom.drec_on
attribute [to_additive is_add_monoid_hom.map_zero] is_monoid_hom.map_one

namespace is_monoid_hom
variables [monoid α] [monoid β] (f : α → β) [is_monoid_hom f]

@[to_additive is_add_monoid_hom.id]
instance id : is_monoid_hom (@id α) := by refine {..}; intros; refl

@[to_additive is_add_monoid_hom.comp]
instance comp {γ} [monoid γ] (g : β → γ) [is_monoid_hom g] :
  is_monoid_hom (g ∘ f) :=
{ map_mul := λ x y, show g _ = g _ * g _, by rw [map_mul f, map_mul g],
  map_one := show g _ = 1, by rw [map_one f, map_one g] }

instance is_add_monoid_hom_mul_left {γ : Type*} [semiring γ] (x : γ) : is_add_monoid_hom (λ y : γ, x * y) :=
by refine_struct {..}; simp [mul_add]

instance is_add_monoid_hom_mul_right {γ : Type*} [semiring γ] (x : γ) : is_add_monoid_hom (λ y : γ, y * x) :=
by refine_struct {..}; simp [add_mul]

end is_monoid_hom

-- TODO rename fields of is_group_hom: mul ↝ map_mul?

/-- Predicate for group homomorphism. -/
class is_group_hom [group α] [group β] (f : α → β) : Prop :=
(mul : ∀ a b : α, f (a * b) = f a * f b)

class is_add_group_hom [add_group α] [add_group β] (f : α → β) : Prop :=
(add : ∀ a b, f (a + b) = f a + f b)

attribute [to_additive is_add_group_hom] is_group_hom
attribute [to_additive is_add_group_hom.cases_on] is_group_hom.cases_on
attribute [to_additive is_add_group_hom.dcases_on] is_group_hom.dcases_on
attribute [to_additive is_add_group_hom.rec] is_group_hom.rec
attribute [to_additive is_add_group_hom.drec] is_group_hom.drec
attribute [to_additive is_add_group_hom.rec_on] is_group_hom.rec_on
attribute [to_additive is_add_group_hom.drec_on] is_group_hom.drec_on
attribute [to_additive is_add_group_hom.add] is_group_hom.mul
attribute [to_additive is_add_group_hom.mk] is_group_hom.mk

instance additive.is_add_group_hom [group α] [group β] (f : α → β) [is_group_hom f] :
  @is_add_group_hom (additive α) (additive β) _ _ f :=
⟨@is_group_hom.mul α β _ _ f _⟩

instance multiplicative.is_group_hom [add_group α] [add_group β] (f : α → β) [is_add_group_hom f] :
  @is_group_hom (multiplicative α) (multiplicative β) _ _ f :=
⟨@is_add_group_hom.add α β _ _ f _⟩

attribute [to_additive additive.is_add_group_hom] multiplicative.is_group_hom

namespace is_group_hom
variables [group α] [group β] (f : α → β) [is_group_hom f]

@[to_additive is_add_group_hom.zero]
theorem one : f 1 = 1 :=
mul_self_iff_eq_one.1 $ by rw [← mul f, one_mul]

@[to_additive is_add_group_hom.neg]
theorem inv (a : α) : f a⁻¹ = (f a)⁻¹ :=
eq_inv_of_mul_eq_one $ by rw [← mul f, inv_mul_self, one f]

@[to_additive is_add_group_hom.id]
instance id : is_group_hom (@id α) :=
⟨λ _ _, rfl⟩

@[to_additive is_add_group_hom.comp]
instance comp {γ} [group γ] (g : β → γ) [is_group_hom g] :
  is_group_hom (g ∘ f) :=
⟨λ x y, show g _ = g _ * g _, by rw [mul f, mul g]⟩

protected lemma is_conj (f : α → β) [is_group_hom f] {a b : α} : is_conj a b → is_conj (f a) (f b)
| ⟨c, hc⟩ := ⟨f c, by rw [← is_group_hom.mul f, ← is_group_hom.inv f, ← is_group_hom.mul f, hc]⟩

@[to_additive is_add_group_hom.to_is_add_monoid_hom]
lemma to_is_monoid_hom (f : α → β) [is_group_hom f] : is_monoid_hom f :=
⟨is_group_hom.one f, is_group_hom.mul f⟩

@[to_additive is_add_group_hom.injective_iff]
lemma injective_iff (f : α → β) [is_group_hom f] :
  function.injective f ↔ (∀ a, f a = 1 → a = 1) :=
⟨λ h _, by rw ← is_group_hom.one f; exact @h _ _,
  λ h x y hxy, by rw [← inv_inv (f x), inv_eq_iff_mul_eq_one, ← is_group_hom.inv f,
      ← is_group_hom.mul f] at hxy;
    simpa using inv_eq_of_mul_eq_one (h _ hxy)⟩

attribute [instance] is_group_hom.to_is_monoid_hom
  is_add_group_hom.to_is_add_monoid_hom

end is_group_hom

@[to_additive is_add_group_hom_add]
lemma is_group_hom_mul {α β} [group α] [comm_group β]
  (f g : α → β) [is_group_hom f] [is_group_hom g] :
  is_group_hom (λa, f a * g a) :=
⟨assume a b, by simp only [is_group_hom.mul f, is_group_hom.mul g, mul_comm, mul_assoc, mul_left_comm]⟩

attribute [instance] is_group_hom_mul is_add_group_hom_add

@[to_additive is_add_group_hom_neg]
lemma is_group_hom_inv {α β} [group α] [comm_group β] (f : α → β) [is_group_hom f] :
  is_group_hom (λa, (f a)⁻¹) :=
⟨assume a b, by rw [is_group_hom.mul f, mul_inv]⟩

attribute [instance] is_group_hom_inv is_add_group_hom_neg

@[to_additive neg.is_add_group_hom]
lemma inv.is_group_hom [comm_group α] : is_group_hom (has_inv.inv : α → α) :=
⟨by simp [mul_inv_rev, mul_comm]⟩

attribute [instance] inv.is_group_hom neg.is_add_group_hom

/-- Predicate for group anti-homomorphism, or a homomorphism
  into the opposite group. -/
class is_group_anti_hom {β : Type*} [group α] [group β] (f : α → β) : Prop :=
(mul : ∀ a b : α, f (a * b) = f b * f a)

namespace is_group_anti_hom
variables [group α] [group β] (f : α → β) [w : is_group_anti_hom f]
include w

theorem one : f 1 = 1 :=
mul_self_iff_eq_one.1 $ by rw [← mul f, one_mul]

theorem inv (a : α) : f a⁻¹ = (f a)⁻¹ :=
eq_inv_of_mul_eq_one $ by rw [← mul f, mul_inv_self, one f]

end is_group_anti_hom

theorem inv_is_group_anti_hom [group α] : is_group_anti_hom (λ x : α, x⁻¹) :=
⟨mul_inv_rev⟩

namespace is_add_group_hom
variables [add_group α] [add_group β] (f : α → β) [is_add_group_hom f]

lemma sub (a b) : f (a - b) = f a - f b :=
calc f (a - b) = f (a + -b)   : rfl
           ... = f a + f (-b) : add f _ _
           ... = f a - f b    : by  simp[neg f]

end is_add_group_hom

lemma is_add_group_hom_sub {α β} [add_group α] [add_comm_group β]
  (f g : α → β) [is_add_group_hom f] [is_add_group_hom g] :
  is_add_group_hom (λa, f a - g a) :=
is_add_group_hom_add f (λa, - g a)

attribute [instance] is_add_group_hom_sub

namespace units

variables {γ : Type*} [monoid α] [monoid β] [monoid γ] (f : α → β) (g : β → γ)
[is_monoid_hom f] [is_monoid_hom g]

definition map : units α → units β :=
λ u, ⟨f u.val, f u.inv,
      by rw [← is_monoid_hom.map_mul f, u.val_inv, is_monoid_hom.map_one f],
      by rw [← is_monoid_hom.map_mul f, u.inv_val, is_monoid_hom.map_one f] ⟩

instance : is_group_hom (units.map f) :=
⟨λ a b, by ext; exact is_monoid_hom.map_mul f ⟩

instance : is_monoid_hom (coe : units α → α) :=
⟨by simp, by simp⟩

@[simp] lemma coe_map (u : units α) : (map f u : β) = f u := rfl

@[simp] lemma map_id : map (id : α → α) = id := by ext; refl

lemma map_comp : map (g ∘ f) = map g ∘ map f := rfl

lemma map_comp' : map (λ x, g (f x)) = λ x, map g (map f x) := rfl

end units

@[to_additive with_zero]
def with_one (α) := option α

@[to_additive with_zero.monad]
instance : monad with_one := option.monad

@[to_additive with_zero.has_zero]
instance : has_one (with_one α) := ⟨none⟩

@[to_additive with_zero.has_coe_t]
instance : has_coe_t α (with_one α) := ⟨some⟩

@[simp, to_additive with_zero.zero_ne_coe]
lemma with_one.one_ne_coe {a : α} : (1 : with_one α) ≠ a :=
λ h, option.no_confusion h

@[simp, to_additive with_zero.coe_ne_zero]
lemma with_one.coe_ne_one {a : α} : (a : with_one α) ≠ (1 : with_one α) :=
λ h, option.no_confusion h

@[to_additive with_zero.ne_zero_iff_exists]
lemma with_one.ne_one_iff_exists : ∀ {x : with_one α}, x ≠ 1 ↔ ∃ (a : α), x = a
| 1       := ⟨λ h, false.elim $ h rfl, by { rintros ⟨a,ha⟩ h, simpa using h }⟩
| (a : α) := ⟨λ h, ⟨a, rfl⟩, λ h, with_one.coe_ne_one⟩

@[to_additive with_zero.coe_inj]
lemma with_one.coe_inj {a b : α} : (a : with_one α) = b ↔ a = b :=
option.some_inj

@[elab_as_eliminator, to_additive with_zero.cases_on]
protected lemma with_one.cases_on (P : with_one α → Prop) :
  ∀ (x : with_one α), P 1 → (∀ a : α, P a) → P x :=
option.cases_on

attribute [to_additive with_zero.has_zero.equations._eqn_1] with_one.has_one.equations._eqn_1

@[to_additive with_zero.has_add]
instance [has_mul α] : has_mul (with_one α) :=
{ mul := option.lift_or_get (*) }

@[simp, to_additive with_zero.add_coe]
lemma with_one.mul_coe [has_mul α] (a b : α) : (a : with_one α) * b = (a * b : α) := rfl

attribute [to_additive with_zero.has_add.equations._eqn_1] with_one.has_mul.equations._eqn_1

instance [semigroup α] : monoid (with_one α) :=
{ mul_assoc := (option.lift_or_get_assoc _).1,
  one_mul   := (option.lift_or_get_is_left_id _).1,
  mul_one   := (option.lift_or_get_is_right_id _).1,
  ..with_one.has_one,
  ..with_one.has_mul }

attribute [to_additive with_zero.add_monoid._proof_1] with_one.monoid._proof_1
attribute [to_additive with_zero.add_monoid._proof_2] with_one.monoid._proof_2
attribute [to_additive with_zero.add_monoid._proof_3] with_one.monoid._proof_3
attribute [to_additive with_zero.add_monoid] with_one.monoid
attribute [to_additive with_zero.add_monoid.equations._eqn_1] with_one.monoid.equations._eqn_1

instance [comm_semigroup α] : comm_monoid (with_one α) :=
{ mul_comm := (option.lift_or_get_comm _).1,
  ..with_one.monoid }

instance [add_comm_semigroup α] : add_comm_monoid (with_zero α) :=
{ add_comm := (option.lift_or_get_comm _).1,
  ..with_zero.add_monoid }
attribute [to_additive with_zero.add_comm_monoid] with_one.comm_monoid

namespace with_zero

instance [one : has_one α] : has_one (with_zero α) :=
{ ..one }

instance [has_one α] : zero_ne_one_class (with_zero α) :=
{ zero_ne_one := λ h, option.no_confusion h,
  ..with_zero.has_zero,
  ..with_zero.has_one }

lemma coe_one [has_one α] : ((1 : α) : with_zero α) = 1 := rfl

instance [has_mul α] : mul_zero_class (with_zero α) :=
{ mul       := λ o₁ o₂, o₁.bind (λ a, o₂.map (λ b, a * b)),
  zero_mul  := λ a, rfl,
  mul_zero  := λ a, by cases a; refl,
  ..with_zero.has_zero }

@[simp] lemma mul_coe [has_mul α] (a b : α) :
  (a : with_zero α) * b = (a * b : α) := rfl

instance [semigroup α] : semigroup (with_zero α) :=
{ mul_assoc := λ a b c, match a, b, c with
    | none,   _,      _      := rfl
    | some a, none,   _      := rfl
    | some a, some b, none   := rfl
    | some a, some b, some c := congr_arg some (mul_assoc _ _ _)
    end,
  ..with_zero.mul_zero_class }

instance [comm_semigroup α] : comm_semigroup (with_zero α) :=
{ mul_comm := λ a b, match a, b with
    | none,   _      := (mul_zero _).symm
    | some a, none   := rfl
    | some a, some b := congr_arg some (mul_comm _ _)
    end,
  ..with_zero.semigroup }

instance [monoid α] : monoid (with_zero α) :=
{ one_mul := λ a, match a with
    | none   := rfl
    | some a := congr_arg some $ one_mul _
    end,
  mul_one := λ a, match a with
    | none   := rfl
    | some a := congr_arg some $ mul_one _
    end,
  ..with_zero.zero_ne_one_class,
  ..with_zero.semigroup }

instance [comm_monoid α] : comm_monoid (with_zero α) :=
{ ..with_zero.monoid, ..with_zero.comm_semigroup }

definition inv [has_inv α] (x : with_zero α) : with_zero α :=
do a ← x, return a⁻¹

instance [has_inv α] : has_inv (with_zero α) := ⟨with_zero.inv⟩

@[simp] lemma inv_coe [has_inv α] (a : α) :
  (a : with_zero α)⁻¹ = (a⁻¹ : α) := rfl
@[simp] lemma inv_zero [has_inv α] :
  (0 : with_zero α)⁻¹ = 0 := rfl

section group
variables [group α]

@[simp] lemma inv_one : (1 : with_zero α)⁻¹ = 1 :=
show ((1⁻¹ : α) : with_zero α) = 1, by simp [coe_one]

definition with_zero.div (x y : with_zero α) : with_zero α :=
x * y⁻¹

instance : has_div (with_zero α) := ⟨with_zero.div⟩

@[simp] lemma zero_div (a : with_zero α) : 0 / a = 0 := rfl
@[simp] lemma div_zero (a : with_zero α) : a / 0 = 0 := by change a * _ = _; simp

lemma div_coe (a b : α) : (a : with_zero α) / b = (a * b⁻¹ : α) := rfl

lemma one_div (x : with_zero α) : 1 / x = x⁻¹ := one_mul _

@[simp] lemma div_one : ∀ (x : with_zero α), x / 1 = x
| 0       := rfl
| (a : α) := show _ * _ = _, by simp

@[simp] lemma mul_right_inv : ∀  (x : with_zero α) (h : x ≠ 0), x * x⁻¹ = 1
| 0       h := false.elim $ h rfl
| (a : α) h := by simp [coe_one]

@[simp] lemma mul_left_inv : ∀  (x : with_zero α) (h : x ≠ 0), x⁻¹ * x = 1
| 0       h := false.elim $ h rfl
| (a : α) h := by simp [coe_one]

@[simp] lemma mul_inv_rev : ∀ (x y : with_zero α), (x * y)⁻¹ = y⁻¹ * x⁻¹
| 0       0       := rfl
| 0       (b : α) := rfl
| (a : α) 0       := rfl
| (a : α) (b : α) := by simp

@[simp] lemma mul_div_cancel {a b : with_zero α} (hb : b ≠ 0) : a * b / b = a :=
show _ * _ * _ = _, by simp [mul_assoc, hb]

@[simp] lemma div_mul_cancel {a b : with_zero α} (hb : b ≠ 0) : a / b * b = a :=
show _ * _ * _ = _, by simp [mul_assoc, hb]

lemma div_eq_iff_mul_eq {a b c : with_zero α} (hb : b ≠ 0) : a / b = c ↔ c * b = a :=
by split; intro h; simp [h.symm, hb]

end group

section comm_group
variables [comm_group α] {a b c d : with_zero α}

lemma div_eq_div (hb : b ≠ 0) (hd : d ≠ 0) : a / b = c / d ↔ a * d = b * c :=
begin
  rw ne_zero_iff_exists at hb hd,
  rcases hb with ⟨b, rfl⟩,
  rcases hd with ⟨d, rfl⟩,
  induction a using with_zero.cases_on;
  induction c using with_zero.cases_on,
  { refl },
  { simp [div_coe] },
  { simp [div_coe] },
  erw [with_zero.coe_inj, with_zero.coe_inj],
  show a * b⁻¹ = c * d⁻¹ ↔ a * d = b * c,
  split; intro H,
  { rw mul_inv_eq_iff_eq_mul at H,
    rw [H, mul_right_comm, inv_mul_cancel_right, mul_comm] },
  { rw [mul_inv_eq_iff_eq_mul, mul_right_comm, mul_comm c, ← H, mul_inv_cancel_right] }
end

end comm_group

end with_zero


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

import .limits.shapes.products basic data.dvector
       .limits.shapes.equalizers
       category_theory.limits.limits

universes v u

open category_theory

namespace category_theory.limits

@[derive decidable_eq] inductive two : Type u
| left | right

def two.map {C : Sort*} (X Y : C) : two → C
| two.left := X
| two.right := Y

def two.functor {C : Sort u} (X Y : C) [category.{v+1} C] : discrete two ⥤ C :=
functor.of_function (two.map X Y)

def empty.functor (C : Sort*) [category.{v+1} C] : discrete pempty ⥤ C :=
functor.of_function (λ x, by {cases x} : pempty → C)

def empty_cone {C : Sort u} [category.{v+1} C] (A : C) : limits.cone (empty.functor C) :=
{ X := A,
  π := { app := λ x, by cases x,
  naturality' := by tidy}}

def commutative_square {C : Sort u} [category.{v u} C] {A B A' B' : C}
  (f_top : A ⟶ B) (d_left : A ⟶ A') (d_right : B ⟶ B') (f_bot : A' ⟶ B') :=
f_top ≫ d_right = d_left ≫ f_bot

variables {C : Type u} [𝒞 : category.{v+1} C]
include 𝒞

variable(C)
@[class] def has_binary_products := has_limits_of_shape (discrete two.{v}) C
@[class] def has_terminal_object : Sort* := has_limits_of_shape.{v} (discrete pempty) C

@[class] def has_binary_coproducts := has_colimits_of_shape (discrete two.{v}) C
@[class] def has_initial_object : Sort* := has_colimits_of_shape.{v} (discrete pempty) C

@[instance] def has_limit_two_of_has_binary_products [H : has_binary_products C] {X Y : C} :
  has_limit $ two.functor X Y :=
@has_limits_of_shape.has_limit _ _ _ _ H (two.functor X Y)

@[instance] def has_limit_empty_of_has_terminal_object [H : has_terminal_object C] :
  has_limit $ empty.functor C :=
@has_limits_of_shape.has_limit _ _ _ _ H (empty.functor C)

variable{C}

def has_terminal_object.mk (T : C) (h₁ : ∀(X : C), X ⟶ T)
  (h₂ : ∀{{X : C}} (f g : X ⟶ T), f = g) : has_terminal_object C :=
⟨λ F, { cone := ⟨T, ⟨pempty.rec _, pempty.rec _⟩⟩,
  is_limit :=
  { lift := λ s, h₁ s.X,
    fac' := λ s, pempty.rec _,
    uniq' := λ s m h, h₂ _ _ } }⟩

def has_binary_products.mk (m : C → C → C) (p1 : ∀{X Y : C}, m X Y ⟶ X)
  (p2 : ∀{X Y : C}, m X Y ⟶ Y) (lft : ∀{{X Y Z : C}} (f : Z ⟶ X) (g : Z ⟶ Y), Z ⟶ m X Y)
  (lft1 : ∀{{X Y Z : C}} (f : Z ⟶ X) (g : Z ⟶ Y), lft f g ≫ p1 = f)
  (lft2 : ∀{{X Y Z : C}} (f : Z ⟶ X) (g : Z ⟶ Y), lft f g ≫ p2 = g)
  (lft_unique : ∀{{X Y Z : C}} (f g : Z ⟶ m X Y) (h1 : f ≫ p1 = g ≫ p1) (h2 : f ≫ p2 = g ≫ p2),
    f = g) : has_binary_products C :=
begin
  constructor, intro F, fsplit,
  { use m (F.obj two.left) (F.obj two.right),
    apply nat_trans.of_homs, refine two.rec _ _, exact p1, exact p2 },
  refine limits.is_limit.mk _ _ _,
  { rintro ⟨X, f⟩, apply lft (f.app two.left), dsimp, exact f.app two.right },
  { rintro ⟨X, f⟩ (_|_), apply lft1, apply lft2 },
  { rintro ⟨X, f⟩ g h, dsimp, apply lft_unique,
    rw [lft1], exact h two.left, rw [lft2], exact h two.right }
end

def has_initial_object.mk (I : C) (h₁ : ∀(X : C), I ⟶ X)
  (h₂ : ∀{{X : C}} (f g : I ⟶ X), f = g) : has_initial_object C :=
⟨λ F, { cocone := ⟨I, ⟨pempty.rec _, pempty.rec _⟩⟩,
  is_colimit :=
  { desc := λ s, h₁ s.X,
    fac' := λ s, pempty.rec _,
    uniq' := λ s m h, h₂ _ _ } }⟩

def has_binary_coproducts.mk (p : C → C → C) (i1 : ∀{X Y : C}, X ⟶ p X Y)
  (i2 : ∀{X Y : C}, Y ⟶ p X Y) (dsc : ∀{{X Y Z : C}} (f : X ⟶ Z) (g : Y ⟶ Z), p X Y ⟶ Z)
  (dsc1 : ∀{{X Y Z : C}} (f : X ⟶ Z) (g : Y ⟶ Z), i1 ≫ dsc f g = f)
  (dsc2 : ∀{{X Y Z : C}} (f : X ⟶ Z) (g : Y ⟶ Z), i2 ≫ dsc f g = g)
  (dsc_unique : ∀{{X Y Z : C}} (f g : p X Y ⟶ Z) (h1 : i1 ≫ f = i1 ≫ g) (h2 : i2 ≫ f = i2 ≫ g),
    f = g) : has_binary_coproducts C :=
begin
  constructor, intro F, fsplit,
  { use p (F.obj two.left) (F.obj two.right),
    apply nat_trans.of_homs, refine two.rec _ _, exact i1, exact i2 },
  refine limits.is_colimit.mk _ _ _,
  { rintro ⟨X, f⟩, apply dsc (f.app two.left), dsimp, exact f.app two.right },
  { rintro ⟨X, f⟩ (_|_), apply dsc1, apply dsc2 },
  { rintro ⟨X, f⟩ g h, dsimp, apply dsc_unique,
    rw [dsc1], exact h two.left, rw [dsc2], exact h two.right }
end

/-- The binary product is the vertex of the limiting cone to the canonical functor two → 𝒞
    associated to X and Y -/
def binary_product (X Y : C) [has_limit $ two.functor X Y] : C :=
limit (two.functor X Y)

namespace binary_product

local infix ` × `:60 := binary_product

def π₁ {X Y : C} [has_limit $ two.functor X Y] : X × Y ⟶ X := limit.π _ two.left

def π₂ {X Y : C} [has_limit $ two.functor X Y] : X × Y ⟶ Y := limit.π _ two.right

/-- An alternative version of `π₁` if type-class inference fails -/
def π₁' {X Y : C} {H : has_binary_products C} : X × Y ⟶ X := π₁
/-- An alternative version of `π₂` if type-class inference fails -/
def π₂' {X Y : C} {H : has_binary_products C} : X × Y ⟶ Y := π₂

def dfin.map {n : ℕ} : dvector C n → dfin n → C :=
λ v d, by {induction v, cases d, cases d, exact v_x, exact v_ih d_a}

example {X : C} [has_binary_products C] : X × X × X = (X × X) × X := by refl

def cone_of_two_maps {W A₁ A₂: C} (f₁ : W ⟶ A₁) (f₂ : W ⟶ A₂) : cone (two.functor A₁ A₂) :=
{ X := W,
  π := { app := λ l, two.rec_on l f₁ f₂,
  naturality' := by tidy}}

lemma cone_of_two_maps_object [has_binary_products C] {B₁ B₂ A₁ A₂: C} {f₁ : B₁ × B₂ ⟶ A₁}
  {f₂ : B₁ × B₂ ⟶ A₂} : (cone_of_two_maps f₁ f₂).X = B₁ × B₂ := by refl

def map_to_product.mk {H : has_binary_products C} {W B₁ B₂ : C} (f₁ : W ⟶ B₁) (f₂ : W ⟶ B₂) :
  W ⟶ B₁ × B₂ :=
is_limit.lift (limit.is_limit _) (cone_of_two_maps f₁ f₂)

def diag [H : has_binary_products C] {B : C} : B ⟶ B × B :=
map_to_product.mk (𝟙 B) (𝟙 B)

protected def map {H : has_binary_products C} {A A' B B' : C} (f : A ⟶ A') (g : B ⟶ B') :
  A × B ⟶ A' × B' :=
map_to_product.mk (π₁ ≫ f) (π₂ ≫ g)

local infix ` ×.map `:90 := binary_product.map

protected def iso {H : has_binary_products C} {A A' B B' : C} (f : A ≅ A') (g : B ≅ B') :
  A × B ≅ A' × B' :=
{ hom := f.hom ×.map g.hom,
  inv := f.inv ×.map g.inv,
  hom_inv_id' := omitted,
  inv_hom_id' := omitted }

local infix ` ×.iso `:90 := binary_product.iso

def assoc_hom {H : has_binary_products C} {X Y Z : C} : (X × Y) × Z ⟶ X × (Y × Z) :=
by apply map_to_product.mk (π₁ ≫ π₁) (π₂ ×.map (𝟙 Z))

def assoc_inv {H : has_binary_products C} {X Y Z : C} : X × (Y × Z) ⟶ (X × Y) × Z :=
by apply map_to_product.mk (𝟙 X ×.map π₁) (π₂ ≫ π₂)

def product_assoc {H : has_binary_products C} {X Y Z : C} : (X × Y) × Z ≅ X × (Y × Z) :=
{ hom := assoc_hom,
  inv := assoc_inv,
  hom_inv_id' := omitted,
  inv_hom_id' := omitted}

def product_comm {H : has_binary_products C} {X Y : C} : X × Y ≅ Y × X :=
{ hom := map_to_product.mk π₂ π₁,
  inv := map_to_product.mk π₂ π₁,
  hom_inv_id' := omitted,
  inv_hom_id' := omitted}

def product_assoc4 {H : has_binary_products C} {X Y Z W : C} :
  (X × Y) × (Z × W) ≅ (X × Z) × (Y × W) :=
product_assoc ≪≫
iso.refl X ×.iso (product_assoc.symm ≪≫ product_comm ×.iso iso.refl W ≪≫ product_assoc) ≪≫
product_assoc.symm

example :
  commutative_square
         /-unit-/ (𝟙 unit) /- unit  -/
         (𝟙 unit)            (𝟙 unit)
         /-unit-/ (𝟙 unit) /- unit -/
  := by tidy

end binary_product
open binary_product

section terminal_object

local infix ` × `:60 := binary_product

def terminal_object [has_terminal_object C] : C :=
limit (empty.functor C)

notation `term` := terminal_object

def terminal_map [has_terminal_object C] (A : C) : A ⟶ term :=
is_limit.lift (limit.is_limit (empty.functor C)) (empty_cone A)

lemma terminal_map_eq [has_terminal_object C] {A : C} (f g : A ⟶ term) : f = g :=
omitted

lemma mul_one [has_terminal_object C] [has_binary_products C] (G : C) :
  nonempty $ term × G ≅ G := omitted

lemma one_mul [has_terminal_object C] [has_binary_products C] (G : C) :
  nonempty $ G × term ≅ G := omitted

def mul_one_inv [has_terminal_object C] [has_binary_products C] {G : C} : G ⟶ G × term :=
by apply map_to_product.mk (𝟙 _) (terminal_map G)

def one_mul_inv [has_terminal_object C] [has_binary_products C] {G : C} : G ⟶ term × G :=
by apply map_to_product.mk (terminal_map G) (𝟙 _)

end terminal_object

section pow

local infix ` × `:60 := binary_product

/-- The n-fold product of an object with itself -/
def category.pow [has_binary_products C] [has_terminal_object C] (X : C) : ℕ → C
| 0     := term
| 1     := X
| (n+2) := X × category.pow (n+1)

end pow

namespace finite_limits
open binary_product

instance fintype_two : fintype two :=
{elems := { val := ⟦[two.left, two.right]⟧,
  nodup := by tidy },
  complete := λ x, by cases x; tidy}

example : fintype pempty := by apply_instance

section finite_products

variable (C)
@[class]def has_finite_products := Π α : Type*, fintype α → has_limits_of_shape.{v} (discrete α) C

@[class]def has_equalizers := has_limits_of_shape.{v} (walking_pair) C

@[instance] def has_binary_products_of_has_finite_products [H : has_finite_products C] :
  has_binary_products C := H _ infer_instance

@[instance] def has_terminal_object_of_has_finite_products [H : has_finite_products C] :
  has_limits_of_shape.{v} (discrete pempty) C := H _ infer_instance

@[class]def has_finite_limits := @has_finite_products C 𝒞 × @has_equalizers C 𝒞

end finite_products

end finite_limits

end category_theory.limits


import topology.category.Top.limits
import category_theory.limits.shapes
import topology.instances.real

/- This file contains some demos of using the (co)limits API to do topology. -/

noncomputable theory

open category_theory
open category_theory.limits

def R : Top := Top.of ℝ
def I : Top := Top.of (set.Icc 0 1 : set ℝ)
def pt : Top := Top.of unit

section MappingCylinder
-- Let's construct the mapping cylinder.
def to_pt (X : Top) : X ⟶ pt :=
{ val := λ _, unit.star, property := continuous_const }
def I₀ : pt ⟶ I :=
{ val := λ _, ⟨(0 : ℝ), begin rw [set.left_mem_Icc], norm_num, end⟩,
  property := continuous_const }
def I₁ : pt ⟶ I :=
{ val := λ _, ⟨(1 : ℝ), begin rw [set.right_mem_Icc], norm_num, end⟩,
  property := continuous_const }

def cylinder (X : Top) : Top := prod X I
-- To define a map to the cylinder, we give a map to each factor.
-- `prod.lift` is a helper method, providing a wrapper around `limit.lift` for binary products.
def cylinder₀ (X : Top) : X ⟶ cylinder X :=
prod.lift (𝟙 X) (to_pt X ≫ I₀)
def cylinder₁ (X : Top) : X ⟶ cylinder X :=
prod.lift (𝟙 X) (to_pt X ≫ I₁)

-- The mapping cylinder is the pushout of the diagram
--    X
--   ↙ ↘
--  Y   (X x I)
-- (`pushout` is implemented just as a wrapper around `colimit`) is
def mapping_cylinder {X Y : Top} (f : X ⟶ Y) : Top := pushout f (cylinder₁ X)

/-- We construct the map from `X` into the "bottom" of the mapping cylinder
for `f : X ⟶ Y`, as the composition of the inclusion of `X` into the bottom of the
cylinder `prod X I`, followed by the map `pushout.inr` of `prod X I` into `mapping_cylinder f`. -/
def mapping_cylinder₀ {X Y : Top} (f : X ⟶ Y) : X ⟶ mapping_cylinder f :=
cylinder₀ X ≫ pushout.inr

/--
The mapping cone is defined as the pushout of
```
         X
        ↙ ↘
 (Cyl f)   pt
```
(where the left arrow is `mapping_cylinder₀`).
This makes it an iterated colimit; one could also define it in one step as the colimit of
```
--    X        X
--   ↙ ↘      ↙ ↘
--  Y   (X x I)  pt
```
-/
def mapping_cone {X Y : Top} (f : X ⟶ Y) : Top := pushout (mapping_cylinder₀ f) (to_pt X)

-- TODO Hopefully someone will write a nice tactic for generating diagrams quickly,
-- and we'll be able to verify that this iterated construction is the same as the colimit
-- over a single diagram.
end MappingCylinder

section Gluing

-- Here's two copies of the real line glued together at a point.
def f : pt ⟶ R := { val := λ _, (0 : ℝ), property := continuous_const }

/-- Two copies of the real line glued together at 0. -/
def X : Top := pushout f f

-- To define a map out of it, we define maps out of each copy of the line,
-- and check the maps agree at 0.
def g : X ⟶ R :=
pushout.desc (𝟙 _) (𝟙 _) rfl

end Gluing

universes v u w

section Products

/-- The countably infinite product of copies of `ℝ`. -/
def Y : Top := ∏ (λ n : ℕ, R)

/-- We define a point of this infinite product by specifying its coordinates. -/
def q : pt ⟶ Y :=
pi.lift (λ (n : ℕ), ⟨λ (_ : pt), (n : ℝ), continuous_const⟩)

-- "Looking under the hood", we see that `q` is a `subtype`, whose `val` is a function `unit → Y.α`.
-- #check q.val -- q.val : pt.α → Y.α
-- `q.property` is the fact this function is continous (i.e. no content)

-- We can check that this function is definitionally just the function we specified.
example : (q.val ()).val (57 : ℕ) = ((57 : ℕ) : ℝ) := rfl

end Products


example : ¬ true = false := by
  simp [(¬ ·)]

example (h : y = 0) : x + y = x := by
  simp [(.+.)] -- Expands `HAdd.hAdd
  traceState
  simp [Add.add]
  simp [h, Nat.add]
  done

example (h : y = 0) : x + y = x := by
  simp [.+.]
  traceState
  simp [Add.add]
  simp [h, Nat.add]
  done


/-
Copyright (c) 2017 Johannes Hölzl. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Johannes Hölzl, Johan Commelin, Mario Carneiro
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.data.mv_polynomial.basic
import Mathlib.PostPort

universes u_1 u_2 u_4 u_5 u_3

namespace Mathlib

/-!
# Renaming variables of polynomials

This file establishes the `rename` operation on multivariate polynomials,
which modifies the set of variables.

## Main declarations

* `mv_polynomial.rename`

## Notation

As in other polynomial files, we typically use the notation:

+ `σ τ α : Type*` (indexing the variables)

+ `R S : Type*` `[comm_semiring R]` `[comm_semiring S]` (the coefficients)

+ `s : σ →₀ ℕ`, a function from `σ` to `ℕ` which is zero away from a finite set.
This will give rise to a monomial in `mv_polynomial σ R` which mathematicians might call `X^s`

+ `r : R` elements of the coefficient ring

+ `i : σ`, with corresponding monomial `X i`, often denoted `X_i` by mathematicians

+ `p : mv_polynomial σ α`

-/

namespace mv_polynomial

/-- Rename all the variables in a multivariable polynomial. -/
def rename {σ : Type u_1} {τ : Type u_2} {R : Type u_4} [comm_semiring R] (f : σ → τ) : alg_hom R (mv_polynomial σ R) (mv_polynomial τ R) :=
  aeval (X ∘ f)

@[simp] theorem rename_C {σ : Type u_1} {τ : Type u_2} {R : Type u_4} [comm_semiring R] (f : σ → τ) (r : R) : coe_fn (rename f) (coe_fn C r) = coe_fn C r :=
  eval₂_C (algebra_map R (mv_polynomial τ R)) (fun (n : σ) => function.comp X f n) r

@[simp] theorem rename_X {σ : Type u_1} {τ : Type u_2} {R : Type u_4} [comm_semiring R] (f : σ → τ) (i : σ) : coe_fn (rename f) (X i) = X (f i) :=
  eval₂_X (algebra_map R (mv_polynomial τ R)) (fun (n : σ) => function.comp X f n) i

theorem map_rename {σ : Type u_1} {τ : Type u_2} {R : Type u_4} {S : Type u_5} [comm_semiring R] [comm_semiring S] (f : R →+* S) (g : σ → τ) (p : mv_polynomial σ R) : coe_fn (map f) (coe_fn (rename g) p) = coe_fn (rename g) (coe_fn (map f) p) := sorry

@[simp] theorem rename_rename {σ : Type u_1} {τ : Type u_2} {α : Type u_3} {R : Type u_4} [comm_semiring R] (f : σ → τ) (g : τ → α) (p : mv_polynomial σ R) : coe_fn (rename g) (coe_fn (rename f) p) = coe_fn (rename (g ∘ f)) p := sorry

@[simp] theorem rename_id {σ : Type u_1} {R : Type u_4} [comm_semiring R] (p : mv_polynomial σ R) : coe_fn (rename id) p = p :=
  eval₂_eta p

theorem rename_monomial {σ : Type u_1} {τ : Type u_2} {R : Type u_4} [comm_semiring R] (f : σ → τ) (d : σ →₀ ℕ) (r : R) : coe_fn (rename f) (monomial d r) = monomial (finsupp.map_domain f d) r := sorry

theorem rename_eq {σ : Type u_1} {τ : Type u_2} {R : Type u_4} [comm_semiring R] (f : σ → τ) (p : mv_polynomial σ R) : coe_fn (rename f) p = finsupp.map_domain (finsupp.map_domain f) p := sorry

theorem rename_injective {σ : Type u_1} {τ : Type u_2} {R : Type u_4} [comm_semiring R] (f : σ → τ) (hf : function.injective f) : function.injective ⇑(rename f) := sorry

theorem eval₂_rename {σ : Type u_1} {τ : Type u_2} {R : Type u_4} {S : Type u_5} [comm_semiring R] [comm_semiring S] (f : R →+* S) (k : σ → τ) (g : τ → S) (p : mv_polynomial σ R) : eval₂ f g (coe_fn (rename k) p) = eval₂ f (g ∘ k) p := sorry

theorem eval₂_hom_rename {σ : Type u_1} {τ : Type u_2} {R : Type u_4} {S : Type u_5} [comm_semiring R] [comm_semiring S] (f : R →+* S) (k : σ → τ) (g : τ → S) (p : mv_polynomial σ R) : coe_fn (eval₂_hom f g) (coe_fn (rename k) p) = coe_fn (eval₂_hom f (g ∘ k)) p :=
  eval₂_rename f k (fun (n : τ) => g n) p

theorem aeval_rename {σ : Type u_1} {τ : Type u_2} {R : Type u_4} {S : Type u_5} [comm_semiring R] [comm_semiring S] (k : σ → τ) (g : τ → S) (p : mv_polynomial σ R) [algebra R S] : coe_fn (aeval g) (coe_fn (rename k) p) = coe_fn (aeval (g ∘ k)) p :=
  eval₂_hom_rename (algebra_map R S) k (fun (n : τ) => g n) p

theorem rename_eval₂ {σ : Type u_1} {τ : Type u_2} {R : Type u_4} [comm_semiring R] (k : σ → τ) (p : mv_polynomial σ R) (g : τ → mv_polynomial σ R) : coe_fn (rename k) (eval₂ C (g ∘ k) p) = eval₂ C (⇑(rename k) ∘ g) (coe_fn (rename k) p) := sorry

theorem rename_prodmk_eval₂ {σ : Type u_1} {τ : Type u_2} {R : Type u_4} [comm_semiring R] (p : mv_polynomial σ R) (j : τ) (g : σ → mv_polynomial σ R) : coe_fn (rename (Prod.mk j)) (eval₂ C g p) = eval₂ C (fun (x : σ) => coe_fn (rename (Prod.mk j)) (g x)) p := sorry

theorem eval₂_rename_prodmk {σ : Type u_1} {τ : Type u_2} {R : Type u_4} {S : Type u_5} [comm_semiring R] [comm_semiring S] (f : R →+* S) (g : σ × τ → S) (i : σ) (p : mv_polynomial τ R) : eval₂ f g (coe_fn (rename (Prod.mk i)) p) = eval₂ f (fun (j : τ) => g (i, j)) p := sorry

theorem eval_rename_prodmk {σ : Type u_1} {τ : Type u_2} {R : Type u_4} [comm_semiring R] (g : σ × τ → R) (i : σ) (p : mv_polynomial τ R) : coe_fn (eval g) (coe_fn (rename (Prod.mk i)) p) = coe_fn (eval fun (j : τ) => g (i, j)) p :=
  eval₂_rename_prodmk (ring_hom.id R) (fun (n : σ × τ) => g n) i p

/-- Every polynomial is a polynomial in finitely many variables. -/
theorem exists_finset_rename {σ : Type u_1} {R : Type u_4} [comm_semiring R] (p : mv_polynomial σ R) : ∃ (s : finset σ), ∃ (q : mv_polynomial (Subtype fun (x : σ) => x ∈ s) R), p = coe_fn (rename coe) q := sorry

/-- Every polynomial is a polynomial in finitely many variables. -/
theorem exists_fin_rename {σ : Type u_1} {R : Type u_4} [comm_semiring R] (p : mv_polynomial σ R) : ∃ (n : ℕ), ∃ (f : fin n → σ), ∃ (hf : function.injective f), ∃ (q : mv_polynomial (fin n) R), p = coe_fn (rename f) q := sorry

theorem eval₂_cast_comp {σ : Type u_1} {τ : Type u_2} {R : Type u_4} [comm_semiring R] (f : σ → τ) (c : ℤ →+* R) (g : τ → R) (p : mv_polynomial σ ℤ) : eval₂ c (g ∘ f) p = eval₂ c g (coe_fn (rename f) p) := sorry

@[simp] theorem coeff_rename_map_domain {σ : Type u_1} {τ : Type u_2} {R : Type u_4} [comm_semiring R] (f : σ → τ) (hf : function.injective f) (φ : mv_polynomial σ R) (d : σ →₀ ℕ) : coeff (finsupp.map_domain f d) (coe_fn (rename f) φ) = coeff d φ := sorry

theorem coeff_rename_eq_zero {σ : Type u_1} {τ : Type u_2} {R : Type u_4} [comm_semiring R] (f : σ → τ) (φ : mv_polynomial σ R) (d : τ →₀ ℕ) (h : ∀ (u : σ →₀ ℕ), finsupp.map_domain f u = d → coeff u φ = 0) : coeff d (coe_fn (rename f) φ) = 0 := sorry

theorem coeff_rename_ne_zero {σ : Type u_1} {τ : Type u_2} {R : Type u_4} [comm_semiring R] (f : σ → τ) (φ : mv_polynomial σ R) (d : τ →₀ ℕ) (h : coeff d (coe_fn (rename f) φ) ≠ 0) : ∃ (u : σ →₀ ℕ), finsupp.map_domain f u = d ∧ coeff u φ ≠ 0 := sorry

@[simp] theorem constant_coeff_rename {σ : Type u_1} {R : Type u_4} [comm_semiring R] {τ : Type u_2} (f : σ → τ) (φ : mv_polynomial σ R) : coe_fn constant_coeff (coe_fn (rename f) φ) = coe_fn constant_coeff φ := sorry


import data.real.nnreal

open_locale nnreal

namespace nnreal

variables (r r' k c c₁ c₂ c₃ : ℝ≥0)

instance fact_le_of_lt [h : fact (c₁ < c₂)] : fact (c₁ ≤ c₂) := ⟨h.1.le⟩

instance fact_pos_of_one_le [hk : fact (1 ≤ c)] : fact (0 < c) :=
⟨lt_of_lt_of_le zero_lt_one hk.1⟩

instance fact_mul_pos [h1 : fact (0 < c₁)] [h2 : fact (0 < c₂)] : fact (0 < c₁ * c₂) :=
⟨mul_pos h1.out h2.out⟩

instance fact_le_mul_of_one_le_left [hk : fact (1 ≤ k)] [hc : fact (c₁ ≤ c₂)] :
  fact (c₁ ≤ k * c₂) :=
⟨calc c₁ = 1 * c₁ : (one_mul _).symm ... ≤ k * c₂ : mul_le_mul' hk.1 hc.1⟩

instance fact_le_mul_of_one_le_right [hc : fact (c₁ ≤ c₂)] [hk : fact (1 ≤ k)] :
  fact (c₁ ≤ c₂ * k) :=
⟨calc c₁ = c₁ * 1 : (mul_one _).symm ... ≤ c₂ * k : mul_le_mul' hc.1 hk.1⟩

instance fact_mul_le_of_le_one_left [hk : fact (k ≤ 1)] [hc : fact (c₁ ≤ c₂)] :
  fact (k * c₁ ≤ c₂) :=
⟨calc k * c₁ ≤ 1 * c₂ : mul_le_mul' hk.1 hc.1 ... = c₂     : one_mul _⟩

instance fact_mul_le_of_le_one_right [hk : fact (k ≤ 1)] [hc : fact (c₁ ≤ c₂)] :
  fact (c₁ * k ≤ c₂) :=
⟨calc c₁ * k ≤ c₂ * 1 : mul_le_mul' hc.1 hk.1 ... = c₂ : mul_one _⟩

instance fact_one_le_add_one : fact (1 ≤ k + 1) :=
⟨self_le_add_left 1 k⟩

instance fact_le_refl : fact (c ≤ c) := ⟨le_rfl⟩

instance fact_le_subst_right [fact (c₁ ≤ c₂)] [h : fact (c₂ = c₃)]: fact (c₁ ≤ c₃) :=
by rwa ← h.1

instance fact_le_subst_right' [fact (c₁ ≤ c₂)] [h : fact (c₃ = c₂)]: fact (c₁ ≤ c₃) :=
by rwa ← h.1.symm

instance fact_le_subst_left [fact (c₁ ≤ c₂)] [h : fact (c₁ = c₃)]: fact (c₃ ≤ c₂) :=
by rwa ← h.1

instance fact_le_subst_left' [fact (c₁ ≤ c₂)] [h : fact (c₃ = c₁)]: fact (c₃ ≤ c₂) :=
by rwa ← h.1.symm

instance fact_inv_mul_le [h : fact (0 < r')] : fact (r'⁻¹ * (r' * c) ≤ c) :=
⟨le_of_eq $ inv_mul_cancel_left₀ (ne_of_gt h.1) _⟩

instance fact_mul_le_mul_left [h : fact (c₁ ≤ c₂)] : fact (r' * c₁ ≤ r' * c₂) :=
⟨mul_le_mul' le_rfl h.1⟩

instance fact_mul_le_mul_right [h : fact (c₁ ≤ c₂)] : fact (c₁ * r' ≤ c₂ * r') :=
⟨mul_le_mul' h.1 le_rfl⟩

instance fact_le_inv_mul_self [h1 : fact (0 < r')] [h2 : fact (r' ≤ 1)] : fact (c ≤ r'⁻¹ * c) :=
begin
  constructor,
  rw mul_comm,
  apply le_mul_inv_of_mul_le (ne_of_gt h1.1),
  nth_rewrite 1 ← mul_one c,
  exact mul_le_mul (le_of_eq rfl) h2.1 (le_of_lt h1.1) zero_le',
end

instance fact_le_max_left (a b c : ℝ≥0) [h : fact (a ≤ b)] : fact (a ≤ max b c) :=
⟨h.1.trans $ le_max_left _ _⟩

instance fact_one_le_mul_self (a : ℝ≥0) [h : fact (1 ≤ a)] : fact (1 ≤ a * a) :=
⟨calc (1 : ℝ≥0) = 1 * 1 : (mul_one 1).symm
           ... ≤ a * a : mul_le_mul' h.1 h.1⟩

instance one_le_add {a b : ℝ≥0} [ha : fact (1 ≤ a)] : fact (1 ≤ a + b) :=
⟨le_trans ha.1 $ by simp⟩
instance one_le_add' {a b : ℝ≥0} [hb : fact (1 ≤ b)] : fact (1 ≤ a + b) :=
⟨le_trans hb.1 $ by simp⟩

instance fact_one_le_pow {n : ℕ} {a : ℝ≥0} [h : fact (1 ≤ a)] : fact (1 ≤ a^n) :=
begin
  cases n,
  { simpa only [pow_zero] using nnreal.fact_le_refl _ },
  { rwa @one_le_pow_iff _ _ _ nnreal.covariant_mul, apply nat.succ_ne_zero }
end

instance fact_pow_le_one {n : ℕ} {a : ℝ≥0} [h : fact (a ≤ 1)] : fact (a^n ≤ 1) :=
begin
  cases n,
  { simpa only [pow_zero] using nnreal.fact_le_refl _ },
  { rwa @pow_le_one_iff _ _ _ nnreal.covariant_mul, apply nat.succ_ne_zero }
end

lemma fact_le_pow_mul_of_le_pow_succ_mul {n : ℕ} (r : ℝ≥0)
  [fact (r ≤ 1)] [h : fact (c₂ ≤ r ^ (n+1) * c₁)] :
  fact (c₂ ≤ r ^ n * c₁) :=
begin
  refine ⟨h.1.trans _⟩,
  rw [pow_succ, mul_assoc],
  apply fact.out
end

instance fact_le_mul_add : fact (c * c₁ + c * c₂ ≤ c * (c₁ + c₂)) :=
by { rw mul_add, exact nnreal.fact_le_refl _ }

instance fact_nat_cast_pos (N : ℕ) [hN: fact (0 < N)] : fact (0 < (N:ℝ≥0)) :=
⟨nat.cast_pos.mpr hN.1⟩

instance fact_nat_cast_inv_le_one (N : ℕ) : fact ((N:ℝ≥0)⁻¹ ≤ 1) :=
begin
  by_cases hN : N = 0,
  { subst hN, simp only [nat.cast_zero, inv_zero, zero_le'], exact ⟨trivial⟩ },
  { rw [inv_le, mul_one], swap, { exact_mod_cast hN },
    norm_cast,
    rw nat.add_one_le_iff,
    exact ⟨nat.pos_of_ne_zero hN⟩, }
end

instance fact_inv_le_one [H : fact (1 ≤ c)] : fact (c⁻¹ ≤ 1) :=
begin
  by_cases hc : c = 0,
  { rw hc at H, exact (not_le_of_lt zero_lt_one H.1).elim },
  rwa [inv_le hc, mul_one]
end

instance fact_one_le_two : fact ((1:ℝ≥0) ≤ 2) := ⟨one_le_two⟩

instance fact_two_pow_inv_le_two_pow_inv (N : ℕ) : fact ((2 ^ N : ℝ≥0)⁻¹ ≤ (2 ^ N : ℕ)⁻¹) :=
⟨le_of_eq $ by norm_cast⟩

instance fact_two_pow_inv_le_one (N : ℕ) : fact ((2 ^ N : ℝ≥0)⁻¹ ≤ 1) :=
⟨le_trans (nnreal.fact_two_pow_inv_le_two_pow_inv N).1 $ fact.out _⟩

end nnreal

#lint- only unused_arguments def_lemma doc_blame


/-
Copyright (c) 2019 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Scott Morrison, Justus Springer
-/
import topology.category.Top.open_nhds
import topology.sheaves.presheaf
import topology.sheaves.sheaf_condition.unique_gluing
import category_theory.limits.types
import category_theory.limits.preserves.filtered
import category_theory.limits.final
import topology.sober
import tactic.elementwise
import algebra.category.CommRing

/-!
# Stalks

For a presheaf `F` on a topological space `X`, valued in some category `C`, the *stalk* of `F`
at the point `x : X` is defined as the colimit of the following functor

(nhds x)ᵒᵖ ⥤ (opens X)ᵒᵖ ⥤ C

where the functor on the left is the inclusion of categories and the functor on the right is `F`.
For an open neighborhood `U` of `x`, we define the map `F.germ x : F.obj (op U) ⟶ F.stalk x` as the
canonical morphism into this colimit.

Taking stalks is functorial: For every point `x : X` we define a functor `stalk_functor C x`,
sending presheaves on `X` to objects of `C`. Furthermore, for a map `f : X ⟶ Y` between
topological spaces, we define `stalk_pushforward` as the induced map on the stalks
`(f _* ℱ).stalk (f x) ⟶ ℱ.stalk x`.

Some lemmas about stalks and germs only hold for certain classes of concrete categories. A basic
property of forgetful functors of categories of algebraic structures (like `Mon`, `CommRing`,...)
is that they preserve filtered colimits. Since stalks are filtered colimits, this ensures that
the stalks of presheaves valued in these categories behave exactly as for `Type`-valued presheaves.
For example, in `germ_exist` we prove that in such a category, every element of the stalk is the
germ of a section.

Furthermore, if we require the forgetful functor to reflect isomorphisms and preserve limits (as
is the case for most algebraic structures), we have access to the unique gluing API and can prove
further properties. Most notably, in `is_iso_iff_stalk_functor_map_iso`, we prove that in such
a category, a morphism of sheaves is an isomorphism if and only if all of its stalk maps are
isomorphisms.

See also the definition of "algebraic structures" in the stacks project:
https://stacks.math.columbia.edu/tag/007L

-/

noncomputable theory

universes v u v' u'

open category_theory
open Top
open category_theory.limits
open topological_space
open opposite

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

variables [has_colimits.{v} C]

variables {X Y Z : Top.{v}}

namespace Top.presheaf

variables (C)
/-- Stalks are functorial with respect to morphisms of presheaves over a fixed `X`. -/
def stalk_functor (x : X) : X.presheaf C ⥤ C :=
((whiskering_left _ _ C).obj (open_nhds.inclusion x).op) ⋙ colim

variables {C}

/--
The stalk of a presheaf `F` at a point `x` is calculated as the colimit of the functor
nbhds x ⥤ opens F.X ⥤ C
-/
def stalk (ℱ : X.presheaf C) (x : X) : C :=
(stalk_functor C x).obj ℱ -- -- colimit ((open_nhds.inclusion x).op ⋙ ℱ)

@[simp] lemma stalk_functor_obj (ℱ : X.presheaf C) (x : X) :
  (stalk_functor C x).obj ℱ = ℱ.stalk x := rfl

/--
The germ of a section of a presheaf over an open at a point of that open.
-/
def germ (F : X.presheaf C) {U : opens X} (x : U) : F.obj (op U) ⟶ stalk F x :=
colimit.ι ((open_nhds.inclusion x.1).op ⋙ F) (op ⟨U, x.2⟩)

@[simp, elementwise]
lemma germ_res (F : X.presheaf C) {U V : opens X} (i : U ⟶ V) (x : U) :
  F.map i.op ≫ germ F x = germ F (i x : V) :=
let i' : (⟨U, x.2⟩ : open_nhds x.1) ⟶ ⟨V, (i x : V).2⟩ := i in
colimit.w ((open_nhds.inclusion x.1).op ⋙ F) i'.op

/--
A morphism from the stalk of `F` at `x` to some object `Y` is completely determined by its
composition with the `germ` morphisms.
-/
lemma stalk_hom_ext (F : X.presheaf C) {x} {Y : C} {f₁ f₂ : F.stalk x ⟶ Y}
  (ih : ∀ (U : opens X) (hxU : x ∈ U), F.germ ⟨x, hxU⟩ ≫ f₁ = F.germ ⟨x, hxU⟩ ≫ f₂) : f₁ = f₂ :=
colimit.hom_ext $ λ U, by { induction U using opposite.rec, cases U with U hxU, exact ih U hxU }

@[simp, reassoc, elementwise]
lemma stalk_functor_map_germ {F G : X.presheaf C} (U : opens X) (x : U)
  (f : F ⟶ G) : germ F x ≫ (stalk_functor C x.1).map f = f.app (op U) ≫ germ G x :=
colimit.ι_map (whisker_left ((open_nhds.inclusion x.1).op) f) (op ⟨U, x.2⟩)

variables (C)

/--
For a presheaf `F` on a space `X`, a continuous map `f : X ⟶ Y` induces a morphisms between the
stalk of `f _ * F` at `f x` and the stalk of `F` at `x`.
-/
def stalk_pushforward (f : X ⟶ Y) (F : X.presheaf C) (x : X) : (f _* F).stalk (f x) ⟶ F.stalk x :=
begin
  -- This is a hack; Lean doesn't like to elaborate the term written directly.
  transitivity,
  swap,
  exact colimit.pre _ (open_nhds.map f x).op,
  exact colim.map (whisker_right (nat_trans.op (open_nhds.inclusion_map_iso f x).inv) F),
end

@[simp, elementwise, reassoc]
lemma stalk_pushforward_germ (f : X ⟶ Y) (F : X.presheaf C) (U : opens Y)
  (x : (opens.map f).obj U) :
  (f _* F).germ ⟨f x, x.2⟩ ≫ F.stalk_pushforward C f x = F.germ x :=
begin
  rw [stalk_pushforward, germ, colimit.ι_map_assoc, colimit.ι_pre, whisker_right_app],
  erw [category_theory.functor.map_id, category.id_comp],
  refl,
end

-- Here are two other potential solutions, suggested by @fpvandoorn at
-- <https://github.com/leanprover-community/mathlib/pull/1018#discussion_r283978240>
-- However, I can't get the subsequent two proofs to work with either one.

-- def stalk_pushforward (f : X ⟶ Y) (ℱ : X.presheaf C) (x : X) :
--   (f _* ℱ).stalk (f x) ⟶ ℱ.stalk x :=
-- colim.map ((functor.associator _ _ _).inv ≫
--   whisker_right (nat_trans.op (open_nhds.inclusion_map_iso f x).inv) ℱ) ≫
-- colimit.pre ((open_nhds.inclusion x).op ⋙ ℱ) (open_nhds.map f x).op

-- def stalk_pushforward (f : X ⟶ Y) (ℱ : X.presheaf C) (x : X) :
--   (f _* ℱ).stalk (f x) ⟶ ℱ.stalk x :=
-- (colim.map (whisker_right (nat_trans.op (open_nhds.inclusion_map_iso f x).inv) ℱ) :
--   colim.obj ((open_nhds.inclusion (f x) ⋙ opens.map f).op ⋙ ℱ) ⟶ _) ≫
-- colimit.pre ((open_nhds.inclusion x).op ⋙ ℱ) (open_nhds.map f x).op

namespace stalk_pushforward
local attribute [tidy] tactic.op_induction'

@[simp] lemma id (ℱ : X.presheaf C) (x : X) :
  ℱ.stalk_pushforward C (𝟙 X) x = (stalk_functor C x).map ((pushforward.id ℱ).hom) :=
begin
  dsimp [stalk_pushforward, stalk_functor],
  ext1,
  tactic.op_induction',
  cases j, cases j_val,
  rw [colimit.ι_map_assoc, colimit.ι_map, colimit.ι_pre, whisker_left_app, whisker_right_app,
       pushforward.id_hom_app, eq_to_hom_map, eq_to_hom_refl],
  dsimp,
  -- FIXME A simp lemma which unfortunately doesn't fire:
  erw [category_theory.functor.map_id],
end

-- This proof is sadly not at all robust:
-- having to use `erw` at all is a bad sign.
@[simp] lemma comp (ℱ : X.presheaf C) (f : X ⟶ Y) (g : Y ⟶ Z) (x : X) :
  ℱ.stalk_pushforward C (f ≫ g) x =
  ((f _* ℱ).stalk_pushforward C g (f x)) ≫ (ℱ.stalk_pushforward C f x) :=
begin
  dsimp [stalk_pushforward, stalk_functor],
  ext U,
  induction U using opposite.rec,
  cases U,
  cases U_val,
  simp only [colimit.ι_map_assoc, colimit.ι_pre_assoc,
             whisker_right_app, category.assoc],
  dsimp,
  -- FIXME: Some of these are simp lemmas, but don't fire successfully:
  erw [category_theory.functor.map_id, category.id_comp, category.id_comp, category.id_comp,
       colimit.ι_pre, colimit.ι_pre],
  refl,
end

lemma stalk_pushforward_iso_of_open_embedding {f : X ⟶ Y} (hf : open_embedding f)
   (F : X.presheaf C) (x : X) : is_iso (F.stalk_pushforward _ f x) :=
 begin
   haveI := functor.initial_of_adjunction (hf.is_open_map.adjunction_nhds x),
   convert is_iso.of_iso ((functor.final.colimit_iso (hf.is_open_map.functor_nhds x).op
     ((open_nhds.inclusion (f x)).op ⋙ f _* F) : _).symm ≪≫ colim.map_iso _),
   swap,
   { fapply nat_iso.of_components,
     { intro U,
       refine F.map_iso (eq_to_iso _),
       dsimp only [functor.op],
       exact congr_arg op (subtype.eq $ set.preimage_image_eq (unop U).1.1 hf.inj) },
     { intros U V i, erw [← F.map_comp, ← F.map_comp], congr } },
   { ext U,
     rw ← iso.comp_inv_eq,
     erw colimit.ι_map_assoc,
     rw [colimit.ι_pre, category.assoc],
     erw [colimit.ι_map_assoc, colimit.ι_pre, ← F.map_comp_assoc],
     apply colimit.w ((open_nhds.inclusion (f x)).op ⋙ f _* F) _,
     dsimp only [functor.op],
     refine ((hom_of_le _).op : op (unop U) ⟶ _),
     exact set.image_preimage_subset _ _ },
 end

end stalk_pushforward

section stalk_pullback

/-- The morphism `ℱ_{f x} ⟶ (f⁻¹ℱ)ₓ` that factors through `(f_*f⁻¹ℱ)_{f x}`. -/
def stalk_pullback_hom (f : X ⟶ Y) (F : Y.presheaf C) (x : X) :
  F.stalk (f x) ⟶ (pullback_obj f F).stalk x :=
(stalk_functor _ (f x)).map ((pushforward_pullback_adjunction C f).unit.app F) ≫
  stalk_pushforward _ _ _ x

/-- The morphism `(f⁻¹ℱ)(U) ⟶ ℱ_{f(x)}` for some `U ∋ x`. -/
def germ_to_pullback_stalk (f : X ⟶ Y) (F : Y.presheaf C) (U : opens X) (x : U) :
  (pullback_obj f F).obj (op U) ⟶ F.stalk (f x) :=
colimit.desc (Lan.diagram (opens.map f).op F (op U))
{ X := F.stalk (f x),
  ι := { app := λ V, F.germ ⟨f x, V.hom.unop.le x.2⟩,
          naturality' := λ _ _ i, by { erw category.comp_id, exact F.germ_res i.left.unop _ } } }

/-- The morphism `(f⁻¹ℱ)ₓ ⟶ ℱ_{f(x)}`. -/
def stalk_pullback_inv (f : X ⟶ Y) (F : Y.presheaf C) (x : X) :
  (pullback_obj f F).stalk x ⟶ F.stalk (f x) :=
colimit.desc ((open_nhds.inclusion x).op ⋙ presheaf.pullback_obj f F)
{ X := F.stalk (f x),
  ι := { app := λ U, F.germ_to_pullback_stalk _ f (unop U).1 ⟨x, (unop U).2⟩,
          naturality' := λ _ _ _, by { erw [colimit.pre_desc, category.comp_id], congr } } }

/-- The isomorphism `ℱ_{f(x)} ≅ (f⁻¹ℱ)ₓ`. -/
def stalk_pullback_iso (f : X ⟶ Y) (F : Y.presheaf C) (x : X) :
  F.stalk (f x) ≅ (pullback_obj f F).stalk x :=
{ hom := stalk_pullback_hom _ _ _ _,
  inv := stalk_pullback_inv _ _ _ _,
  hom_inv_id' :=
  begin
    delta stalk_pullback_hom stalk_pullback_inv stalk_functor presheaf.pullback stalk_pushforward
      germ_to_pullback_stalk germ,
    ext j,
    induction j using opposite.rec,
    cases j,
    simp only [topological_space.open_nhds.inclusion_map_iso_inv, whisker_right_app,
      whisker_left_app, whiskering_left_obj_map, functor.comp_map, colimit.ι_map_assoc,
      nat_trans.op_id, Lan_obj_map, pushforward_pullback_adjunction_unit_app_app, category.assoc,
      colimit.ι_pre_assoc],
    erw [colimit.ι_desc, colimit.pre_desc, colimit.ι_desc, category.comp_id],
    simpa
  end,
  inv_hom_id' :=
  begin
    delta stalk_pullback_hom stalk_pullback_inv stalk_functor presheaf.pullback stalk_pushforward,
    ext U j,
    induction U using opposite.rec,
    cases U, cases j, cases j_right,
    erw [colimit.map_desc, colimit.map_desc, colimit.ι_desc_assoc,
      colimit.ι_desc_assoc, colimit.ι_desc, category.comp_id],
    simp only [cocone.whisker_ι, colimit.cocone_ι, open_nhds.inclusion_map_iso_inv,
      cocones.precompose_obj_ι, whisker_right_app, whisker_left_app, nat_trans.comp_app,
      whiskering_left_obj_map, nat_trans.op_id, Lan_obj_map,
      pushforward_pullback_adjunction_unit_app_app],
    erw ←colimit.w _
      (@hom_of_le (open_nhds x) _
         ⟨_, U_property⟩ ⟨(opens.map f).obj (unop j_left), j_hom.unop.le U_property⟩
         j_hom.unop.le).op,
    erw colimit.ι_pre_assoc (Lan.diagram _ F _) (costructured_arrow.map _),
    erw colimit.ι_pre_assoc (Lan.diagram _ F _) (costructured_arrow.map _),
    congr,
    simp only [category.assoc, costructured_arrow.map_mk],
    delta costructured_arrow.mk,
    congr
  end }

end stalk_pullback

section stalk_specializes

variables {C}

/-- If `x` specializes to `y`, then there is a natural map `F.stalk y ⟶ F.stalk x`. -/
noncomputable
def stalk_specializes (F : X.presheaf C) {x y : X} (h : x ⤳ y) : F.stalk y ⟶ F.stalk x :=
begin
  refine colimit.desc _ ⟨_,λ U, _,_⟩,
  { exact colimit.ι ((open_nhds.inclusion x).op ⋙ F)
      (op ⟨(unop U).1, (specializes_iff_forall_open.mp h _ (unop U).1.2 (unop U).2 : _)⟩) },
  { intros U V i,
    dsimp,
    rw category.comp_id,
    let U' : open_nhds x := ⟨_, (specializes_iff_forall_open.mp h _ (unop U).1.2 (unop U).2 : _)⟩,
    let V' : open_nhds x := ⟨_, (specializes_iff_forall_open.mp h _ (unop V).1.2 (unop V).2 : _)⟩,
    exact colimit.w ((open_nhds.inclusion x).op ⋙ F) (show V' ⟶ U', from i.unop).op }
end

@[simp, reassoc, elementwise]
lemma germ_stalk_specializes (F : X.presheaf C) {U : opens X} {y : U} {x : X} (h : x ⤳ y) :
  F.germ y ≫ F.stalk_specializes h =
    F.germ ⟨x, specializes_iff_forall_open.mp h _ U.2 y.prop⟩ := colimit.ι_desc _ _

@[simp, reassoc, elementwise]
lemma germ_stalk_specializes' (F : X.presheaf C) {U : opens X} {x y : X} (h : x ⤳ y) (hy : y ∈ U) :
  F.germ ⟨y, hy⟩ ≫ F.stalk_specializes h =
    F.germ ⟨x, specializes_iff_forall_open.mp h _ U.2 hy⟩ := colimit.ι_desc _ _

@[simp, reassoc, elementwise]
lemma stalk_specializes_stalk_functor_map {F G : X.presheaf C} (f : F ⟶ G) {x y : X} (h : x ⤳ y) :
  F.stalk_specializes h ≫ (stalk_functor C x).map f =
    (stalk_functor C y).map f ≫ G.stalk_specializes h :=
by { ext, delta stalk_functor, simpa [stalk_specializes] }

@[simp, reassoc, elementwise]
lemma stalk_specializes_stalk_pushforward (f : X ⟶ Y) (F : X.presheaf C) {x y : X} (h : x ⤳ y) :
  (f _* F).stalk_specializes (f.map_specialization h) ≫ F.stalk_pushforward _ f x =
    F.stalk_pushforward _ f y ≫ F.stalk_specializes h :=
by { ext, delta stalk_pushforward, simpa [stalk_specializes] }

end stalk_specializes

section concrete

variables {C}
variables [concrete_category.{v} C]

local attribute [instance] concrete_category.has_coe_to_sort concrete_category.has_coe_to_fun

@[ext]
lemma germ_ext (F : X.presheaf C) {U V : opens X} {x : X} {hxU : x ∈ U} {hxV : x ∈ V}
  (W : opens X) (hxW : x ∈ W) (iWU : W ⟶ U) (iWV : W ⟶ V) {sU : F.obj (op U)} {sV : F.obj (op V)}
  (ih : F.map iWU.op sU = F.map iWV.op sV) :
  F.germ ⟨x, hxU⟩ sU = F.germ ⟨x, hxV⟩ sV :=
by erw [← F.germ_res iWU ⟨x, hxW⟩,
    ← F.germ_res iWV ⟨x, hxW⟩, comp_apply, comp_apply, ih]

variables [preserves_filtered_colimits (forget C)]

/--
For presheaves valued in a concrete category whose forgetful functor preserves filtered colimits,
every element of the stalk is the germ of a section.
-/
lemma germ_exist (F : X.presheaf C) (x : X) (t : stalk F x) :
  ∃ (U : opens X) (m : x ∈ U) (s : F.obj (op U)), F.germ ⟨x, m⟩ s = t :=
begin
  obtain ⟨U, s, e⟩ := types.jointly_surjective _
    (is_colimit_of_preserves (forget C) (colimit.is_colimit _)) t,
  revert s e,
  rw [(show U = op (unop U), from rfl)],
  generalize : unop U = V, clear U,
  cases V with V m,
  intros s e,
  exact ⟨V, m, s, e⟩,
end

lemma germ_eq (F : X.presheaf C) {U V : opens X} (x : X) (mU : x ∈ U) (mV : x ∈ V)
  (s : F.obj (op U)) (t : F.obj (op V))
  (h : germ F ⟨x, mU⟩ s = germ F ⟨x, mV⟩ t) :
  ∃ (W : opens X) (m : x ∈ W) (iU : W ⟶ U) (iV : W ⟶ V), F.map iU.op s = F.map iV.op t :=
begin
  obtain ⟨W, iU, iV, e⟩ := (types.filtered_colimit.is_colimit_eq_iff _
    (is_colimit_of_preserves _ (colimit.is_colimit ((open_nhds.inclusion x).op ⋙ F)))).mp h,
  exact ⟨(unop W).1, (unop W).2, iU.unop, iV.unop, e⟩,
end

lemma stalk_functor_map_injective_of_app_injective {F G : presheaf C X} (f : F ⟶ G)
  (h : ∀ U : opens X, function.injective (f.app (op U))) (x : X) :
  function.injective ((stalk_functor C x).map f) := λ s t hst,
begin
  rcases germ_exist F x s with ⟨U₁, hxU₁, s, rfl⟩,
  rcases germ_exist F x t with ⟨U₂, hxU₂, t, rfl⟩,
  simp only [stalk_functor_map_germ_apply _ ⟨x,_⟩] at hst,
  obtain ⟨W, hxW, iWU₁, iWU₂, heq⟩ := G.germ_eq x hxU₁ hxU₂ _ _ hst,
  rw [← comp_apply, ← comp_apply, ← f.naturality, ← f.naturality, comp_apply, comp_apply] at heq,
  replace heq := h W heq,
  convert congr_arg (F.germ ⟨x,hxW⟩) heq,
  exacts [(F.germ_res_apply iWU₁ ⟨x,hxW⟩ s).symm,
          (F.germ_res_apply iWU₂ ⟨x,hxW⟩ t).symm],
end

variables [has_limits C] [preserves_limits (forget C)] [reflects_isomorphisms (forget C)]

/--
Let `F` be a sheaf valued in a concrete category, whose forgetful functor reflects isomorphisms,
preserves limits and filtered colimits. Then two sections who agree on every stalk must be equal.
-/
lemma section_ext (F : sheaf C X) (U : opens X) (s t : F.1.obj (op U))
  (h : ∀ x : U, F.1.germ x s = F.1.germ x t) :
  s = t :=
begin
  -- We use `germ_eq` and the axiom of choice, to pick for every point `x` a neighbourhood
  -- `V x`, such that the restrictions of `s` and `t` to `V x` coincide.
  choose V m i₁ i₂ heq using λ x : U, F.1.germ_eq x.1 x.2 x.2 s t (h x),
  -- Since `F` is a sheaf, we can prove the equality locally, if we can show that these
  -- neighborhoods form a cover of `U`.
  apply F.eq_of_locally_eq' V U i₁,
  { intros x hxU,
    rw [opens.mem_coe, opens.mem_supr],
    exact ⟨⟨x, hxU⟩, m ⟨x, hxU⟩⟩ },
  { intro x,
    rw [heq, subsingleton.elim (i₁ x) (i₂ x)] }
end

/-
Note that the analogous statement for surjectivity is false: Surjectivity on stalks does not
imply surjectivity of the components of a sheaf morphism. However it does imply that the morphism
is an epi, but this fact is not yet formalized.
-/
lemma app_injective_of_stalk_functor_map_injective {F : sheaf C X} {G : presheaf C X}
  (f : F.1 ⟶ G) (U : opens X) (h : ∀ x : U, function.injective ((stalk_functor C x.val).map f)) :
  function.injective (f.app (op U)) :=
λ s t hst, section_ext F _ _ _ $ λ x, h x $ by
  rw [stalk_functor_map_germ_apply, stalk_functor_map_germ_apply, hst]

lemma app_injective_iff_stalk_functor_map_injective {F : sheaf C X}
  {G : presheaf C X} (f : F.1 ⟶ G) :
  (∀ x : X, function.injective ((stalk_functor C x).map f)) ↔
  (∀ U : opens X, function.injective (f.app (op U))) :=
⟨λ h U, app_injective_of_stalk_functor_map_injective f U (λ x, h x.1),
  stalk_functor_map_injective_of_app_injective f⟩

/-- For surjectivity, we are given an arbitrary section `t` and need to find a preimage for it.
We claim that it suffices to find preimages *locally*. That is, for each `x : U` we construct
a neighborhood `V ≤ U` and a section `s : F.obj (op V))` such that `f.app (op V) s` and `t`
agree on `V`. -/
lemma app_surjective_of_injective_of_locally_surjective {F G : sheaf C X} (f : F ⟶ G)
  (U : opens X) (hinj : ∀ x : U, function.injective ((stalk_functor C x.1).map f))
  (hsurj : ∀ (t) (x : U), ∃ (V : opens X) (m : x.1 ∈ V) (iVU : V ⟶ U) (s : F.1.obj (op V)),
    f.app (op V) s = G.1.map iVU.op t) :
  function.surjective (f.app (op U)) :=
begin
  intro t,
  -- We use the axiom of choice to pick around each point `x` an open neighborhood `V` and a
  -- preimage under `f` on `V`.
  choose V mV iVU sf heq using hsurj t,
  -- These neighborhoods clearly cover all of `U`.
  have V_cover : U ≤ supr V,
  { intros x hxU,
    rw [opens.mem_coe, opens.mem_supr],
    exact ⟨⟨x, hxU⟩, mV ⟨x, hxU⟩⟩ },
  -- Since `F` is a sheaf, we can glue all the local preimages together to get a global preimage.
  obtain ⟨s, s_spec, -⟩ := F.exists_unique_gluing' V U iVU V_cover sf _,
  { use s,
    apply G.eq_of_locally_eq' V U iVU V_cover,
    intro x,
    rw [← comp_apply, ← f.naturality, comp_apply, s_spec, heq] },
  { intros x y,
    -- What's left to show here is that the secions `sf` are compatible, i.e. they agree on
    -- the intersections `V x ⊓ V y`. We prove this by showing that all germs are equal.
    apply section_ext,
    intro z,
    -- Here, we need to use injectivity of the stalk maps.
    apply (hinj ⟨z, (iVU x).le ((inf_le_left : V x ⊓ V y ≤ V x) z.2)⟩),
    dsimp only,
    erw [stalk_functor_map_germ_apply, stalk_functor_map_germ_apply],
    simp_rw [← comp_apply, f.naturality, comp_apply, heq, ← comp_apply, ← G.1.map_comp],
    refl }
end

lemma app_surjective_of_stalk_functor_map_bijective {F G : sheaf C X} (f : F ⟶ G)
  (U : opens X) (h : ∀ x : U, function.bijective ((stalk_functor C x.val).map f)) :
  function.surjective (f.app (op U)) :=
begin
  refine app_surjective_of_injective_of_locally_surjective f U (λ x, (h x).1) (λ t x, _),
  -- Now we need to prove our initial claim: That we can find preimages of `t` locally.
  -- Since `f` is surjective on stalks, we can find a preimage `s₀` of the germ of `t` at `x`
  obtain ⟨s₀,hs₀⟩ := (h x).2 (G.1.germ x t),
  -- ... and this preimage must come from some section `s₁` defined on some open neighborhood `V₁`
  obtain ⟨V₁,hxV₁,s₁,hs₁⟩ := F.1.germ_exist x.1 s₀,
  subst hs₁, rename hs₀ hs₁,
  erw stalk_functor_map_germ_apply V₁ ⟨x.1,hxV₁⟩ f s₁ at hs₁,
  -- Now, the germ of `f.app (op V₁) s₁` equals the germ of `t`, hence they must coincide on
  -- some open neighborhood `V₂`.
  obtain ⟨V₂, hxV₂, iV₂V₁, iV₂U, heq⟩ := G.1.germ_eq x.1 hxV₁ x.2 _ _ hs₁,
  -- The restriction of `s₁` to that neighborhood is our desired local preimage.
  use [V₂, hxV₂, iV₂U, F.1.map iV₂V₁.op s₁],
  rw [← comp_apply, f.naturality, comp_apply, heq],
end

lemma app_bijective_of_stalk_functor_map_bijective {F G : sheaf C X} (f : F ⟶ G)
   (U : opens X) (h : ∀ x : U, function.bijective ((stalk_functor C x.val).map f)) :
  function.bijective (f.app (op U)) :=
⟨app_injective_of_stalk_functor_map_injective f U (λ x, (h x).1),
  app_surjective_of_stalk_functor_map_bijective f U h⟩

lemma app_is_iso_of_stalk_functor_map_iso {F G : sheaf C X} (f : F ⟶ G) (U : opens X)
  [∀ x : U, is_iso ((stalk_functor C x.val).map f)] : is_iso (f.app (op U)) :=
begin
  -- Since the forgetful functor of `C` reflects isomorphisms, it suffices to see that the
  -- underlying map between types is an isomorphism, i.e. bijective.
  suffices : is_iso ((forget C).map (f.app (op U))),
  { exactI is_iso_of_reflects_iso (f.app (op U)) (forget C) },
  rw is_iso_iff_bijective,
  apply app_bijective_of_stalk_functor_map_bijective,
  intro x,
  apply (is_iso_iff_bijective _).mp,
  exact functor.map_is_iso (forget C) ((stalk_functor C x.1).map f)
end

/--
Let `F` and `G` be sheaves valued in a concrete category, whose forgetful functor reflects
isomorphisms, preserves limits and filtered colimits. Then if the stalk maps of a morphism
`f : F ⟶ G` are all isomorphisms, `f` must be an isomorphism.
-/
-- Making this an instance would cause a loop in typeclass resolution with `functor.map_is_iso`
lemma is_iso_of_stalk_functor_map_iso {F G : sheaf C X} (f : F ⟶ G)
  [∀ x : X, is_iso ((stalk_functor C x).map f)] : is_iso f :=
begin
  -- Since the inclusion functor from sheaves to presheaves is fully faithful, it suffices to
  -- show that `f`, as a morphism between _presheaves_, is an isomorphism.
  suffices : is_iso ((sheaf.forget C X).map f),
  { exactI is_iso_of_fully_faithful (sheaf.forget C X) f },
  -- We show that all components of `f` are isomorphisms.
  suffices : ∀ U : (opens X)ᵒᵖ, is_iso (f.app U),
  { exact @nat_iso.is_iso_of_is_iso_app _ _ _ _ F.1 G.1 f this, },
  intro U, induction U using opposite.rec,
  apply app_is_iso_of_stalk_functor_map_iso
end

/--
Let `F` and `G` be sheaves valued in a concrete category, whose forgetful functor reflects
isomorphisms, preserves limits and filtered colimits. Then a morphism `f : F ⟶ G` is an
isomorphism if and only if all of its stalk maps are isomorphisms.
-/
lemma is_iso_iff_stalk_functor_map_iso {F G : sheaf C X} (f : F ⟶ G) :
  is_iso f ↔ ∀ x : X, is_iso ((stalk_functor C x).map f) :=
begin
  split,
  { intros h x, resetI,
    exact @functor.map_is_iso _ _ _ _ _ _ (stalk_functor C x) f
      ((sheaf.forget C X).map_is_iso f) },
  { intro h,
    exactI is_iso_of_stalk_functor_map_iso f }
end

end concrete

instance (F : X.presheaf CommRing) {U : opens X} (x : U) :
  algebra (F.obj $ op U) (F.stalk x) :=
(F.germ x).to_algebra

@[simp]
lemma stalk_open_algebra_map {X : Top} (F : X.presheaf CommRing) {U : opens X} (x : U) :
  algebra_map (F.obj $ op U) (F.stalk x) = F.germ x := rfl

end Top.presheaf


import data.mv_polynomial ring_theory.ideal_operations ring_theory.adjoin_root
import ring_theory.integral_closure

namespace adjoin_root
variables {α : Type*} [comm_ring α] {f : polynomial α}
open polynomial ideal

lemma coe_injective_of_degree_pos_of_monic (hf : 0 < degree f) (hm : monic f) :
  function.injective (coe : α → adjoin_root f) :=
λ x y hxy,
begin
  rcases mem_span_singleton.1 (ideal.quotient.eq.1 hxy) with ⟨g, hg⟩,
  classical,
  by_cases hg0 : g = 0,
  { rwa [hg0, mul_zero, sub_eq_zero, C_inj] at hg },
  { have hlc : leading_coeff f * leading_coeff g ≠ 0,
    { rwa [monic.def.1 hm, one_mul, ne.def, leading_coeff_eq_zero] },
    exact false.elim (not_le_of_gt hf $
      calc degree f = nat_degree f : degree_eq_nat_degree (λ hf0, by simp * at *)
      ... ≤ nat_degree f + nat_degree g : with_bot.coe_le_coe.2 (nat.le_add_right _ _)
      ... = 0 : by rw [← with_bot.coe_add, ← nat_degree_mul_eq' hlc, ← hg, ← C_sub, nat_degree_C,
        with_bot.coe_zero]) }
end
end adjoin_root
#print ideal.leading_coeff
namespace ideal
variables {R : Type*} [comm_ring R]

@[simp] lemma span_empty : (span ∅ : ideal R) = ⊥ :=
submodule.span_empty

lemma quotient.mk_eq_zero {I : ideal R} {x : R} : ideal.quotient.mk I x = 0 ↔ x ∈ I :=
submodule.quotient.mk_eq_zero _

lemma ext_iff {I J : ideal R} : I = J ↔ (∀ x, x ∈ I ↔ x ∈ J) :=
⟨λ h _, h ▸ iff.rfl, ideal.ext⟩

end ideal

namespace mv_polynomial

lemma C_inj {R σ : Type*} [comm_semiring R] {x y : R} : (C x : mv_polynomial σ R) = C y ↔ x = y :=
sorry

noncomputable instance {R σ : Type*} [nonzero_comm_semiring R] :
  nonzero_comm_semiring (mv_polynomial σ R) :=
{ zero_ne_one := sorry,
  ..show comm_semiring (mv_polynomial σ R), by apply_instance }

end mv_polynomial

namespace polynomial

open ideal set
open_locale classical
end polynomial

open mv_polynomial ideal
universes u v
variables (K : Type u) [discrete_field K]
noncomputable theory

section name
variables {α : Type*} {β : Type*} {σ : Type*} [comm_ring α] [comm_ring β]

def mname (i : σ) (p : polynomial α) : mv_polynomial σ α :=
p.eval₂ C (X i)

@[simp] lemma mname_one (i : σ)  :
  mname i (1 : polynomial α) = 1 :=
by simp [mname]

@[simp] lemma mname_zero (i : σ)  :
  mname i (0 : polynomial α) = 0 :=
by simp [mname]

@[simp] lemma mname_add (i : σ) (p q : polynomial α) :
  mname i (p + q) =  mname i p + mname i q :=
by simp [mname]

@[simp] lemma mname_mul (i : σ) (p q : polynomial α) :
  mname i (p * q) =  mname i p * mname i q :=
by simp [mname]

@[simp] lemma mname_pow (i : σ) (p : polynomial α) (n : ℕ) :
  mname i (p ^ n) =  mname i p ^ n :=
by induction n; simp [pow_succ, *]

@[simp] lemma mname_sub (i : σ) (p q : polynomial α) :
  mname i (p - q) =  mname i p - mname i q :=
by simp [mname]

@[simp] lemma mname_neg (i : σ) (p : polynomial α) :
  mname i (-p) = -mname i p :=
by simp [mname]

@[simp] lemma mname_C (i : σ) (a : α) :
  mname i (polynomial.C a) = C a :=
by simp [mname]

@[simp] lemma mname_X (i : σ) :
  mname i (polynomial.X : polynomial α) = X i :=
by simp [mname]

@[simp] lemma eval₂_mname (i : σ) (f : α → β) [is_semiring_hom f] (s : σ → β) (p : polynomial α) :
  eval₂ f s (mname i p) = polynomial.eval₂ f (s i) p :=
polynomial.induction_on p
  (λ a, by simp)
  (by simp {contextual := tt})
  (by simp [pow_succ', (mul_assoc _ _ _).symm] {contextual := tt})

end name

@[reducible] def posd : Type u := {p : polynomial K // 0 < p.degree ∧ p.monic}

@[reducible] def pac : Type u :=
mv_polynomial (posd K) K

variable {K}

namespace pac
variable (K)
def relt (s : set (posd K)) : set (pac K) :=
(λ p : posd K, p.1.eval₂ C (X p)) '' s

end pac
open pac

set_option class.instance_max_depth 50

@[instance, priority 100000] instance :
  comm_ring (pac K) := mv_polynomial.comm_ring

def F1 (s : set (posd K)) : K →+* ideal.quotient (span (relt K s)) :=
(ring_hom.of (ideal.quotient.mk (span (relt K s)))).comp (ring_hom.of (C : K → pac K))

def F2 (s : set (posd K)) (p : posd K) : K →+* adjoin_root (p.1.map (F1 s)) :=
(ring_hom.of coe).comp $ (ring_hom.of $ ideal.quotient.mk (span (relt K s))).comp $
  ring_hom.of (C : K → pac K)

open_locale classical

lemma isom2 (s : set (posd K)) (p : posd K) (hps : p ∉ s) :
  ideal.quotient (span (relt K (insert p s))) →+* adjoin_root (p.1.map (F1 s)) :=
ring_hom.of $ ideal.quotient.lift _
  (eval₂ (F2 s p) (λ q, if q ∈ s
    then (↑(ideal.quotient.mk (span (relt K s)) (X q : pac K)) : adjoin_root _)
      else if q = p then adjoin_root.root
      else 0))
  begin
    assume x hx,
    refine submodule.span_induction hx _ (by simp) (by simp {contextual := tt})
      (by simp {contextual := tt}),
    assume x hx,
    rcases hx with ⟨q, hq, rfl⟩,
    { rcases hq with rfl | hq,
      { dsimp only [F2, F1],
        rw [← mname, ← adjoin_root.eval₂_root, eval₂_mname, if_pos rfl,
          if_neg hps, polynomial.eval₂_map],
        refl },
      { dsimp only,
        have : ideal.quotient.mk (span (relt K s)) (mname q q) = 0,
        { rw [ideal.quotient.mk_eq_zero],
          exact subset_span (set.mem_image_of_mem _ hq) },
        erw [← mname, eval₂_mname, if_pos hq,
          ← is_ring_hom.map_zero (coe : ideal.quotient (span (relt K s)) →
            adjoin_root (p.1.map (F1 s))), ← this, mname, F2],
        exact eq.symm (polynomial.hom_eval₂ (q : polynomial K) _
          (ring_hom.comp (ring_hom.of (coe : ideal.quotient (span (relt K s)) →
            adjoin_root (p.1.map (F1 s))))
          (ring_hom.of (ideal.quotient.mk (span (relt K s))))) (X q)) } }
  end

open polynomial

lemma map1 (s : set (posd K)) (p : posd K)
  (h01' : (0 :  ideal.quotient (span (relt K s))) ≠ 1) :
  (0 : adjoin_root (p.1.map (F1 s))) ≠ 1 :=
λ h01,
  by rw [← is_ring_hom.map_zero (coe : ideal.quotient (span (relt K s)) →
    adjoin_root (p.1.map (F1 s))),
   ← is_ring_hom.map_one (coe : ideal.quotient (span (relt K s)) →
    adjoin_root (p.1.map (F1 s)))] at h01; exact
h01' (adjoin_root.coe_injective_of_degree_pos_of_monic
  begin
    refine lt_of_not_ge' _,
    rw [degree_le_zero_iff],
    assume h,
    have : (p.1.map (F1 s)).coeff p.1.nat_degree =
      (polynomial.C ((p.1.map (F1 s)).coeff 0)).coeff p.1.nat_degree, { rw ← h },
    have h0 : nat_degree p.1 ≠ 0,
    { rw [← nat.pos_iff_ne_zero, ← with_bot.coe_lt_coe],
      exact lt_of_lt_of_le p.2.1 degree_le_nat_degree },
    rw [polynomial.coeff_C, polynomial.coeff_map, ← polynomial.leading_coeff,
      monic.def.1 p.2.2, ring_hom.map_one, if_neg h0] at this,
    exact h01'.symm this
  end
  (monic_map _ p.2.2)
  h01).

lemma ne_top_aux (s : finset (posd K)) : span (relt K ↑s) ≠ ⊤ :=
finset.induction_on s
  (by simp [ne_top_iff_one, relt, ideal.ext_iff, classical.not_forall]; exact ⟨1, by simp⟩)
  (λ p s hps ih,
    have (0 : ideal.quotient (span (relt K ↑s))) ≠ 1,
      from ne.symm $ mt (ideal.quotient.mk_eq_zero).1 ((ne_top_iff_one _).1 ih),
    have (0 :  adjoin_root (p.1.map (F1 (↑s : set (posd K))))) ≠ 1,
      from map1 ↑s p this,
    have (0 : ideal.quotient (span (relt K (insert p ↑s)))) ≠ 1,
      from λ h, this $ by rw [← ring_hom.map_zero (isom2 ↑s p hps), h, ring_hom.map_one],
    by rw [finset.coe_insert, ne_top_iff_one, ← ideal.quotient.mk_eq_zero, eq_comm];
      exact this)

lemma ne_top : span (relt K ⊤) ≠ ⊤ :=
(ne_top_iff_one _).2 $ λ h : 1 ∈ span (relt K ⊤),
have hs : ∃ s : finset (posd K), (1 : pac K) ∈ span (relt K ↑s),
  from submodule.span_induction h
    (by rintros x ⟨p, hp, rfl⟩; exact ⟨{p}, subset_span (by simp [relt])⟩)
    ⟨∅, by simp⟩
    (by rintros x y ⟨s, hs⟩ ⟨t, ht⟩;
      exact ⟨s ∪ t, ideal.add_mem _ (span_mono (by simp [relt, set.image_union]) hs)
                                    (span_mono (by simp [relt, set.image_union]) ht)⟩)
    (by rintros a x ⟨s, hs⟩; exact ⟨s, ideal.mul_mem_left _ hs⟩),
by cases hs with s hs;
  exact ne_top_aux s ((not_iff_not.1 (ne_top_iff_one _)).2 hs)

variable (K)
def big_ideal : ideal (pac K) :=
classical.some (exists_le_maximal (span (relt K ⊤)) ne_top)

def K1 : Type u :=
ideal.quotient (@big_ideal K _)

instance : discrete_field (K1 K) :=
@ideal.quotient.field _ _ _
  (classical.some_spec (exists_le_maximal (span (relt K ⊤)) ne_top)).1

variables {K}

def of : K → K1 K := ideal.quotient.mk _ ∘ mv_polynomial.C

instance of.is_ring_hom : is_ring_hom (@of K _) := is_ring_hom.comp _ _

instance : algebra K (K1 K) := algebra.of_ring_hom of of.is_ring_hom

lemma algebra_map_eq_of : algebra_map (K1 K) = of := rfl

lemma aeval_posd {f : posd K} : (polynomial.aeval K (K1 K)
  (ideal.quotient.mk (big_ideal K) (X f)) :
    polynomial K → K1 K) f.1 = 0 :=
begin
  rw [polynomial.aeval_def, algebra_map_eq_of, of,
    ← hom_eval₂ _ mv_polynomial.C (ideal.quotient.mk (big_ideal K)), ← mname],
  exact ideal.quotient.mk_eq_zero.2
    ((classical.some_spec (exists_le_maximal (span (relt K ⊤)) ne_top)).2
      (subset_span (set.mem_image_of_mem _ (set.mem_univ _))))
end

lemma is_integral_aux {f : posd K} : @is_integral K (K1 K) _ _ _
  (ideal.quotient.mk _ (X f) : K1 K) :=
⟨f, f.2.2, aeval_posd⟩

lemma mem_integral_closure (x : K1 K) : is_integral K x :=
quotient.induction_on' x $ λ x,
  show ideal.quotient.mk _ x ∈ integral_closure K (K1 K),
  from mv_polynomial.induction_on x
    (λ k, is_integral_algebra_map)
    sorry -- subalgebra.add_mem
    (λ x p, sorry)


import category_theory.base
import category_theory.eq_to_hom
import category_theory.groupoid
import category_theory.full_subcategory

universes v x z u u' w w' y y'

local notation f ` ∘ `:80 g:80 := g ≫ f

namespace category_theory

-- TODO: merge with category_theory.full_subcategory

local attribute [simps] induced_category.category

variables {C : Type u} {C' : Type u'} (k : C' → C)
variables {D : Type w} {D' : Type w'} (l : D' → D)

def induced_functor' {catC : category.{v} C} {catD : category.{x} D} (F : C ↝ D)
  (F' : C' → D') (e : ∀ a, F.obj (k a) = l (F' a)) :
  induced_category C k ↝ induced_category D l :=
{ obj := F',
  map := λ X Y f,
    show l (F' X) ⟶ l (F' Y), from
    eq_to_hom (e Y) ∘ (F &> f) ∘ eq_to_hom (e X).symm,
  map_id' := λ X, by dsimp; rw F.map_id; simp,
  map_comp' := λ X Y Z f g, by dsimp; rw F.map_comp; simp }

lemma induced_functor_id [catC : category.{v} C] :
  induced_functor' k k (functor.id C) id (λ a, rfl) =
  functor.id (induced_category C k) :=
begin
  fapply functor.ext,
  { intro a, refl },
  { intros a b f, dsimp [induced_functor'], simp }
end

variables {E : Type y} {E' : Type y'} (m : E' → E)
lemma induced_functor_comp [catC : category.{v} C]
  [catD : category.{x} D] [catE : category.{z} E]
  {F : C ↝ D} {F' : C' → D'} (eF : ∀ a, F.obj (k a) = l (F' a))
  {G : D ↝ E} {G' : D' → E'} (eG : ∀ a, G.obj (l a) = m (G' a)) :
  induced_functor' k m (F.comp G) (function.comp G' F')
    (by intro a; change G.obj (F.obj (k a)) = _; rw [eF, eG]) =
    induced_functor' k l F F' eF ⋙ induced_functor' l m G G' eG :=
begin
  fapply functor.ext,
  { intro a, refl },
  { intros a b f,
    -- This proof mysteriously broke
    dsimp [induced_functor'],
    rw category.id_comp,
    erw category.comp_id,
    -- FIXME: Why was this lemma removed from simp?
    simp [eq_to_hom_map], refl }
end

end category_theory


/-
Copyright (c) 2021 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Scott Morrison, Adam Topaz
-/
import category_theory.preadditive
import category_theory.preadditive.additive_functor
import data.equiv.transfer_instance

/-!
# If `C` is preadditive, `Cᵒᵖ` has a natural preadditive structure.

-/

open opposite

namespace category_theory

variables (C : Type*) [category C] [preadditive C]

instance : preadditive Cᵒᵖ :=
{ hom_group := λ X Y, equiv.add_comm_group (op_equiv X Y),
  add_comp' := λ X Y Z f f' g,
    congr_arg quiver.hom.op (preadditive.comp_add _ _ _ g.unop f.unop f'.unop),
  comp_add' := λ X Y Z f g g',
    congr_arg quiver.hom.op (preadditive.add_comp _ _ _ g.unop g'.unop f.unop), }

instance module_End_left {X : Cᵒᵖ} {Y : C} : module (End X) (unop X ⟶ Y) :=
{ smul_add := λ r f g, preadditive.comp_add _ _ _ _ _ _,
  smul_zero := λ r, limits.comp_zero,
  add_smul := λ r s f, preadditive.add_comp _ _ _ _ _ _,
  zero_smul := λ f, limits.zero_comp }

@[simp] lemma unop_zero (X Y : Cᵒᵖ) : (0 : X ⟶ Y).unop = 0 := rfl
@[simp] lemma unop_add {X Y : Cᵒᵖ} (f g : X ⟶ Y) : (f + g).unop = f.unop + g.unop := rfl
@[simp] lemma op_zero (X Y : C) : (0 : X ⟶ Y).op = 0 := rfl
@[simp]

variables {C} {D : Type*} [category D] [preadditive D]

instance functor.op_additive (F : C ⥤ D) [F.additive] : F.op.additive := {}

instance functor.right_op_additive (F : Cᵒᵖ ⥤ D) [F.additive] : F.right_op.additive := {}

instance functor.left_op_additive (F : C ⥤ Dᵒᵖ) [F.additive] : F.left_op.additive := {}

instance functor.unop_additive (F : Cᵒᵖ ⥤ Dᵒᵖ) [F.additive] : F.unop.additive := {}

end category_theory


/-
Copyright (c) 2021 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Scott Morrison, Adam Topaz
-/
import category_theory.preadditive
import category_theory.preadditive.additive_functor
import logic.equiv.transfer_instance

/-!
# If `C` is preadditive, `Cᵒᵖ` has a natural preadditive structure.

-/

open opposite

namespace category_theory

variables (C : Type*) [category C] [preadditive C]

instance : preadditive Cᵒᵖ :=
{ hom_group := λ X Y, equiv.add_comm_group (op_equiv X Y),
  add_comp' := λ X Y Z f f' g,
    congr_arg quiver.hom.op (preadditive.comp_add _ _ _ g.unop f.unop f'.unop),
  comp_add' := λ X Y Z f g g',
    congr_arg quiver.hom.op (preadditive.add_comp _ _ _ g.unop g'.unop f.unop), }

instance module_End_left {X : Cᵒᵖ} {Y : C} : module (End X) (unop X ⟶ Y) :=
{ smul_add := λ r f g, preadditive.comp_add _ _ _ _ _ _,
  smul_zero := λ r, limits.comp_zero,
  add_smul := λ r s f, preadditive.add_comp _ _ _ _ _ _,
  zero_smul := λ f, limits.zero_comp }

@[simp] lemma unop_zero (X Y : Cᵒᵖ) : (0 : X ⟶ Y).unop = 0 := rfl
@[simp] lemma unop_add {X Y : Cᵒᵖ} (f g : X ⟶ Y) : (f + g).unop = f.unop + g.unop := rfl
@[simp] lemma op_zero (X Y : C) : (0 : X ⟶ Y).op = 0 := rfl
@[simp]

variables {C} {D : Type*} [category D] [preadditive D]

instance functor.op_additive (F : C ⥤ D) [F.additive] : F.op.additive := {}

instance functor.right_op_additive (F : Cᵒᵖ ⥤ D) [F.additive] : F.right_op.additive := {}

instance functor.left_op_additive (F : C ⥤ Dᵒᵖ) [F.additive] : F.left_op.additive := {}

instance functor.unop_additive (F : Cᵒᵖ ⥤ Dᵒᵖ) [F.additive] : F.unop.additive := {}

end category_theory