/-
Copyright (c) 2017 Kenny Lau. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Kenny Lau, Mario Carneiro, Johannes Hölzl, Chris Hughes, Jens Wagemaker
-/
import algebra.group.basic
import logic.nontrivial

/-!
# Units (i.e., invertible elements) of a monoid

An element of a `monoid` is a unit if it has a two-sided inverse.

## Main declarations

* `units M`: the group of units (i.e., invertible elements) of a monoid.
* `is_unit x`: a predicate asserting that `x` is a unit (i.e., invertible element) of a monoid.

For both declarations, there is an additive counterpart: `add_units` and `is_add_unit`.

## Notation

We provide `Mˣ` as notation for `units M`,
resembling the notation $R^{\times}$ for the units of a ring, which is common in mathematics.

-/

open function

universe u
variable {α : Type u}

/-- Units of a `monoid`, bundled version. Notation: `αˣ`.

An element of a `monoid` is a unit if it has a two-sided inverse.
This version bundles the inverse element so that it can be computed.
For a predicate see `is_unit`. -/
structure units (α : Type u) [monoid α] :=
(val : α)
(inv : α)
(val_inv : val * inv = 1)
(inv_val : inv * val = 1)

postfix `ˣ`:1025 := units
-- We don't provide notation for the additive version, because its use is somewhat rare.

/-- Units of an `add_monoid`, bundled version.

An element of an `add_monoid` is a unit if it has a two-sided additive inverse.
This version bundles the inverse element so that it can be computed.
For a predicate see `is_add_unit`. -/
structure add_units (α : Type u) [add_monoid α] :=
(val : α)
(neg : α)
(val_neg : val + neg = 0)
(neg_val : neg + val = 0)

attribute [to_additive] units

section has_elem

@[to_additive] lemma unique_has_one {α : Type*} [unique α] [has_one α] :
  default = (1 : α) :=
unique.default_eq 1

end has_elem

namespace units

variables [monoid α]

@[to_additive] instance : has_coe αˣ α := ⟨val⟩

@[to_additive] instance : has_inv αˣ := ⟨λ u, ⟨u.2, u.1, u.4, u.3⟩⟩

/-- See Note [custom simps projection] -/
@[to_additive /-" See Note [custom simps projection] "-/]
def simps.coe (u : αˣ) : α := u

/-- See Note [custom simps projection] -/
@[to_additive /-" See Note [custom simps projection] "-/]
def simps.coe_inv (u : αˣ) : α := ↑(u⁻¹)

initialize_simps_projections units (val → coe as_prefix, inv → coe_inv as_prefix)
initialize_simps_projections add_units (val → coe as_prefix, neg → coe_neg as_prefix)

@[simp, to_additive] lemma coe_mk (a : α) (b h₁ h₂) : ↑(units.mk a b h₁ h₂) = a := rfl

@[ext, to_additive] theorem ext :
  function.injective (coe : αˣ → α)
| ⟨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₁

@[norm_cast, to_additive] theorem eq_iff {a b : αˣ} :
  (a : α) = b ↔ a = b := ext.eq_iff

@[to_additive] theorem ext_iff {a b : αˣ} :
  a = b ↔ (a : α) = b := eq_iff.symm

@[to_additive] instance [decidable_eq α] : decidable_eq αˣ :=
λ a b, decidable_of_iff' _ ext_iff

@[simp, to_additive] theorem mk_coe (u : αˣ) (y h₁ h₂) :
  mk (u : α) y h₁ h₂ = u :=
ext rfl

/-- Copy a unit, adjusting definition equalities. -/
@[to_additive /-"Copy an `add_unit`, adjusting definitional equalities."-/, simps]
def copy (u : αˣ) (val : α) (hv : val = u) (inv : α) (hi : inv = ↑(u⁻¹)) : αˣ :=
{ val := val, inv := inv,
  inv_val := hv.symm ▸ hi.symm ▸ u.inv_val, val_inv := hv.symm ▸ hi.symm ▸ u.val_inv }

@[to_additive]
lemma copy_eq (u : αˣ) (val hv inv hi) :
  u.copy val hv inv hi = u :=
ext hv

/-- Units of a monoid form a group. -/
@[to_additive "Additive units of an additive monoid form an additive group."] instance : group αˣ :=
{ mul := λ u₁ u₂, ⟨u₁.val * u₂.val, u₂.inv * u₁.inv,
    by rw [mul_assoc, ← mul_assoc u₂.val, val_inv, one_mul, val_inv],
    by rw [mul_assoc, ← mul_assoc u₁.inv, inv_val, one_mul, inv_val]⟩,
  one := ⟨1, 1, one_mul 1, one_mul 1⟩,
  mul_one := λ u, ext $ mul_one u,
  one_mul := λ u, ext $ one_mul u,
  mul_assoc := λ u₁ u₂ u₃, ext $ mul_assoc u₁ u₂ u₃,
  inv := has_inv.inv,
  mul_left_inv := λ u, ext u.inv_val }

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

@[to_additive] instance : inhabited αˣ := ⟨1⟩

@[to_additive] instance [has_repr α] : has_repr αˣ := ⟨repr ∘ val⟩

variables (a b c : αˣ) {u : αˣ}

@[simp, norm_cast, to_additive] lemma coe_mul : (↑(a * b) : α) = a * b := rfl

@[simp, norm_cast, to_additive] lemma coe_one : ((1 : αˣ) : α) = 1 := rfl

@[simp, norm_cast, to_additive] lemma coe_eq_one {a : αˣ} : (a : α) = 1 ↔ a = 1 :=
by rw [←units.coe_one, eq_iff]

@[simp, to_additive] lemma inv_mk (x y : α) (h₁ h₂) : (mk x y h₁ h₂)⁻¹ = mk y x h₂ h₁ := rfl

@[simp, to_additive] lemma val_eq_coe : a.val = (↑a : α) := rfl

@[simp, to_additive] lemma inv_eq_coe_inv : a.inv = ((a⁻¹ : αˣ) : α) := rfl

@[simp, to_additive] lemma inv_mul : (↑a⁻¹ * a : α) = 1 := inv_val _
@[simp, to_additive] lemma mul_inv : (a * ↑a⁻¹ : α) = 1 := val_inv _

@[to_additive] lemma inv_mul_of_eq {a : α} (h : ↑u = a) : ↑u⁻¹ * a = 1 := by rw [←h, u.inv_mul]
@[to_additive] lemma mul_inv_of_eq {a : α} (h : ↑u = a) : a * ↑u⁻¹ = 1 := by rw [←h, u.mul_inv]

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

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

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

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

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

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

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

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

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

@[to_additive]

@[to_additive] protected lemma inv_eq_of_mul_eq_one_left {a : α} (h : a * u = 1) : ↑u⁻¹ = a :=
calc ↑u⁻¹ = 1 * ↑u⁻¹ : by rw one_mul
      ... = a : by rw [←h, mul_inv_cancel_right]

@[to_additive] protected lemma inv_eq_of_mul_eq_one_right {a : α} (h : ↑u * a = 1) : ↑u⁻¹ = a :=
calc ↑u⁻¹ = ↑u⁻¹ * 1 : by rw mul_one
      ... = a : by rw [←h, inv_mul_cancel_left]

@[to_additive] protected lemma eq_inv_of_mul_eq_one_left {a : α} (h : ↑u * a = 1) : a = ↑u⁻¹ :=
(units.inv_eq_of_mul_eq_one_right h).symm

@[to_additive] protected lemma eq_inv_of_mul_eq_one_right {a : α} (h : a * u = 1) : a = ↑u⁻¹ :=
(units.inv_eq_of_mul_eq_one_left h).symm

@[simp, to_additive] lemma mul_inv_eq_one {a : α} : a * ↑u⁻¹ = 1 ↔ a = u :=
⟨inv_inv u ▸ units.eq_inv_of_mul_eq_one_right, λ h, mul_inv_of_eq h.symm⟩

@[simp, to_additive] lemma inv_mul_eq_one {a : α} : ↑u⁻¹ * a = 1 ↔ ↑u = a :=
⟨inv_inv u ▸ units.inv_eq_of_mul_eq_one_right, inv_mul_of_eq⟩

@[to_additive] lemma mul_eq_one_iff_eq_inv {a : α} : a * u = 1 ↔ a = ↑u⁻¹ :=
by rw [←mul_inv_eq_one, inv_inv]

@[to_additive] lemma mul_eq_one_iff_inv_eq {a : α} : ↑u * a = 1 ↔ ↑u⁻¹ = a :=
by rw [←inv_mul_eq_one, inv_inv]

lemma inv_unique {u₁ u₂ : αˣ} (h : (↑u₁ : α) = ↑u₂) : (↑u₁⁻¹ : α) = ↑u₂⁻¹ :=
units.inv_eq_of_mul_eq_one_right $ by rw [h, u₂.mul_inv]

end units

/-- For `a, b` in a `comm_monoid` such that `a * b = 1`, makes a unit out of `a`. -/
@[to_additive "For `a, b` in an `add_comm_monoid` such that `a + b = 0`, makes an add_unit
out of `a`."]
def units.mk_of_mul_eq_one [comm_monoid α] (a b : α) (hab : a * b = 1) :
  αˣ :=
⟨a, b, hab, (mul_comm b a).trans hab⟩

@[simp, to_additive] lemma units.coe_mk_of_mul_eq_one [comm_monoid α] {a b : α} (h : a * b = 1) :
  (units.mk_of_mul_eq_one a b h : α) = a := 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⁻¹ : αˣ)

infix ` /ₚ `:70 := divp

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

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

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

@[simp] theorem divp_inv (u : αˣ) : a /ₚ u⁻¹ = a * u := rfl

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

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

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

theorem divp_divp_eq_divp_mul (x : α) (u₁ u₂ : αˣ) : (x /ₚ u₁) /ₚ u₂ = x /ₚ (u₂ * u₁) :=
by simp only [divp, mul_inv_rev, units.coe_mul, mul_assoc]

theorem divp_eq_iff_mul_eq {x : α} {u : αˣ} {y : α} : x /ₚ u = y ↔ y * u = x :=
u.mul_left_inj.symm.trans $ by rw [divp_mul_cancel]; exact ⟨eq.symm, eq.symm⟩

theorem divp_eq_one_iff_eq {a : α} {u : αˣ} : a /ₚ u = 1 ↔ a = u :=
(units.mul_left_inj u).symm.trans $ by rw [divp_mul_cancel, one_mul]

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

end monoid

section comm_monoid

variables [comm_monoid α]

theorem divp_eq_divp_iff {x y : α} {ux uy : αˣ} :
  x /ₚ ux = y /ₚ uy ↔ x * uy = y * ux :=
by rw [divp_eq_iff_mul_eq, mul_comm, ← divp_assoc, divp_eq_iff_mul_eq, mul_comm y ux]

theorem divp_mul_divp (x y : α) (ux uy : αˣ) :
  (x /ₚ ux) * (y /ₚ uy) = (x * y) /ₚ (ux * uy) :=
by rw [← divp_divp_eq_divp_mul, divp_assoc, mul_comm x, divp_assoc, mul_comm]

end comm_monoid

/-!
# `is_unit` predicate

In this file we define the `is_unit` predicate on a `monoid`, and
prove a few basic properties. For the bundled version see `units`. See
also `prime`, `associated`, and `irreducible` in `algebra/associated`.

-/

section is_unit

variables {M : Type*} {N : Type*}

/-- An element `a : M` of a monoid is a unit if it has a two-sided inverse.
The actual definition says that `a` is equal to some `u : Mˣ`, where
`Mˣ` is a bundled version of `is_unit`. -/
@[to_additive "An element `a : M` of an add_monoid is an `add_unit` if it has
a two-sided additive inverse. The actual definition says that `a` is equal to some
`u : add_units M`, where `add_units M` is a bundled version of `is_add_unit`."]
def is_unit [monoid M] (a : M) : Prop := ∃ u : Mˣ, (u : M) = a

@[nontriviality, to_additive]
lemma is_unit_of_subsingleton [monoid M] [subsingleton M] (a : M) : is_unit a :=
⟨⟨a, a, subsingleton.elim _ _, subsingleton.elim _ _⟩, rfl⟩

attribute [nontriviality] is_add_unit_of_subsingleton

@[to_additive] instance [monoid M] : can_lift M Mˣ :=
{ coe := coe,
  cond := is_unit,
  prf := λ _, id }

@[to_additive] instance [monoid M] [subsingleton M] : unique Mˣ :=
{ default := 1,
  uniq := λ a, units.coe_eq_one.mp $ subsingleton.elim (a : M) 1 }

@[simp, to_additive is_add_unit_add_unit]
protected lemma units.is_unit [monoid M] (u : Mˣ) : is_unit (u : M) := ⟨u, rfl⟩

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

@[to_additive] theorem is_unit_of_mul_eq_one [comm_monoid M]
  (a b : M) (h : a * b = 1) : is_unit a :=
⟨units.mk_of_mul_eq_one a b h, rfl⟩

@[to_additive is_add_unit.exists_neg] theorem is_unit.exists_right_inv [monoid M]
  {a : M} (h : is_unit a) : ∃ b, a * b = 1 :=
by { rcases h with ⟨⟨a, b, hab, _⟩, rfl⟩, exact ⟨b, hab⟩ }

@[to_additive is_add_unit.exists_neg'] theorem is_unit.exists_left_inv [monoid M]
  {a : M} (h : is_unit a) : ∃ b, b * a = 1 :=
by { rcases h with ⟨⟨a, b, _, hba⟩, rfl⟩, exact ⟨b, hba⟩ }

@[to_additive] theorem is_unit_iff_exists_inv [comm_monoid M]
  {a : M} : is_unit a ↔ ∃ b, a * b = 1 :=
⟨λ h, h.exists_right_inv,
 λ ⟨b, hab⟩, is_unit_of_mul_eq_one _ b hab⟩

@[to_additive] theorem is_unit_iff_exists_inv' [comm_monoid M]
  {a : M} : is_unit a ↔ ∃ b, b * a = 1 :=
by simp [is_unit_iff_exists_inv, mul_comm]

@[to_additive]
lemma is_unit.mul [monoid M] {x y : M} : is_unit x → is_unit y → is_unit (x * y) :=
by { rintros ⟨x, rfl⟩ ⟨y, rfl⟩, exact ⟨x * y, units.coe_mul _ _⟩ }

/-- Multiplication by a `u : Mˣ` on the right doesn't affect `is_unit`. -/
@[simp, to_additive "Addition of a `u : add_units M` on the right doesn't
affect `is_add_unit`."]
theorem units.is_unit_mul_units [monoid M] (a : M) (u : Mˣ) :
  is_unit (a * u) ↔ is_unit a :=
iff.intro
  (assume ⟨v, hv⟩,
    have is_unit (a * ↑u * ↑u⁻¹), by existsi v * u⁻¹; rw [←hv, units.coe_mul],
    by rwa [mul_assoc, units.mul_inv, mul_one] at this)
  (λ v, v.mul u.is_unit)

/-- Multiplication by a `u : Mˣ` on the left doesn't affect `is_unit`. -/
@[simp, to_additive "Addition of a `u : add_units M` on the left doesn't affect `is_add_unit`."]
theorem units.is_unit_units_mul {M : Type*} [monoid M] (u : Mˣ) (a : M) :
  is_unit (↑u * a) ↔ is_unit a :=
iff.intro
  (assume ⟨v, hv⟩,
    have is_unit (↑u⁻¹ * (↑u * a)), by existsi u⁻¹ * v; rw [←hv, units.coe_mul],
    by rwa [←mul_assoc, units.inv_mul, one_mul] at this)
  u.is_unit.mul

@[to_additive]
theorem is_unit_of_mul_is_unit_left [comm_monoid M] {x y : M}
  (hu : is_unit (x * y)) : is_unit x :=
let ⟨z, hz⟩ := is_unit_iff_exists_inv.1 hu in
is_unit_iff_exists_inv.2 ⟨y * z, by rwa ← mul_assoc⟩

@[to_additive] theorem is_unit_of_mul_is_unit_right [comm_monoid M] {x y : M}
  (hu : is_unit (x * y)) : is_unit y :=
@is_unit_of_mul_is_unit_left _ _ y x $ by rwa mul_comm

@[simp, to_additive]
lemma is_unit.mul_iff [comm_monoid M] {x y : M} : is_unit (x * y) ↔ is_unit x ∧ is_unit y :=
⟨λ h, ⟨is_unit_of_mul_is_unit_left h, is_unit_of_mul_is_unit_right h⟩,
  λ h, is_unit.mul h.1 h.2⟩

/-- The element of the group of units, corresponding to an element of a monoid which is a unit. When
`α` is a `division_monoid`, use `is_unit.unit'` instead. -/
@[to_additive "The element of the additive group of additive units, corresponding to an element of
an additive monoid which is an additive unit. When `α` is a `subtraction_monoid`, use
`is_add_unit.add_unit'` instead."]
noncomputable def is_unit.unit [monoid M] {a : M} (h : is_unit a) : Mˣ :=
(classical.some h).copy a (classical.some_spec h).symm _ rfl

@[simp, to_additive]
lemma is_unit.unit_of_coe_units [monoid M] {a : Mˣ} (h : is_unit (a : M)) : h.unit = a :=
units.ext $ rfl

@[to_additive]
lemma is_unit.unit_spec [monoid M] {a : M} (h : is_unit a) : ↑h.unit = a :=
rfl

@[to_additive]
lemma is_unit.coe_inv_mul [monoid M] {a : M} (h : is_unit a) :
  ↑(h.unit)⁻¹ * a = 1 :=
units.mul_inv _

@[to_additive]
lemma is_unit.mul_coe_inv [monoid M] {a : M} (h : is_unit a) :
  a * ↑(h.unit)⁻¹ = 1 :=
begin
  convert units.mul_inv _,
  simp [h.unit_spec]
end

/-- `is_unit x` is decidable if we can decide if `x` comes from `Mˣ`. -/
instance [monoid M] (x : M) [h : decidable (∃ u : Mˣ, ↑u = x)] : decidable (is_unit x) := h

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

@[to_additive] lemma is_unit.mul_left_inj (h : is_unit a) : b * a = c * a ↔ b = c :=
let ⟨u, hu⟩ := h in hu ▸ u.mul_left_inj

@[to_additive] lemma is_unit.mul_right_inj (h : is_unit a) : a * b = a * c ↔ b = c :=
let ⟨u, hu⟩ := h in hu ▸ u.mul_right_inj

@[to_additive] protected lemma is_unit.mul_left_cancel (h : is_unit a) : a * b = a * c → b = c :=
h.mul_right_inj.1

@[to_additive] protected lemma is_unit.mul_right_cancel (h : is_unit b) : a * b = c * b → a = c :=
h.mul_left_inj.1

@[to_additive] protected lemma is_unit.mul_right_injective (h : is_unit a) : injective ((*) a) :=
λ _ _, h.mul_left_cancel

@[to_additive] protected lemma is_unit.mul_left_injective (h : is_unit b) : injective (* b) :=
λ _ _, h.mul_right_cancel

end monoid
end is_unit

section noncomputable_defs

variables {M : Type*}

/-- Constructs a `group` structure on a `monoid` consisting only of units. -/
noncomputable def group_of_is_unit [hM : monoid M] (h : ∀ (a : M), is_unit a) : group M :=
{ inv := λ a, ↑((h a).unit)⁻¹,
  mul_left_inv := λ a, by
  { change ↑((h a).unit)⁻¹ * a = 1,
    rw [units.inv_mul_eq_iff_eq_mul, (h a).unit_spec, mul_one] },
  .. hM }

/-- Constructs a `comm_group` structure on a `comm_monoid` consisting only of units. -/
noncomputable def comm_group_of_is_unit [hM : comm_monoid M] (h : ∀ (a : M), is_unit a) :
  comm_group M :=
{ inv := λ a, ↑((h a).unit)⁻¹,
  mul_left_inv := λ a, by
  { change ↑((h a).unit)⁻¹ * a = 1,
    rw [units.inv_mul_eq_iff_eq_mul, (h a).unit_spec, mul_one] },
  .. hM }

end noncomputable_defs


/-
Copyright (c) 2022 Kyle Miller, Adam Topaz, Rémi Bottinelli, Junyan Xu. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Kyle Miller, Adam Topaz, Rémi Bottinelli, Junyan Xu
-/
import category_theory.filtered
import data.set.finite
import topology.category.Top.limits

/-!
# Cofiltered systems

This file deals with properties of cofiltered (and inverse) systems.

## Main definitions

Given a functor `F : J ⥤ Type v`:

* For `j : J`, `F.eventual_range j` is the intersections of all ranges of morphisms `F.map f`
  where `f` has codomain `j`.
* `F.is_mittag_leffler` states that the functor `F` satisfies the Mittag-Leffler
  condition: the ranges of morphisms `F.map f` (with `f` having codomain `j`) stabilize.
* If `J` is cofiltered `F.to_eventual_ranges` is the subfunctor of `F` obtained by restriction
  to `F.eventual_range`.
* `F.to_preimages` restricts a functor to preimages of a given set in some `F.obj i`. If `J` is
  cofiltered, then it is Mittag-Leffler if `F` is, see `is_mittag_leffler.to_preimages`.

## Main statements

* `nonempty_sections_of_finite_cofiltered_system` shows that if `J` is cofiltered and each
  `F.obj j` is nonempty and finite, `F.sections` is nonempty.
* `nonempty_sections_of_finite_inverse_system` is a specialization of the above to `J` being a
   directed set (and `F : Jᵒᵖ ⥤ Type v`).
* `is_mittag_leffler_of_exists_finite_range` shows that if `J` is cofiltered and for all `j`,
  there exists some `i` and `f : i ⟶ j` such that the range of `F.map f` is finite, then
  `F` is Mittag-Leffler.
* `to_eventual_ranges_surjective` shows that if `F` is Mittag-Leffler, then `F.to_eventual_ranges`
  has all morphisms `F.map f` surjective.

## Todo

* Prove [Stacks: Lemma 0597](https://stacks.math.columbia.edu/tag/0597)

## References

* [Stacks: Mittag-Leffler systems](https://stacks.math.columbia.edu/tag/0594)

## Tags

Mittag-Leffler, surjective, eventual range, inverse system,

-/

universes u v w

open category_theory category_theory.is_cofiltered set category_theory.functor_to_types

section finite_konig

/-- This bootstraps `nonempty_sections_of_finite_inverse_system`. In this version,
the `F` functor is between categories of the same universe, and it is an easy
corollary to `Top.nonempty_limit_cone_of_compact_t2_inverse_system`. -/
lemma nonempty_sections_of_finite_cofiltered_system.init
  {J : Type u} [small_category J] [is_cofiltered_or_empty J] (F : J ⥤ Type u)
  [hf : ∀ j, finite (F.obj j)] [hne : ∀ j, nonempty (F.obj j)] :
  F.sections.nonempty :=
begin
  let F' : J ⥤ Top := F ⋙ Top.discrete,
  haveI : ∀ j, discrete_topology (F'.obj j) := λ _, ⟨rfl⟩,
  haveI : ∀ j, finite (F'.obj j) := hf,
  haveI : ∀ j, nonempty (F'.obj j) := hne,
  obtain ⟨⟨u, hu⟩⟩ := Top.nonempty_limit_cone_of_compact_t2_cofiltered_system F',
  exact ⟨u, λ _ _, hu⟩,
end

/-- The cofiltered limit of nonempty finite types is nonempty.

See `nonempty_sections_of_finite_inverse_system` for a specialization to inverse limits. -/
theorem nonempty_sections_of_finite_cofiltered_system
  {J : Type u} [category.{w} J] [is_cofiltered_or_empty J] (F : J ⥤ Type v)
  [∀ (j : J), finite (F.obj j)] [∀ (j : J), nonempty (F.obj j)] :
  F.sections.nonempty :=
begin
  -- Step 1: lift everything to the `max u v w` universe.
  let J' : Type (max w v u) := as_small.{max w v} J,
  let down : J' ⥤ J := as_small.down,
  let F' : J' ⥤ Type (max u v w) := down ⋙ F ⋙ ulift_functor.{(max u w) v},
  haveI : ∀ i, nonempty (F'.obj i) := λ i, ⟨⟨classical.arbitrary (F.obj (down.obj i))⟩⟩,
  haveI : ∀ i, finite (F'.obj i) := λ i, finite.of_equiv (F.obj (down.obj i)) equiv.ulift.symm,
  -- Step 2: apply the bootstrap theorem
  casesI is_empty_or_nonempty J,
  { fsplit; exact is_empty_elim },
  haveI : is_cofiltered J := ⟨⟩,
  obtain ⟨u, hu⟩ := nonempty_sections_of_finite_cofiltered_system.init F',
  -- Step 3: interpret the results
  use λ j, (u ⟨j⟩).down,
  intros j j' f,
  have h := @hu (⟨j⟩ : J') (⟨j'⟩ : J') (ulift.up f),
  simp only [as_small.down, functor.comp_map, ulift_functor_map, functor.op_map] at h,
  simp_rw [←h],
  refl,
end

/-- The inverse limit of nonempty finite types is nonempty.

See `nonempty_sections_of_finite_cofiltered_system` for a generalization to cofiltered limits.
That version applies in almost all cases, and the only difference is that this version
allows `J` to be empty.

This may be regarded as a generalization of Kőnig's lemma.
To specialize: given a locally finite connected graph, take `Jᵒᵖ` to be `ℕ` and
`F j` to be length-`j` paths that start from an arbitrary fixed vertex.
Elements of `F.sections` can be read off as infinite rays in the graph. -/
theorem nonempty_sections_of_finite_inverse_system
  {J : Type u} [preorder J] [is_directed J (≤)] (F : Jᵒᵖ ⥤ Type v)
  [∀ (j : Jᵒᵖ), finite (F.obj j)] [∀ (j : Jᵒᵖ), nonempty (F.obj j)] :
  F.sections.nonempty :=
begin
  casesI is_empty_or_nonempty J,
  { haveI : is_empty Jᵒᵖ := ⟨λ j, is_empty_elim j.unop⟩,  -- TODO: this should be a global instance
    exact ⟨is_empty_elim, is_empty_elim⟩, },
  { exact nonempty_sections_of_finite_cofiltered_system _, },
end

end finite_konig

namespace category_theory
namespace functor

variables {J : Type u} [category J] (F : J ⥤ Type v) {i j k : J} (s : set (F.obj i))

/--
The eventual range of the functor `F : J ⥤ Type v` at index `j : J` is the intersection
of the ranges of all maps `F.map f` with `i : J` and `f : i ⟶ j`.
-/
def eventual_range (j : J) := ⋂ i (f : i ⟶ j), range (F.map f)

lemma mem_eventual_range_iff {x : F.obj j} :
  x ∈ F.eventual_range j ↔ ∀ ⦃i⦄ (f : i ⟶ j), x ∈ range (F.map f) := mem_Inter₂

/--
The functor `F : J ⥤ Type v` satisfies the Mittag-Leffler condition if for all `j : J`,
there exists some `i : J` and `f : i ⟶ j` such that for all `k : J` and `g : k ⟶ j`, the range
of `F.map f` is contained in that of `F.map g`;
in other words (see `is_mittag_leffler_iff_eventual_range`), the eventual range at `j` is attained
by some `f : i ⟶ j`.
-/
def is_mittag_leffler : Prop :=
∀ j : J, ∃ i (f : i ⟶ j), ∀ ⦃k⦄ (g : k ⟶ j), range (F.map f) ⊆ range (F.map g)

lemma is_mittag_leffler_iff_eventual_range : F.is_mittag_leffler ↔
  ∀ j : J, ∃ i (f : i ⟶ j), F.eventual_range j = range (F.map f) :=
forall_congr $ λ j, exists₂_congr $ λ i f,
  ⟨λ h, (Inter₂_subset _ _).antisymm $ subset_Inter₂ h, λ h, h ▸ Inter₂_subset⟩

lemma is_mittag_leffler.subset_image_eventual_range (h : F.is_mittag_leffler) (f : j ⟶ i) :
  F.eventual_range i ⊆ F.map f '' (F.eventual_range j) :=
begin
  obtain ⟨k, g, hg⟩ := F.is_mittag_leffler_iff_eventual_range.1 h j,
  rw hg, intros x hx,
  obtain ⟨x, rfl⟩ := F.mem_eventual_range_iff.1 hx (g ≫ f),
  refine ⟨_, ⟨x, rfl⟩, by simpa only [F.map_comp]⟩,
end

lemma eventual_range_eq_range_precomp (f : i ⟶ j) (g : j ⟶ k)
  (h : F.eventual_range k = range (F.map g)) :
  F.eventual_range k = range (F.map $ f ≫ g) :=
begin
  apply subset_antisymm,
  { apply Inter₂_subset, },
  { rw [h, F.map_comp], apply range_comp_subset_range, }
end

lemma is_mittag_leffler_of_surjective
  (h : ∀ ⦃i j : J⦄ (f :i ⟶ j), (F.map f).surjective) : F.is_mittag_leffler :=
λ j, ⟨j, 𝟙 j, λ k g, by rw [map_id, types_id, range_id, (h g).range_eq]⟩

/-- The subfunctor of `F` obtained by restricting to the preimages of a set `s ∈ F.obj i`. -/
@[simps] def to_preimages : J ⥤ Type v :=
{ obj := λ j, ⋂ f : j ⟶ i, F.map f ⁻¹' s,
  map := λ j k g, maps_to.restrict (F.map g) _ _ $ λ x h, begin
    rw [mem_Inter] at h ⊢, intro f,
    rw [← mem_preimage, preimage_preimage],
    convert h (g ≫ f), rw F.map_comp, refl,
  end,
  map_id' := λ j, by { simp_rw F.map_id, ext, refl },
  map_comp' := λ j k l f g, by { simp_rw F.map_comp, refl } }

instance to_preimages_finite [∀ j, finite (F.obj j)] :
  ∀ j, finite ((F.to_preimages s).obj j) := λ j, subtype.finite

variable [is_cofiltered_or_empty J]

lemma eventual_range_maps_to (f : j ⟶ i) :
  (F.eventual_range j).maps_to (F.map f) (F.eventual_range i) :=
λ x hx, begin
  rw mem_eventual_range_iff at hx ⊢,
  intros k f',
  obtain ⟨l, g, g', he⟩ := cospan f f',
  obtain ⟨x, rfl⟩ := hx g,
  rw [← map_comp_apply, he, F.map_comp],
  exact ⟨_, rfl⟩,
end

lemma is_mittag_leffler.eq_image_eventual_range (h : F.is_mittag_leffler) (f : j ⟶ i) :
  F.eventual_range i = F.map f '' (F.eventual_range j) :=
(h.subset_image_eventual_range F f).antisymm $ maps_to'.1 (F.eventual_range_maps_to f)

lemma eventual_range_eq_iff {f : i ⟶ j} :
  F.eventual_range j = range (F.map f) ↔
  ∀ ⦃k⦄ (g : k ⟶ i), range (F.map f) ⊆ range (F.map $ g ≫ f) :=
begin
  rw [subset_antisymm_iff, eventual_range, and_iff_right (Inter₂_subset _ _), subset_Inter₂_iff],
  refine ⟨λ h k g, h _ _, λ h j' f', _⟩,
  obtain ⟨k, g, g', he⟩ := cospan f f',
  refine (h g).trans _,
  rw [he, F.map_comp],
  apply range_comp_subset_range,
end

lemma is_mittag_leffler_iff_subset_range_comp : F.is_mittag_leffler ↔
  ∀ j : J, ∃ i (f : i ⟶ j), ∀ ⦃k⦄ (g : k ⟶ i), range (F.map f) ⊆ range (F.map $ g ≫ f) :=
by simp_rw [is_mittag_leffler_iff_eventual_range, eventual_range_eq_iff]

lemma is_mittag_leffler.to_preimages (h : F.is_mittag_leffler) :
  (F.to_preimages s).is_mittag_leffler :=
(is_mittag_leffler_iff_subset_range_comp _).2 $ λ j, begin
  obtain ⟨j₁, g₁, f₁, -⟩ := cone_objs i j,
  obtain ⟨j₂, f₂, h₂⟩ := F.is_mittag_leffler_iff_eventual_range.1 h j₁,
  refine ⟨j₂, f₂ ≫ f₁, λ j₃ f₃, _⟩,
  rintro _ ⟨⟨x, hx⟩, rfl⟩,
  have : F.map f₂ x ∈ F.eventual_range j₁, { rw h₂, exact ⟨_, rfl⟩ },
  obtain ⟨y, hy, h₃⟩ := h.subset_image_eventual_range F (f₃ ≫ f₂) this,
  refine ⟨⟨y, mem_Inter.2 $ λ g₂, _⟩, subtype.ext _⟩,
  { obtain ⟨j₄, f₄, h₄⟩ := cone_maps g₂ ((f₃ ≫ f₂) ≫ g₁),
    obtain ⟨y, rfl⟩ := F.mem_eventual_range_iff.1 hy f₄,
    rw ← map_comp_apply at h₃,
    rw [mem_preimage, ← map_comp_apply, h₄, ← category.assoc, map_comp_apply, h₃, ← map_comp_apply],
    apply mem_Inter.1 hx },
  { simp_rw [to_preimages_map, maps_to.coe_restrict_apply, subtype.coe_mk],
    rw [← category.assoc, map_comp_apply, h₃, map_comp_apply] },
end

lemma is_mittag_leffler_of_exists_finite_range
  (h : ∀ (j : J), ∃ i (f : i ⟶ j), (range $ F.map f).finite) :
  F.is_mittag_leffler :=
λ j, begin
  obtain ⟨i, hi, hf⟩ := h j,
  obtain ⟨m, ⟨i, f, hm⟩, hmin⟩ := finset.is_well_founded_lt.wf.has_min
    {s : finset (F.obj j) | ∃ i (f : i ⟶ j), ↑s = range (F.map f)} ⟨_, i, hi, hf.coe_to_finset⟩,
  refine ⟨i, f, λ k g,
    (directed_on_range.mp $ F.ranges_directed j).is_bot_of_is_min ⟨⟨i, f⟩, rfl⟩ _ _ ⟨⟨k, g⟩, rfl⟩⟩,
  rintro _ ⟨⟨k', g'⟩, rfl⟩ hl,
  refine (eq_of_le_of_not_lt hl _).ge,
  have := hmin _ ⟨k', g', (m.finite_to_set.subset $ hm.substr hl).coe_to_finset⟩,
  rwa [finset.lt_iff_ssubset, ← finset.coe_ssubset, set.finite.coe_to_finset, hm] at this,
end

/--
The subfunctor of `F` obtained by restricting to the eventual range at each index.
-/
@[simps] def to_eventual_ranges : J ⥤ Type v :=
{ obj := λ j, F.eventual_range j,
  map := λ i j f, (F.eventual_range_maps_to f).restrict _ _ _,
  map_id' := λ i, by { simp_rw F.map_id, ext, refl },
  map_comp' := λ _ _ _ _ _, by { simp_rw F.map_comp, refl } }

instance to_eventual_ranges_finite [∀ j, finite (F.obj j)] :
  ∀ j, finite (F.to_eventual_ranges.obj j) := λ j, subtype.finite

/--
The sections of the functor `F : J ⥤ Type v` are in bijection with the sections of
`F.eventual_ranges`.
-/
def to_eventual_ranges_sections_equiv : F.to_eventual_ranges.sections ≃ F.sections :=
{ to_fun := λ s, ⟨_, λ i j f, subtype.coe_inj.2 $ s.prop f⟩,
  inv_fun := λ s, ⟨λ j, ⟨_, mem_Inter₂.2 $ λ i f, ⟨_, s.prop f⟩⟩, λ i j f, subtype.ext $ s.prop f⟩,
  left_inv := λ _, by { ext, refl },
  right_inv := λ _, by { ext, refl } }

/--
If `F` satisfies the Mittag-Leffler condition, its restriction to eventual ranges is a surjective
functor.
-/
lemma surjective_to_eventual_ranges (h : F.is_mittag_leffler) ⦃i j⦄ (f : i ⟶ j) :
  (F.to_eventual_ranges.map f).surjective :=
λ ⟨x, hx⟩, by { obtain ⟨y, hy, rfl⟩ := h.subset_image_eventual_range F f hx, exact ⟨⟨y, hy⟩, rfl⟩ }

/-- If `F` is nonempty at each index and Mittag-Leffler, then so is `F.to_eventual_ranges`. -/
lemma to_eventual_ranges_nonempty (h : F.is_mittag_leffler) [∀ (j : J), nonempty (F.obj j)]
  (j : J) : nonempty (F.to_eventual_ranges.obj j) :=
let ⟨i, f, h⟩ := F.is_mittag_leffler_iff_eventual_range.1 h j in
by { rw [to_eventual_ranges_obj, h], apply_instance }

/-- If `F` has all arrows surjective, then it "factors through a poset". -/
lemma thin_diagram_of_surjective (Fsur : ∀ ⦃i j : J⦄ (f : i ⟶ j), (F.map f).surjective)
  {i j} (f g : i ⟶ j) : F.map f = F.map g :=
let ⟨k, φ, hφ⟩ := cone_maps f g in
(Fsur φ).injective_comp_right $ by simp_rw [← types_comp, ← F.map_comp, hφ]

lemma to_preimages_nonempty_of_surjective [hFn : ∀ (j : J), nonempty (F.obj j)]
  (Fsur : ∀ ⦃i j : J⦄ (f : i ⟶ j), (F.map f).surjective)
  (hs : s.nonempty) (j) : nonempty ((F.to_preimages s).obj j) :=
begin
  simp only [to_preimages_obj, nonempty_coe_sort, nonempty_Inter, mem_preimage],
  obtain (h|⟨⟨ji⟩⟩) := is_empty_or_nonempty (j ⟶ i),
  { exact ⟨(hFn j).some, λ ji, h.elim ji⟩, },
  { obtain ⟨y, ys⟩ := hs,
    obtain ⟨x, rfl⟩ := Fsur ji y,
    exact ⟨x, λ ji', (F.thin_diagram_of_surjective Fsur ji' ji).symm ▸ ys⟩, },
end

lemma eval_section_injective_of_eventually_injective
  {j} (Finj : ∀ i (f : i ⟶ j), (F.map f).injective) (i) (f : i ⟶ j) :
  (λ s : F.sections, s.val j).injective :=
begin
  refine λ s₀ s₁ h, subtype.ext $ funext $ λ k, _,
  obtain ⟨m, mi, mk, _⟩ := cone_objs i k,
  dsimp at h,
  rw [←s₀.prop (mi ≫ f), ←s₁.prop (mi ≫ f)] at h,
  rw [←s₀.prop mk, ←s₁.prop mk],
  refine congr_arg _ (Finj m (mi ≫ f) h),
end

section finite_cofiltered_system

variables [∀ (j : J), nonempty (F.obj j)] [∀ (j : J), finite (F.obj j)]
  (Fsur : ∀ ⦃i j : J⦄ (f :i ⟶ j), (F.map f).surjective)

include Fsur
lemma eval_section_surjective_of_surjective (i : J) :
  (λ s : F.sections, s.val i).surjective := λ x,
begin
  let s : set (F.obj i) := {x},
  haveI := F.to_preimages_nonempty_of_surjective s Fsur (singleton_nonempty x),
  obtain ⟨sec, h⟩ := nonempty_sections_of_finite_cofiltered_system (F.to_preimages s),
  refine ⟨⟨λ j, (sec j).val, λ j k jk, by simpa [subtype.ext_iff] using h jk⟩, _⟩,
  { have := (sec i).prop,
    simp only [mem_Inter, mem_preimage, mem_singleton_iff] at this,
    replace this := this (𝟙 i), rwa [map_id_apply] at this, },
end

lemma eventually_injective [nonempty J] [finite F.sections] :
  ∃ j, ∀ i (f : i ⟶ j), (F.map f).injective :=
begin
  haveI : ∀ j, fintype (F.obj j) := λ j, fintype.of_finite (F.obj j),
  haveI : fintype F.sections := fintype.of_finite F.sections,
  have card_le : ∀ j, fintype.card (F.obj j) ≤ fintype.card F.sections :=
    λ j, fintype.card_le_of_surjective _ (F.eval_section_surjective_of_surjective Fsur j),
  let fn := λ j, fintype.card F.sections - fintype.card (F.obj j),
  refine ⟨fn.argmin nat.well_founded_lt.wf, λ i f, ((fintype.bijective_iff_surjective_and_card _).2
    ⟨Fsur f, le_antisymm _ (fintype.card_le_of_surjective _ $ Fsur f)⟩).1⟩,
  rw [← nat.sub_sub_self (card_le i), tsub_le_iff_tsub_le],
  apply fn.argmin_le,
end

end finite_cofiltered_system

end functor
end category_theory


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

/-!
# Erasure of duplicates in a list

This file proves basic results about `list.dedup` (definition in `data.list.defs`).
`dedup l` returns `l` without its duplicates. It keeps the earliest (that is, rightmost)
occurrence of each.

## Tags

duplicate, multiplicity, nodup, `nub`
-/

universes u

namespace list

variables {α : Type u} [decidable_eq α]

@[simp] theorem dedup_nil : dedup [] = ([] : list α) := rfl

theorem dedup_cons_of_mem' {a : α} {l : list α} (h : a ∈ dedup l) :
  dedup (a :: l) = dedup l :=
pw_filter_cons_of_neg $ by simpa only [forall_mem_ne] using h

theorem dedup_cons_of_not_mem' {a : α} {l : list α} (h : a ∉ dedup l) :
  dedup (a :: l) = a :: dedup l :=
pw_filter_cons_of_pos $ by simpa only [forall_mem_ne] using h

@[simp] theorem mem_dedup {a : α} {l : list α} : a ∈ dedup l ↔ a ∈ l :=
by simpa only [dedup, forall_mem_ne, not_not] using not_congr (@forall_mem_pw_filter α (≠) _
  (λ x y z xz, not_and_distrib.1 $ mt (and.rec eq.trans) xz) a l)

@[simp] theorem dedup_cons_of_mem {a : α} {l : list α} (h : a ∈ l) :
  dedup (a :: l) = dedup l :=
dedup_cons_of_mem' $ mem_dedup.2 h

@[simp] theorem dedup_cons_of_not_mem {a : α} {l : list α} (h : a ∉ l) :
  dedup (a :: l) = a :: dedup l :=
dedup_cons_of_not_mem' $ mt mem_dedup.1 h

theorem dedup_sublist : ∀ (l : list α), dedup l <+ l := pw_filter_sublist

theorem dedup_subset : ∀ (l : list α), dedup l ⊆ l := pw_filter_subset

theorem subset_dedup (l : list α) : l ⊆ dedup l :=
λ a, mem_dedup.2

theorem nodup_dedup : ∀ l : list α, nodup (dedup l) := pairwise_pw_filter

theorem dedup_eq_self {l : list α} : dedup l = l ↔ nodup l := pw_filter_eq_self

protected lemma nodup.dedup {l : list α} (h : l.nodup) : l.dedup = l :=
list.dedup_eq_self.2 h

@[simp] theorem dedup_idempotent {l : list α} : dedup (dedup l) = dedup l :=
pw_filter_idempotent

theorem dedup_append (l₁ l₂ : list α) : dedup (l₁ ++ l₂) = l₁ ∪ dedup l₂ :=
begin
  induction l₁ with a l₁ IH, {refl}, rw [cons_union, ← IH],
  show dedup (a :: (l₁ ++ l₂)) = insert a (dedup (l₁ ++ l₂)),
  by_cases a ∈ dedup (l₁ ++ l₂);
  [ rw [dedup_cons_of_mem' h, insert_of_mem h],
    rw [dedup_cons_of_not_mem' h, insert_of_not_mem h]]
end

end list


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

Generalizes the Cauchy completion of (ℚ, abs) to the completion of a
commutative ring with absolute value.
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.data.real.cau_seq
import Mathlib.PostPort

universes u_1 u_2 l

namespace Mathlib

namespace cau_seq.completion

def Cauchy {α : Type u_1} [linear_ordered_field α] {β : Type u_2} [comm_ring β] {abv : β → α}
    [is_absolute_value abv] :=
  quotient cau_seq.equiv

def mk {α : Type u_1} [linear_ordered_field α] {β : Type u_2} [comm_ring β] {abv : β → α}
    [is_absolute_value abv] : cau_seq β abv → Cauchy :=
  quotient.mk

@[simp] theorem mk_eq_mk {α : Type u_1} [linear_ordered_field α] {β : Type u_2} [comm_ring β]
    {abv : β → α} [is_absolute_value abv] (f : cau_seq β abv) : quotient.mk f = mk f :=
  rfl

theorem mk_eq {α : Type u_1} [linear_ordered_field α] {β : Type u_2} [comm_ring β] {abv : β → α}
    [is_absolute_value abv] {f : cau_seq β abv} {g : cau_seq β abv} : mk f = mk g ↔ f ≈ g :=
  quotient.eq

def of_rat {α : Type u_1} [linear_ordered_field α] {β : Type u_2} [comm_ring β] {abv : β → α}
    [is_absolute_value abv] (x : β) : Cauchy :=
  mk (const abv x)

protected instance Cauchy.has_zero {α : Type u_1} [linear_ordered_field α] {β : Type u_2}
    [comm_ring β] {abv : β → α} [is_absolute_value abv] : HasZero Cauchy :=
  { zero := of_rat 0 }

protected instance Cauchy.has_one {α : Type u_1} [linear_ordered_field α] {β : Type u_2}
    [comm_ring β] {abv : β → α} [is_absolute_value abv] : HasOne Cauchy :=
  { one := of_rat 1 }

protected instance Cauchy.inhabited {α : Type u_1} [linear_ordered_field α] {β : Type u_2}
    [comm_ring β] {abv : β → α} [is_absolute_value abv] : Inhabited Cauchy :=
  { default := 0 }

theorem of_rat_zero {α : Type u_1} [linear_ordered_field α] {β : Type u_2} [comm_ring β]
    {abv : β → α} [is_absolute_value abv] : of_rat 0 = 0 :=
  rfl

theorem of_rat_one {α : Type u_1} [linear_ordered_field α] {β : Type u_2} [comm_ring β]
    {abv : β → α} [is_absolute_value abv] : of_rat 1 = 1 :=
  rfl

@[simp] theorem mk_eq_zero {α : Type u_1} [linear_ordered_field α] {β : Type u_2} [comm_ring β]
    {abv : β → α} [is_absolute_value abv] {f : cau_seq β abv} : mk f = 0 ↔ lim_zero f :=
  eq.mp (Eq._oldrec (Eq.refl (mk f = 0 ↔ lim_zero (f - 0))) (sub_zero f)) quotient.eq

protected instance Cauchy.has_add {α : Type u_1} [linear_ordered_field α] {β : Type u_2}
    [comm_ring β] {abv : β → α} [is_absolute_value abv] : Add Cauchy :=
  { add :=
      fun (x y : Cauchy) => quotient.lift_on₂ x y (fun (f g : cau_seq β abv) => mk (f + g)) sorry }

@[simp] theorem mk_add {α : Type u_1} [linear_ordered_field α] {β : Type u_2} [comm_ring β]
    {abv : β → α} [is_absolute_value abv] (f : cau_seq β abv) (g : cau_seq β abv) :
    mk f + mk g = mk (f + g) :=
  rfl

protected instance Cauchy.has_neg {α : Type u_1} [linear_ordered_field α] {β : Type u_2}
    [comm_ring β] {abv : β → α} [is_absolute_value abv] : Neg Cauchy :=
  { neg := fun (x : Cauchy) => quotient.lift_on x (fun (f : cau_seq β abv) => mk (-f)) sorry }

@[simp] theorem mk_neg {α : Type u_1} [linear_ordered_field α] {β : Type u_2} [comm_ring β]
    {abv : β → α} [is_absolute_value abv] (f : cau_seq β abv) : -mk f = mk (-f) :=
  rfl

protected instance Cauchy.has_mul {α : Type u_1} [linear_ordered_field α] {β : Type u_2}
    [comm_ring β] {abv : β → α} [is_absolute_value abv] : Mul Cauchy :=
  { mul :=
      fun (x y : Cauchy) => quotient.lift_on₂ x y (fun (f g : cau_seq β abv) => mk (f * g)) sorry }

@[simp] theorem mk_mul {α : Type u_1} [linear_ordered_field α] {β : Type u_2} [comm_ring β]
    {abv : β → α} [is_absolute_value abv] (f : cau_seq β abv) (g : cau_seq β abv) :
    mk f * mk g = mk (f * g) :=
  rfl

protected instance Cauchy.has_sub {α : Type u_1} [linear_ordered_field α] {β : Type u_2}
    [comm_ring β] {abv : β → α} [is_absolute_value abv] : Sub Cauchy :=
  { sub :=
      fun (x y : Cauchy) => quotient.lift_on₂ x y (fun (f g : cau_seq β abv) => mk (f - g)) sorry }

@[simp] theorem mk_sub {α : Type u_1} [linear_ordered_field α] {β : Type u_2} [comm_ring β]
    {abv : β → α} [is_absolute_value abv] (f : cau_seq β abv) (g : cau_seq β abv) :
    mk f - mk g = mk (f - g) :=
  rfl

theorem of_rat_add {α : Type u_1} [linear_ordered_field α] {β : Type u_2} [comm_ring β]
    {abv : β → α} [is_absolute_value abv] (x : β) (y : β) : of_rat (x + y) = of_rat x + of_rat y :=
  congr_arg mk (const_add x y)

theorem of_rat_neg {α : Type u_1} [linear_ordered_field α] {β : Type u_2} [comm_ring β]
    {abv : β → α} [is_absolute_value abv] (x : β) : of_rat (-x) = -of_rat x :=
  congr_arg mk (const_neg x)

theorem of_rat_mul {α : Type u_1} [linear_ordered_field α] {β : Type u_2} [comm_ring β]
    {abv : β → α} [is_absolute_value abv] (x : β) (y : β) : of_rat (x * y) = of_rat x * of_rat y :=
  congr_arg mk (const_mul x y)

protected instance Cauchy.comm_ring {α : Type u_1} [linear_ordered_field α] {β : Type u_2}
    [comm_ring β] {abv : β → α} [is_absolute_value abv] : comm_ring Cauchy :=
  comm_ring.mk Add.add sorry 0 sorry sorry Neg.neg Sub.sub sorry sorry Mul.mul sorry 1 sorry sorry
    sorry sorry sorry

theorem of_rat_sub {α : Type u_1} [linear_ordered_field α] {β : Type u_2} [comm_ring β]
    {abv : β → α} [is_absolute_value abv] (x : β) (y : β) : of_rat (x - y) = of_rat x - of_rat y :=
  congr_arg mk (const_sub x y)

protected instance Cauchy.has_inv {α : Type u_1} [linear_ordered_field α] {β : Type u_2} [field β]
    {abv : β → α} [is_absolute_value abv] : has_inv Cauchy :=
  has_inv.mk
    fun (x : Cauchy) =>
      quotient.lift_on x
        (fun (f : cau_seq β abv) =>
          mk (dite (lim_zero f) (fun (h : lim_zero f) => 0) fun (h : ¬lim_zero f) => inv f h))
        sorry

@[simp] theorem inv_zero {α : Type u_1} [linear_ordered_field α] {β : Type u_2} [field β]
    {abv : β → α} [is_absolute_value abv] : 0⁻¹ = 0 :=
  sorry

@[simp] theorem inv_mk {α : Type u_1} [linear_ordered_field α] {β : Type u_2} [field β]
    {abv : β → α} [is_absolute_value abv] {f : cau_seq β abv} (hf : ¬lim_zero f) :
    mk f⁻¹ = mk (inv f hf) :=
  sorry

theorem cau_seq_zero_ne_one {α : Type u_1} [linear_ordered_field α] {β : Type u_2} [field β]
    {abv : β → α} [is_absolute_value abv] : ¬0 ≈ 1 :=
  sorry

theorem zero_ne_one {α : Type u_1} [linear_ordered_field α] {β : Type u_2} [field β] {abv : β → α}
    [is_absolute_value abv] : 0 ≠ 1 :=
  fun (h : 0 = 1) => cau_seq_zero_ne_one (iff.mp mk_eq h)

protected theorem inv_mul_cancel {α : Type u_1} [linear_ordered_field α] {β : Type u_2} [field β]
    {abv : β → α} [is_absolute_value abv] {x : Cauchy} : x ≠ 0 → x⁻¹ * x = 1 :=
  sorry

def field {α : Type u_1} [linear_ordered_field α] {β : Type u_2} [field β] {abv : β → α}
    [is_absolute_value abv] : field Cauchy :=
  field.mk comm_ring.add sorry comm_ring.zero sorry sorry comm_ring.neg comm_ring.sub sorry sorry
    comm_ring.mul sorry comm_ring.one sorry sorry sorry sorry sorry has_inv.inv sorry sorry inv_zero

theorem of_rat_inv {α : Type u_1} [linear_ordered_field α] {β : Type u_2} [field β] {abv : β → α}
    [is_absolute_value abv] (x : β) : of_rat (x⁻¹) = (of_rat x⁻¹) :=
  sorry

theorem of_rat_div {α : Type u_1} [linear_ordered_field α] {β : Type u_2} [field β] {abv : β → α}
    [is_absolute_value abv] (x : β) (y : β) : of_rat (x / y) = of_rat x / of_rat y :=
  sorry

end cau_seq.completion

namespace cau_seq

class is_complete {α : Type u_1} [linear_ordered_field α] (β : Type u_2) [ring β] (abv : β → α)
    [is_absolute_value abv]
    where
  is_complete : ∀ (s : cau_seq β abv), ∃ (b : β), s ≈ const abv b

theorem complete {α : Type u_1} [linear_ordered_field α] {β : Type u_2} [ring β] {abv : β → α}
    [is_absolute_value abv] [is_complete β abv] (s : cau_seq β abv) : ∃ (b : β), s ≈ const abv b :=
  is_complete.is_complete

def lim {α : Type u_1} [linear_ordered_field α] {β : Type u_2} [ring β] {abv : β → α}
    [is_absolute_value abv] [is_complete β abv] (s : cau_seq β abv) : β :=
  classical.some (complete s)

theorem equiv_lim {α : Type u_1} [linear_ordered_field α] {β : Type u_2} [ring β] {abv : β → α}
    [is_absolute_value abv] [is_complete β abv] (s : cau_seq β abv) : s ≈ const abv (lim s) :=
  classical.some_spec (complete s)

theorem eq_lim_of_const_equiv {α : Type u_1} [linear_ordered_field α] {β : Type u_2} [ring β]
    {abv : β → α} [is_absolute_value abv] [is_complete β abv] {f : cau_seq β abv} {x : β}
    (h : const abv x ≈ f) : x = lim f :=
  iff.mp const_equiv (setoid.trans h (equiv_lim f))

theorem lim_eq_of_equiv_const {α : Type u_1} [linear_ordered_field α] {β : Type u_2} [ring β]
    {abv : β → α} [is_absolute_value abv] [is_complete β abv] {f : cau_seq β abv} {x : β}
    (h : f ≈ const abv x) : lim f = x :=
  Eq.symm (eq_lim_of_const_equiv (setoid.symm h))

theorem lim_eq_lim_of_equiv {α : Type u_1} [linear_ordered_field α] {β : Type u_2} [ring β]
    {abv : β → α} [is_absolute_value abv] [is_complete β abv] {f : cau_seq β abv}
    {g : cau_seq β abv} (h : f ≈ g) : lim f = lim g :=
  lim_eq_of_equiv_const (setoid.trans h (equiv_lim g))

@[simp] theorem lim_const {α : Type u_1} [linear_ordered_field α] {β : Type u_2} [ring β]
    {abv : β → α} [is_absolute_value abv] [is_complete β abv] (x : β) : lim (const abv x) = x :=
  lim_eq_of_equiv_const (setoid.refl (const abv x))

theorem lim_add {α : Type u_1} [linear_ordered_field α] {β : Type u_2} [ring β] {abv : β → α}
    [is_absolute_value abv] [is_complete β abv] (f : cau_seq β abv) (g : cau_seq β abv) :
    lim f + lim g = lim (f + g) :=
  sorry

theorem lim_mul_lim {α : Type u_1} [linear_ordered_field α] {β : Type u_2} [ring β] {abv : β → α}
    [is_absolute_value abv] [is_complete β abv] (f : cau_seq β abv) (g : cau_seq β abv) :
    lim f * lim g = lim (f * g) :=
  sorry

theorem lim_mul {α : Type u_1} [linear_ordered_field α] {β : Type u_2} [ring β] {abv : β → α}
    [is_absolute_value abv] [is_complete β abv] (f : cau_seq β abv) (x : β) :
    lim f * x = lim (f * const abv x) :=
  eq.mpr
    (id
      (Eq._oldrec (Eq.refl (lim f * x = lim (f * const abv x)))
        (Eq.symm (lim_mul_lim f (const abv x)))))
    (eq.mpr (id (Eq._oldrec (Eq.refl (lim f * x = lim f * lim (const abv x))) (lim_const x)))
      (Eq.refl (lim f * x)))

theorem lim_neg {α : Type u_1} [linear_ordered_field α] {β : Type u_2} [ring β] {abv : β → α}
    [is_absolute_value abv] [is_complete β abv] (f : cau_seq β abv) : lim (-f) = -lim f :=
  sorry

theorem lim_eq_zero_iff {α : Type u_1} [linear_ordered_field α] {β : Type u_2} [ring β]
    {abv : β → α} [is_absolute_value abv] [is_complete β abv] (f : cau_seq β abv) :
    lim f = 0 ↔ lim_zero f :=
  sorry

theorem lim_inv {α : Type u_1} [linear_ordered_field α] {β : Type u_2} [field β] {abv : β → α}
    [is_absolute_value abv] [is_complete β abv] {f : cau_seq β abv} (hf : ¬lim_zero f) :
    lim (inv f hf) = (lim f⁻¹) :=
  sorry

theorem lim_le {α : Type u_1} [linear_ordered_field α] [is_complete α abs] {f : cau_seq α abs}
    {x : α} (h : f ≤ const abs x) : lim f ≤ x :=
  iff.mp const_le (le_of_eq_of_le (setoid.symm (equiv_lim f)) h)

theorem le_lim {α : Type u_1} [linear_ordered_field α] [is_complete α abs] {f : cau_seq α abs}
    {x : α} (h : const abs x ≤ f) : x ≤ lim f :=
  iff.mp const_le (le_of_le_of_eq h (equiv_lim f))

theorem lt_lim {α : Type u_1} [linear_ordered_field α] [is_complete α abs] {f : cau_seq α abs}
    {x : α} (h : const abs x < f) : x < lim f :=
  iff.mp const_lt (lt_of_lt_of_eq h (equiv_lim f))

theorem lim_lt {α : Type u_1} [linear_ordered_field α] [is_complete α abs] {f : cau_seq α abs}
    {x : α} (h : f < const abs x) : lim f < x :=
  iff.mp const_lt (lt_of_eq_of_lt (setoid.symm (equiv_lim f)) h)

end Mathlib


/-
Copyright (c) 2022 Yaël Dillies. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Yaël Dillies, Yury Kudryashov
-/
import analysis.convex.strict
import analysis.convex.topology
import analysis.normed_space.ordered
import analysis.normed_space.pointwise

/-!
# Strictly convex spaces

This file defines strictly convex spaces. A normed space is strictly convex if all closed balls are
strictly convex. This does **not** mean that the norm is strictly convex (in fact, it never is).

## Main definitions

`strict_convex_space`: a typeclass saying that a given normed space over a normed linear ordered
field (e.g., `ℝ` or `ℚ`) is strictly convex. The definition requires strict convexity of a closed
ball of positive radius with center at the origin; strict convexity of any other closed ball follows
from this assumption.

## Main results

In a strictly convex space, we prove

- `strict_convex_closed_ball`: a closed ball is strictly convex.
- `combo_mem_ball_of_ne`, `open_segment_subset_ball_of_ne`, `norm_combo_lt_of_ne`:
  a nontrivial convex combination of two points in a closed ball belong to the corresponding open
  ball;
- `norm_add_lt_of_not_same_ray`, `same_ray_iff_norm_add`, `dist_add_dist_eq_iff`:
  the triangle inequality `dist x y + dist y z ≤ dist x z` is a strict inequality unless `y` belongs
  to the segment `[x -[ℝ] z]`.
- `isometry.affine_isometry_of_strict_convex_space`: an isometry of `normed_add_torsor`s for real
  normed spaces, strictly convex in the case of the codomain, is an affine isometry.

We also provide several lemmas that can be used as alternative constructors for `strict_convex ℝ E`:

- `strict_convex_space.of_strict_convex_closed_unit_ball`: if `closed_ball (0 : E) 1` is strictly
  convex, then `E` is a strictly convex space;

- `strict_convex_space.of_norm_add`: if `∥x + y∥ = ∥x∥ + ∥y∥` implies `same_ray ℝ x y` for all
  `x y : E`, then `E` is a strictly convex space.

## Implementation notes

While the definition is formulated for any normed linear ordered field, most of the lemmas are
formulated only for the case `𝕜 = ℝ`.

## Tags

convex, strictly convex
-/

open set metric
open_locale convex pointwise

/-- A *strictly convex space* is a normed space where the closed balls are strictly convex. We only
require balls of positive radius with center at the origin to be strictly convex in the definition,
then prove that any closed ball is strictly convex in `strict_convex_closed_ball` below.

See also `strict_convex_space.of_strict_convex_closed_unit_ball`. -/
class strict_convex_space (𝕜 E : Type*) [normed_linear_ordered_field 𝕜] [normed_group E]
  [normed_space 𝕜 E] : Prop :=
(strict_convex_closed_ball : ∀ r : ℝ, 0 < r → strict_convex 𝕜 (closed_ball (0 : E) r))

variables (𝕜 : Type*) {E : Type*} [normed_linear_ordered_field 𝕜]
  [normed_group E] [normed_space 𝕜 E]

/-- A closed ball in a strictly convex space is strictly convex. -/
lemma strict_convex_closed_ball [strict_convex_space 𝕜 E] (x : E) (r : ℝ) :
  strict_convex 𝕜 (closed_ball x r) :=
begin
  cases le_or_lt r 0 with hr hr,
  { exact (subsingleton_closed_ball x hr).strict_convex },
  rw ← vadd_closed_ball_zero,
  exact (strict_convex_space.strict_convex_closed_ball r hr).vadd _,
end

variables [normed_space ℝ E]

/-- A real normed vector space is strictly convex provided that the unit ball is strictly convex. -/
lemma strict_convex_space.of_strict_convex_closed_unit_ball
  [linear_map.compatible_smul E E 𝕜 ℝ] (h : strict_convex 𝕜 (closed_ball (0 : E) 1)) :
  strict_convex_space 𝕜 E :=
⟨λ r hr, by simpa only [smul_closed_unit_ball_of_nonneg hr.le] using h.smul r⟩

/-- If `∥x + y∥ = ∥x∥ + ∥y∥` implies that `x y : E` are in the same ray, then `E` is a strictly
convex space. -/
lemma strict_convex_space.of_norm_add (h : ∀ x y : E, ∥x + y∥ = ∥x∥ + ∥y∥ → same_ray ℝ x y) :
  strict_convex_space ℝ E :=
begin
  refine strict_convex_space.of_strict_convex_closed_unit_ball ℝ (λ x hx y hy hne a b ha hb hab, _),
  have hx' := hx, have hy' := hy,
  rw [← closure_closed_ball, closure_eq_interior_union_frontier,
    frontier_closed_ball (0 : E) one_ne_zero] at hx hy,
  cases hx, { exact (convex_closed_ball _ _).combo_interior_self_mem_interior hx hy' ha hb.le hab },
  cases hy, { exact (convex_closed_ball _ _).combo_self_interior_mem_interior hx' hy ha.le hb hab },
  rw [interior_closed_ball (0 : E) one_ne_zero, mem_ball_zero_iff],
  have hx₁ : ∥x∥ = 1, from mem_sphere_zero_iff_norm.1 hx,
  have hy₁ : ∥y∥ = 1, from mem_sphere_zero_iff_norm.1 hy,
  have ha' : ∥a∥ = a, from real.norm_of_nonneg ha.le,
  have hb' : ∥b∥ = b, from real.norm_of_nonneg hb.le,
  calc ∥a • x + b • y∥ < ∥a • x∥ + ∥b • y∥ : (norm_add_le _ _).lt_of_ne (λ H, hne _)
  ... = 1 : by simpa only [norm_smul, hx₁, hy₁, mul_one, ha', hb'],
  simpa only [norm_smul, hx₁, hy₁, ha', hb', mul_one, smul_comm a, smul_right_inj ha.ne',
    smul_right_inj hb.ne'] using (h _ _ H).norm_smul_eq.symm
end

lemma strict_convex_space.of_norm_add_lt_aux {a b c d : ℝ} (ha : 0 < a) (hab : a + b = 1)
  (hc : 0 < c) (hd : 0 < d) (hcd : c + d = 1) (hca : c ≤ a) {x y : E} (hy : ∥y∥ ≤ 1)
  (hxy : ∥a • x + b • y∥ < 1) :
  ∥c • x + d • y∥ < 1 :=
begin
  have hbd : b ≤ d,
  { refine le_of_add_le_add_left (hab.trans_le _),
    rw ←hcd,
    exact add_le_add_right hca _ },
  have h₁ : 0 < c / a := div_pos hc ha,
  have h₂ : 0 ≤ d - c / a * b,
  { rw [sub_nonneg, mul_comm_div, ←le_div_iff' hc],
    exact div_le_div hd.le hbd hc hca },
  calc ∥c • x + d • y∥ = ∥(c / a) • (a • x + b • y) + (d - c / a * b) • y∥
        : by rw [smul_add, ←mul_smul, ←mul_smul, div_mul_cancel _ ha.ne', sub_smul,
            add_add_sub_cancel]
    ... ≤ ∥(c / a) • (a • x + b • y)∥ + ∥(d - c / a * b) • y∥ : norm_add_le _ _
    ... = c / a * ∥a • x + b • y∥ + (d - c / a * b) * ∥y∥
        : by rw [norm_smul_of_nonneg h₁.le, norm_smul_of_nonneg h₂]
    ... < c / a * 1 + (d - c / a * b) * 1
        : add_lt_add_of_lt_of_le (mul_lt_mul_of_pos_left hxy h₁) (mul_le_mul_of_nonneg_left hy h₂)
    ... = 1 : begin
      nth_rewrite 0 ←hab,
      rw [mul_add, div_mul_cancel _ ha.ne', mul_one, add_add_sub_cancel, hcd],
    end,
end

/-- Strict convexity is equivalent to `∥a • x + b • y∥ < 1` for all `x` and `y` of norm at most `1`
and all strictly positive `a` and `b` such that `a + b = 1`. This shows that we only need to check
it for fixed `a` and `b`. -/
lemma strict_convex_space.of_norm_add_lt {a b : ℝ} (ha : 0 < a) (hb : 0 < b) (hab : a + b = 1)
  (h : ∀ x y : E, ∥x∥ ≤ 1 → ∥y∥ ≤ 1 → x ≠ y → ∥a • x + b • y∥ < 1) :
  strict_convex_space ℝ E :=
begin
  refine strict_convex_space.of_strict_convex_closed_unit_ball _ (λ x hx y hy hxy c d hc hd hcd, _),
  rw [interior_closed_ball (0 : E) one_ne_zero, mem_ball_zero_iff],
  rw mem_closed_ball_zero_iff at hx hy,
  obtain hca | hac := le_total c a,
  { exact strict_convex_space.of_norm_add_lt_aux ha hab hc hd hcd hca hy (h _ _ hx hy hxy) },
  rw add_comm at ⊢ hab hcd,
  refine strict_convex_space.of_norm_add_lt_aux hb hab hd hc hcd _ hx _,
  { refine le_of_add_le_add_right (hcd.trans_le _),
    rw ←hab,
    exact add_le_add_left hac _ },
  { rw add_comm,
    exact h _ _ hx hy hxy }
end

variables [strict_convex_space ℝ E] {x y z : E} {a b r : ℝ}

/-- If `x ≠ y` belong to the same closed ball, then a convex combination of `x` and `y` with
positive coefficients belongs to the corresponding open ball. -/
lemma combo_mem_ball_of_ne (hx : x ∈ closed_ball z r) (hy : y ∈ closed_ball z r) (hne : x ≠ y)
  (ha : 0 < a) (hb : 0 < b) (hab : a + b = 1) : a • x + b • y ∈ ball z r :=
begin
  rcases eq_or_ne r 0 with rfl|hr,
  { rw [closed_ball_zero, mem_singleton_iff] at hx hy,
    exact (hne (hx.trans hy.symm)).elim },
  { simp only [← interior_closed_ball _ hr] at hx hy ⊢,
    exact strict_convex_closed_ball ℝ z r hx hy hne ha hb hab }
end

/-- If `x ≠ y` belong to the same closed ball, then the open segment with endpoints `x` and `y` is
included in the corresponding open ball. -/
lemma open_segment_subset_ball_of_ne (hx : x ∈ closed_ball z r) (hy : y ∈ closed_ball z r)
  (hne : x ≠ y) : open_segment ℝ x y ⊆ ball z r :=
(open_segment_subset_iff _).2 $ λ a b, combo_mem_ball_of_ne hx hy hne

/-- If `x` and `y` are two distinct vectors of norm at most `r`, then a convex combination of `x`
and `y` with positive coefficients has norm strictly less than `r`. -/
lemma norm_combo_lt_of_ne (hx : ∥x∥ ≤ r) (hy : ∥y∥ ≤ r) (hne : x ≠ y) (ha : 0 < a) (hb : 0 < b)
  (hab : a + b = 1) : ∥a • x + b • y∥ < r :=
begin
  simp only [← mem_ball_zero_iff, ← mem_closed_ball_zero_iff] at hx hy ⊢,
  exact combo_mem_ball_of_ne hx hy hne ha hb hab
end

/-- In a strictly convex space, if `x` and `y` are not in the same ray, then `∥x + y∥ < ∥x∥ +
∥y∥`. -/
lemma norm_add_lt_of_not_same_ray (h : ¬same_ray ℝ x y) : ∥x + y∥ < ∥x∥ + ∥y∥ :=
begin
  simp only [same_ray_iff_inv_norm_smul_eq, not_or_distrib, ← ne.def] at h,
  rcases h with ⟨hx, hy, hne⟩,
  rw ← norm_pos_iff at hx hy,
  have hxy : 0 < ∥x∥ + ∥y∥ := add_pos hx hy,
  have := combo_mem_ball_of_ne (inv_norm_smul_mem_closed_unit_ball x)
    (inv_norm_smul_mem_closed_unit_ball y) hne (div_pos hx hxy) (div_pos hy hxy)
    (by rw [← add_div, div_self hxy.ne']),
  rwa [mem_ball_zero_iff, div_eq_inv_mul, div_eq_inv_mul, mul_smul, mul_smul,
    smul_inv_smul₀ hx.ne', smul_inv_smul₀ hy.ne', ← smul_add, norm_smul,
    real.norm_of_nonneg (inv_pos.2 hxy).le, ← div_eq_inv_mul, div_lt_one hxy] at this
end

lemma lt_norm_sub_of_not_same_ray (h : ¬same_ray ℝ x y) : ∥x∥ - ∥y∥ < ∥x - y∥ :=
begin
  nth_rewrite 0 ←sub_add_cancel x y at ⊢ h,
  exact sub_lt_iff_lt_add.2 (norm_add_lt_of_not_same_ray $ λ H', h $ H'.add_left same_ray.rfl),
end

lemma abs_lt_norm_sub_of_not_same_ray (h : ¬same_ray ℝ x y) : |∥x∥ - ∥y∥| < ∥x - y∥ :=
begin
  refine abs_sub_lt_iff.2 ⟨lt_norm_sub_of_not_same_ray h, _⟩,
  rw norm_sub_rev,
  exact lt_norm_sub_of_not_same_ray (mt same_ray.symm h),
end

/-- In a strictly convex space, two vectors `x`, `y` are in the same ray if and only if the triangle
inequality for `x` and `y` becomes an equality. -/
lemma same_ray_iff_norm_add : same_ray ℝ x y ↔ ∥x + y∥ = ∥x∥ + ∥y∥ :=
⟨same_ray.norm_add, λ h, not_not.1 $ λ h', (norm_add_lt_of_not_same_ray h').ne h⟩

/-- In a strictly convex space, two vectors `x`, `y` are not in the same ray if and only if the
triangle inequality for `x` and `y` is strict. -/
lemma not_same_ray_iff_norm_add_lt : ¬ same_ray ℝ x y ↔ ∥x + y∥ < ∥x∥ + ∥y∥ :=
same_ray_iff_norm_add.not.trans (norm_add_le _ _).lt_iff_ne.symm

lemma same_ray_iff_norm_sub : same_ray ℝ x y ↔ ∥x - y∥ = |∥x∥ - ∥y∥| :=
⟨same_ray.norm_sub, λ h, not_not.1 $ λ h', (abs_lt_norm_sub_of_not_same_ray h').ne' h⟩

lemma not_same_ray_iff_abs_lt_norm_sub : ¬ same_ray ℝ x y ↔ |∥x∥ - ∥y∥| < ∥x - y∥ :=
same_ray_iff_norm_sub.not.trans $ ne_comm.trans (abs_norm_sub_norm_le _ _).lt_iff_ne.symm

/-- In a strictly convex space, the triangle inequality turns into an equality if and only if the
middle point belongs to the segment joining two other points. -/
lemma dist_add_dist_eq_iff : dist x y + dist y z = dist x z ↔ y ∈ [x -[ℝ] z] :=
by simp only [mem_segment_iff_same_ray, same_ray_iff_norm_add, dist_eq_norm',
  sub_add_sub_cancel', eq_comm]

lemma norm_midpoint_lt_iff (h : ∥x∥ = ∥y∥) : ∥(1/2 : ℝ) • (x + y)∥ < ∥x∥ ↔ x ≠ y :=
by rw [norm_smul, real.norm_of_nonneg (one_div_nonneg.2 zero_le_two), ←inv_eq_one_div,
    ←div_eq_inv_mul, div_lt_iff (@zero_lt_two ℝ _ _), mul_two, ←not_same_ray_iff_of_norm_eq h,
    not_same_ray_iff_norm_add_lt, h]

variables {F : Type*} [normed_group F] [normed_space ℝ F]
variables {PF : Type*} {PE : Type*} [metric_space PF] [metric_space PE]
variables [normed_add_torsor F PF] [normed_add_torsor E PE]

include E

lemma eq_line_map_of_dist_eq_mul_of_dist_eq_mul {x y z : PE} (hxy : dist x y = r * dist x z)
  (hyz : dist y z = (1 - r) * dist x z) :
  y = affine_map.line_map x z r :=
begin
  have : y -ᵥ x ∈ [(0 : E) -[ℝ] z -ᵥ x],
  { rw [← dist_add_dist_eq_iff, dist_zero_left, dist_vsub_cancel_right, ← dist_eq_norm_vsub',
      ← dist_eq_norm_vsub', hxy, hyz, ← add_mul, add_sub_cancel'_right, one_mul] },
  rcases eq_or_ne x z with rfl|hne,
  { obtain rfl : y = x, by simpa,
    simp },
  { rw [← dist_ne_zero] at hne,
    rcases this with ⟨a, b, ha, hb, hab, H⟩,
    rw [smul_zero, zero_add] at H,
    have H' := congr_arg norm H,
    rw [norm_smul, real.norm_of_nonneg hb, ← dist_eq_norm_vsub', ← dist_eq_norm_vsub', hxy,
      mul_left_inj' hne] at H',
    rw [affine_map.line_map_apply, ← H', H, vsub_vadd] },
end

lemma eq_midpoint_of_dist_eq_half {x y z : PE} (hx : dist x y = dist x z / 2)
  (hy : dist y z = dist x z / 2) : y = midpoint ℝ x z :=
begin
  apply eq_line_map_of_dist_eq_mul_of_dist_eq_mul,
  { rwa [inv_of_eq_inv, ← div_eq_inv_mul] },
  { rwa [inv_of_eq_inv, ← one_div, sub_half, one_div, ← div_eq_inv_mul] }
end

namespace isometry

include F

/-- An isometry of `normed_add_torsor`s for real normed spaces, strictly convex in the case of
the codomain, is an affine isometry.  Unlike Mazur-Ulam, this does not require the isometry to
be surjective.  -/
noncomputable def affine_isometry_of_strict_convex_space {f : PF → PE} (hi : isometry f) :
  PF →ᵃⁱ[ℝ] PE :=
{ norm_map := λ x, by simp [affine_map.of_map_midpoint, ←dist_eq_norm_vsub E, hi.dist_eq],
  ..affine_map.of_map_midpoint f (λ x y, begin
    apply eq_midpoint_of_dist_eq_half,
    { rw [hi.dist_eq, hi.dist_eq, dist_left_midpoint, real.norm_of_nonneg zero_le_two,
        div_eq_inv_mul] },
    { rw [hi.dist_eq, hi.dist_eq, dist_midpoint_right, real.norm_of_nonneg zero_le_two,
        div_eq_inv_mul] },
  end) hi.continuous }

@[simp] lemma coe_affine_isometry_of_strict_convex_space {f : PF → PE} (hi : isometry f) :
  ⇑(hi.affine_isometry_of_strict_convex_space) = f :=
rfl

@[simp] lemma affine_isometry_of_strict_convex_space_apply {f : PF → PE} (hi : isometry f)
  (p : PF) :
  hi.affine_isometry_of_strict_convex_space p = f p :=
rfl

end isometry


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

! This file was ported from Lean 3 source module category_theory.limits.shapes.normal_mono.equalizers
! leanprover-community/mathlib commit 69c6a5a12d8a2b159f20933e60115a4f2de62b58
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.CategoryTheory.Limits.Shapes.NormalMono.Basic
import Mathbin.CategoryTheory.Limits.Shapes.FiniteProducts

/-!
# Normal mono categories with finite products and kernels have all equalizers.

> THIS FILE IS SYNCHRONIZED WITH MATHLIB4.
> Any changes to this file require a corresponding PR to mathlib4.

This, and the dual result, are used in the development of abelian categories.
-/

noncomputable section

open CategoryTheory

open CategoryTheory.Limits

variable {C : Type _} [Category C] [HasZeroMorphisms C]

namespace CategoryTheory.NormalMonoCategory

variable [HasFiniteProducts C] [HasKernels C] [NormalMonoCategory C]

/- ./././Mathport/Syntax/Translate/Command.lean:317:38: unsupported irreducible non-definition -/
#print CategoryTheory.NormalMonoCategory.pullback_of_mono /-
/-- The pullback of two monomorphisms exists. -/
irreducible_def pullback_of_mono {X Y Z : C} (a : X ⟶ Z) (b : Y ⟶ Z) [Mono a] [Mono b] :
  HasLimit (cospan a b) :=
  let ⟨P, f, haf, i⟩ := normalMonoOfMono a
  let ⟨Q, g, hbg, i'⟩ := normalMonoOfMono b
  let ⟨a', ha'⟩ :=
    KernelFork.IsLimit.lift' i (kernel.ι (prod.lift f g)) <|
      calc
        kernel.ι (prod.lift f g) ≫ f = kernel.ι (prod.lift f g) ≫ prod.lift f g ≫ Limits.prod.fst :=
          by rw [prod.lift_fst]
        _ = (0 : kernel (prod.lift f g) ⟶ P ⨯ Q) ≫ Limits.prod.fst := by rw [kernel.condition_assoc]
        _ = 0 := zero_comp

  let ⟨b', hb'⟩ :=
    KernelFork.IsLimit.lift' i' (kernel.ι (prod.lift f g)) <|
      calc
        kernel.ι (prod.lift f g) ≫ g = kernel.ι (prod.lift f g) ≫ prod.lift f g ≫ Limits.prod.snd :=
          by rw [prod.lift_snd]
        _ = (0 : kernel (prod.lift f g) ⟶ P ⨯ Q) ≫ Limits.prod.snd := by rw [kernel.condition_assoc]
        _ = 0 := zero_comp

  HasLimit.mk
    { Cone :=
        PullbackCone.mk a' b' <| by
          simp at ha' hb'
          rw [ha', hb']
      IsLimit :=
        PullbackCone.IsLimit.mk _
          (fun s =>
            kernel.lift (prod.lift f g) (PullbackCone.snd s ≫ b) <|
              prod.hom_ext
                (calc
                  ((PullbackCone.snd s ≫ b) ≫ prod.lift f g) ≫ Limits.prod.fst =
                      PullbackCone.snd s ≫ b ≫ f :=
                    by simp only [prod.lift_fst, category.assoc]
                  _ = PullbackCone.fst s ≫ a ≫ f := by rw [pullback_cone.condition_assoc]
                  _ = PullbackCone.fst s ≫ 0 := by rw [haf]
                  _ = 0 ≫ Limits.prod.fst := by rw [comp_zero, zero_comp]
                  )
                (calc
                  ((PullbackCone.snd s ≫ b) ≫ prod.lift f g) ≫ Limits.prod.snd =
                      PullbackCone.snd s ≫ b ≫ g :=
                    by simp only [prod.lift_snd, category.assoc]
                  _ = PullbackCone.snd s ≫ 0 := by rw [hbg]
                  _ = 0 ≫ Limits.prod.snd := by rw [comp_zero, zero_comp]
                  ))
          (fun s =>
            (cancel_mono a).1 <| by
              rw [kernel_fork.ι_of_ι] at ha'
              simp [ha', pullback_cone.condition s])
          (fun s =>
            (cancel_mono b).1 <| by
              rw [kernel_fork.ι_of_ι] at hb'
              simp [hb'])
          fun s m h₁ h₂ =>
          (cancel_mono (kernel.ι (prod.lift f g))).1 <|
            calc
              m ≫ kernel.ι (prod.lift f g) = m ≫ a' ≫ a :=
                by
                congr
                exact ha'.symm
              _ = PullbackCone.fst s ≫ a := by rw [← category.assoc, h₁]
              _ = PullbackCone.snd s ≫ b := (PullbackCone.condition s)
              _ =
                  kernel.lift (prod.lift f g) (PullbackCone.snd s ≫ b) _ ≫
                    kernel.ι (prod.lift f g) :=
                by rw [kernel.lift_ι]
               }
#align category_theory.normal_mono_category.pullback_of_mono CategoryTheory.NormalMonoCategory.pullback_of_mono
-/

section

attribute [local instance] pullback_of_mono

/-- The pullback of `(𝟙 X, f)` and `(𝟙 X, g)` -/
private abbrev P {X Y : C} (f g : X ⟶ Y) [Mono (prod.lift (𝟙 X) f)] [Mono (prod.lift (𝟙 X) g)] :
    C :=
  pullback (prod.lift (𝟙 X) f) (prod.lift (𝟙 X) g)
#align category_theory.normal_mono_category.P category_theory.normal_mono_category.P

/- ./././Mathport/Syntax/Translate/Command.lean:317:38: unsupported irreducible non-definition -/
#print CategoryTheory.NormalMonoCategory.hasLimit_parallelPair /-
/-- The equalizer of `f` and `g` exists. -/
irreducible_def hasLimit_parallelPair {X Y : C} (f g : X ⟶ Y) : HasLimit (parallelPair f g) :=
  have huv : (pullback.fst : p f g ⟶ X) = pullback.snd :=
    calc
      (pullback.fst : p f g ⟶ X) = pullback.fst ≫ 𝟙 _ := Eq.symm <| Category.comp_id _
      _ = pullback.fst ≫ prod.lift (𝟙 X) f ≫ Limits.prod.fst := by rw [prod.lift_fst]
      _ = pullback.snd ≫ prod.lift (𝟙 X) g ≫ Limits.prod.fst := by rw [pullback.condition_assoc]
      _ = pullback.snd := by rw [prod.lift_fst, category.comp_id]

  have hvu : (pullback.fst : p f g ⟶ X) ≫ f = pullback.snd ≫ g :=
    calc
      (pullback.fst : p f g ⟶ X) ≫ f = pullback.fst ≫ prod.lift (𝟙 X) f ≫ Limits.prod.snd := by
        rw [prod.lift_snd]
      _ = pullback.snd ≫ prod.lift (𝟙 X) g ≫ Limits.prod.snd := by rw [pullback.condition_assoc]
      _ = pullback.snd ≫ g := by rw [prod.lift_snd]

  have huu : (pullback.fst : p f g ⟶ X) ≫ f = pullback.fst ≫ g := by rw [hvu, ← huv]
  HasLimit.mk
    { Cone := Fork.ofι pullback.fst huu
      IsLimit :=
        Fork.IsLimit.mk _
          (fun s =>
            pullback.lift (Fork.ι s) (Fork.ι s) <|
              prod.hom_ext (by simp only [prod.lift_fst, category.assoc])
                (by simp only [prod.comp_lift, fork.condition]))
          (fun s => by simp only [fork.ι_of_ι, pullback.lift_fst]) fun s m h =>
          pullback.hom_ext (by simpa only [pullback.lift_fst] using h)
            (by simpa only [huv.symm, pullback.lift_fst] using h) }
#align category_theory.normal_mono_category.has_limit_parallel_pair CategoryTheory.NormalMonoCategory.hasLimit_parallelPair
-/

end

section

attribute [local instance] has_limit_parallel_pair

#print CategoryTheory.NormalMonoCategory.hasEqualizers /-
/-- A `normal_mono_category` category with finite products and kernels has all equalizers. -/
instance (priority := 100) hasEqualizers : HasEqualizers C :=
  hasEqualizers_of_hasLimit_parallelPair _
#align category_theory.normal_mono_category.has_equalizers CategoryTheory.NormalMonoCategory.hasEqualizers
-/

end

#print CategoryTheory.NormalMonoCategory.epi_of_zero_cokernel /-
/-- If a zero morphism is a cokernel of `f`, then `f` is an epimorphism. -/
theorem epi_of_zero_cokernel {X Y : C} (f : X ⟶ Y) (Z : C)
    (l : IsColimit (CokernelCofork.ofπ (0 : Y ⟶ Z) (show f ≫ 0 = 0 by simp))) : Epi f :=
  ⟨fun P u v huv =>
    by
    obtain ⟨W, w, hw, hl⟩ := normal_mono_of_mono (equalizer.ι u v)
    obtain ⟨m, hm⟩ := equalizer.lift' f huv
    have hwf : f ≫ w = 0 := by rw [← hm, category.assoc, hw, comp_zero]
    obtain ⟨n, hn⟩ := cokernel_cofork.is_colimit.desc' l _ hwf
    rw [cofork.π_of_π, zero_comp] at hn
    have : is_iso (equalizer.ι u v) := by apply is_iso_limit_cone_parallel_pair_of_eq hn.symm hl
    apply (cancel_epi (equalizer.ι u v)).1
    exact equalizer.condition _ _⟩
#align category_theory.normal_mono_category.epi_of_zero_cokernel CategoryTheory.NormalMonoCategory.epi_of_zero_cokernel
-/

section

variable [HasZeroObject C]

open ZeroObject

#print CategoryTheory.NormalMonoCategory.epi_of_zero_cancel /-
/-- If `f ≫ g = 0` implies `g = 0` for all `g`, then `g` is a monomorphism. -/
theorem epi_of_zero_cancel {X Y : C} (f : X ⟶ Y)
    (hf : ∀ (Z : C) (g : Y ⟶ Z) (hgf : f ≫ g = 0), g = 0) : Epi f :=
  epi_of_zero_cokernel f 0 <| zeroCokernelOfZeroCancel f hf
#align category_theory.normal_mono_category.epi_of_zero_cancel CategoryTheory.NormalMonoCategory.epi_of_zero_cancel
-/

end

end CategoryTheory.NormalMonoCategory

namespace CategoryTheory.NormalEpiCategory

variable [HasFiniteCoproducts C] [HasCokernels C] [NormalEpiCategory C]

/- ./././Mathport/Syntax/Translate/Command.lean:317:38: unsupported irreducible non-definition -/
#print CategoryTheory.NormalEpiCategory.pushout_of_epi /-
/-- The pushout of two epimorphisms exists. -/
irreducible_def pushout_of_epi {X Y Z : C} (a : X ⟶ Y) (b : X ⟶ Z) [Epi a] [Epi b] :
  HasColimit (span a b) :=
  let ⟨P, f, hfa, i⟩ := normalEpiOfEpi a
  let ⟨Q, g, hgb, i'⟩ := normalEpiOfEpi b
  let ⟨a', ha'⟩ :=
    CokernelCofork.IsColimit.desc' i (cokernel.π (coprod.desc f g)) <|
      calc
        f ≫ cokernel.π (coprod.desc f g) =
            coprod.inl ≫ coprod.desc f g ≫ cokernel.π (coprod.desc f g) :=
          by rw [coprod.inl_desc_assoc]
        _ = coprod.inl ≫ (0 : P ⨿ Q ⟶ cokernel (coprod.desc f g)) := by rw [cokernel.condition]
        _ = 0 := HasZeroMorphisms.comp_zero _ _

  let ⟨b', hb'⟩ :=
    CokernelCofork.IsColimit.desc' i' (cokernel.π (coprod.desc f g)) <|
      calc
        g ≫ cokernel.π (coprod.desc f g) =
            coprod.inr ≫ coprod.desc f g ≫ cokernel.π (coprod.desc f g) :=
          by rw [coprod.inr_desc_assoc]
        _ = coprod.inr ≫ (0 : P ⨿ Q ⟶ cokernel (coprod.desc f g)) := by rw [cokernel.condition]
        _ = 0 := HasZeroMorphisms.comp_zero _ _

  HasColimit.mk
    { Cocone :=
        PushoutCocone.mk a' b' <| by
          simp only [cofork.π_of_π] at ha' hb'
          rw [ha', hb']
      IsColimit :=
        PushoutCocone.IsColimit.mk _
          (fun s =>
            cokernel.desc (coprod.desc f g) (b ≫ PushoutCocone.inr s) <|
              coprod.hom_ext
                (calc
                  coprod.inl ≫ coprod.desc f g ≫ b ≫ PushoutCocone.inr s =
                      f ≫ b ≫ PushoutCocone.inr s :=
                    by rw [coprod.inl_desc_assoc]
                  _ = f ≫ a ≫ PushoutCocone.inl s := by rw [pushout_cocone.condition]
                  _ = 0 ≫ PushoutCocone.inl s := by rw [reassoc_of hfa]
                  _ = coprod.inl ≫ 0 := by rw [comp_zero, zero_comp]
                  )
                (calc
                  coprod.inr ≫ coprod.desc f g ≫ b ≫ PushoutCocone.inr s =
                      g ≫ b ≫ PushoutCocone.inr s :=
                    by rw [coprod.inr_desc_assoc]
                  _ = 0 ≫ PushoutCocone.inr s := by rw [reassoc_of hgb]
                  _ = coprod.inr ≫ 0 := by rw [comp_zero, zero_comp]
                  ))
          (fun s =>
            (cancel_epi a).1 <| by
              rw [cokernel_cofork.π_of_π] at ha'
              simp [reassoc_of ha', pushout_cocone.condition s])
          (fun s =>
            (cancel_epi b).1 <| by
              rw [cokernel_cofork.π_of_π] at hb'
              simp [reassoc_of hb'])
          fun s m h₁ h₂ =>
          (cancel_epi (cokernel.π (coprod.desc f g))).1 <|
            calc
              cokernel.π (coprod.desc f g) ≫ m = (a ≫ a') ≫ m :=
                by
                congr
                exact ha'.symm
              _ = a ≫ PushoutCocone.inl s := by rw [category.assoc, h₁]
              _ = b ≫ PushoutCocone.inr s := (PushoutCocone.condition s)
              _ =
                  cokernel.π (coprod.desc f g) ≫
                    cokernel.desc (coprod.desc f g) (b ≫ PushoutCocone.inr s) _ :=
                by rw [cokernel.π_desc]
               }
#align category_theory.normal_epi_category.pushout_of_epi CategoryTheory.NormalEpiCategory.pushout_of_epi
-/

section

attribute [local instance] pushout_of_epi

/-- The pushout of `(𝟙 Y, f)` and `(𝟙 Y, g)`. -/
private abbrev Q {X Y : C} (f g : X ⟶ Y) [Epi (coprod.desc (𝟙 Y) f)] [Epi (coprod.desc (𝟙 Y) g)] :
    C :=
  pushout (coprod.desc (𝟙 Y) f) (coprod.desc (𝟙 Y) g)
#align category_theory.normal_epi_category.Q category_theory.normal_epi_category.Q

/- ./././Mathport/Syntax/Translate/Command.lean:317:38: unsupported irreducible non-definition -/
#print CategoryTheory.NormalEpiCategory.hasColimit_parallelPair /-
/-- The coequalizer of `f` and `g` exists. -/
irreducible_def hasColimit_parallelPair {X Y : C} (f g : X ⟶ Y) : HasColimit (parallelPair f g) :=
  have huv : (pushout.inl : Y ⟶ q f g) = pushout.inr :=
    calc
      (pushout.inl : Y ⟶ q f g) = 𝟙 _ ≫ pushout.inl := Eq.symm <| Category.id_comp _
      _ = (coprod.inl ≫ coprod.desc (𝟙 Y) f) ≫ pushout.inl := by rw [coprod.inl_desc]
      _ = (coprod.inl ≫ coprod.desc (𝟙 Y) g) ≫ pushout.inr := by
        simp only [category.assoc, pushout.condition]
      _ = pushout.inr := by rw [coprod.inl_desc, category.id_comp]

  have hvu : f ≫ (pushout.inl : Y ⟶ q f g) = g ≫ pushout.inr :=
    calc
      f ≫ (pushout.inl : Y ⟶ q f g) = (coprod.inr ≫ coprod.desc (𝟙 Y) f) ≫ pushout.inl := by
        rw [coprod.inr_desc]
      _ = (coprod.inr ≫ coprod.desc (𝟙 Y) g) ≫ pushout.inr := by
        simp only [category.assoc, pushout.condition]
      _ = g ≫ pushout.inr := by rw [coprod.inr_desc]

  have huu : f ≫ (pushout.inl : Y ⟶ q f g) = g ≫ pushout.inl := by rw [hvu, huv]
  HasColimit.mk
    { Cocone := Cofork.ofπ pushout.inl huu
      IsColimit :=
        Cofork.IsColimit.mk _
          (fun s =>
            pushout.desc (Cofork.π s) (Cofork.π s) <|
              coprod.hom_ext (by simp only [coprod.inl_desc_assoc])
                (by simp only [coprod.desc_comp, cofork.condition]))
          (fun s => by simp only [pushout.inl_desc, cofork.π_of_π]) fun s m h =>
          pushout.hom_ext (by simpa only [pushout.inl_desc] using h)
            (by simpa only [huv.symm, pushout.inl_desc] using h) }
#align category_theory.normal_epi_category.has_colimit_parallel_pair CategoryTheory.NormalEpiCategory.hasColimit_parallelPair
-/

end

section

attribute [local instance] has_colimit_parallel_pair

#print CategoryTheory.NormalEpiCategory.hasCoequalizers /-
/-- A `normal_epi_category` category with finite coproducts and cokernels has all coequalizers. -/
instance (priority := 100) hasCoequalizers : HasCoequalizers C :=
  hasCoequalizers_of_hasColimit_parallelPair _
#align category_theory.normal_epi_category.has_coequalizers CategoryTheory.NormalEpiCategory.hasCoequalizers
-/

end

#print CategoryTheory.NormalEpiCategory.mono_of_zero_kernel /-
/-- If a zero morphism is a kernel of `f`, then `f` is a monomorphism. -/
theorem mono_of_zero_kernel {X Y : C} (f : X ⟶ Y) (Z : C)
    (l : IsLimit (KernelFork.ofι (0 : Z ⟶ X) (show 0 ≫ f = 0 by simp))) : Mono f :=
  ⟨fun P u v huv =>
    by
    obtain ⟨W, w, hw, hl⟩ := normal_epi_of_epi (coequalizer.π u v)
    obtain ⟨m, hm⟩ := coequalizer.desc' f huv
    have hwf : w ≫ f = 0 := by rw [← hm, reassoc_of hw, zero_comp]
    obtain ⟨n, hn⟩ := kernel_fork.is_limit.lift' l _ hwf
    rw [fork.ι_of_ι, has_zero_morphisms.comp_zero] at hn
    have : is_iso (coequalizer.π u v) := by
      apply is_iso_colimit_cocone_parallel_pair_of_eq hn.symm hl
    apply (cancel_mono (coequalizer.π u v)).1
    exact coequalizer.condition _ _⟩
#align category_theory.normal_epi_category.mono_of_zero_kernel CategoryTheory.NormalEpiCategory.mono_of_zero_kernel
-/

section

variable [HasZeroObject C]

open ZeroObject

#print CategoryTheory.NormalEpiCategory.mono_of_cancel_zero /-
/-- If `g ≫ f = 0` implies `g = 0` for all `g`, then `f` is a monomorphism. -/
theorem mono_of_cancel_zero {X Y : C} (f : X ⟶ Y)
    (hf : ∀ (Z : C) (g : Z ⟶ X) (hgf : g ≫ f = 0), g = 0) : Mono f :=
  mono_of_zero_kernel f 0 <| zeroKernelOfCancelZero f hf
#align category_theory.normal_epi_category.mono_of_cancel_zero CategoryTheory.NormalEpiCategory.mono_of_cancel_zero
-/

end

end CategoryTheory.NormalEpiCategory


example (a b : Nat) : 1 ≤ 2 :=
  have : 1 ≤ a + b := by rfl
  have : a + b ≤ b := by rfl
  have : b ≤ 2     := by rfl
  by decide

example (a b : Nat) : 1 ≤ 2 :=
calc
  1 ≤ a + b := by rfl
  _ ≤ b := by rfl
  _ ≤ 2 := by rfl


import .sqe .qfree

open list

lemma nqfree_map_unify {z} :
  ∀ {p : formula}, nqfree p → nqfree (p.map (atom.unify z))
| ⊤' h       := by unfold formula.map
| ⊥' h       := by unfold formula.map
| (A' _) h   := by unfold formula.map
| (p ∧' q) h :=
  begin
    unfold formula.map, cases h, constructor;
    apply nqfree_map_unify; assumption
  end
| (p ∨' q) h :=
  begin
    unfold formula.map, cases h, constructor;
    apply nqfree_map_unify; assumption
  end
| (¬' _) h   := by cases h
| (∃' _) h   := by unfold formula.map

lemma nqfree_unify :
  ∀ {p}, nqfree p → nqfree p.unify :=
begin
  intros p h, unfold formula.unify,
  apply and.intro, trivial,
  apply nqfree_map_unify h
end

lemma qfree_subst_of_qfree (i ks) :
  ∀ p, qfree p → qfree (subst i ks p)
| ⊤' h := by unfold subst
| ⊥' h := by unfold subst
| (A' a) h := by unfold subst
| (p ∧' q) h :=
  begin
    cases h with hp hq, apply and.intro,
    apply qfree_subst_of_qfree p hp,
    apply qfree_subst_of_qfree q hq
  end
| (p ∨' q) h :=
  begin
    cases h with hp hq, apply and.intro,
    apply qfree_subst_of_qfree p hp,
    apply qfree_subst_of_qfree q hq
  end
| (¬' p) h := qfree_subst_of_qfree p h
| (∃' p) h := by unfold subst

lemma qfree_inf_minus_of_qfree :
  ∀ p, qfree p → qfree (inf_minus p)
| ⊤' h := by trivial
| ⊥' h := by trivial
| (A' a) h :=
  begin
    cases a with k ks; try {trivial},
    cases ks with k' ks, trivial, simp [inf_minus],
    apply ite.rec; intro h, trivial,
    apply ite.rec; intro h; trivial
  end
| (p ∧' q) h :=
  begin
    cases h with h1 h2, apply cases_and_o; try {trivial};
    try {apply qfree_inf_minus_of_qfree, assumption},
    constructor; {apply qfree_inf_minus_of_qfree, assumption}
  end
| (p ∨' q) h :=
  begin
    cases h with h1 h2, apply cases_or_o; try {trivial};
    try {apply qfree_inf_minus_of_qfree, assumption},
    constructor; {apply qfree_inf_minus_of_qfree, assumption}
  end
| (¬' p) h := by assumption
| (∃' p) h := by assumption

lemma qfree_sqe_core : ∀ {φ}, nqfree φ → qfree (sqe_core φ) :=
begin
  intros p hp, simp [sqe_core, sqe_inf, sqe_bnd],
  apply qfree_or_o; apply qfree_disj,
 { intros q hq, rw mem_map at hq,
   cases hq with z hz, cases hz with hz1 hz2,
   subst hz2, apply qfree_subst_of_qfree,
   apply qfree_inf_minus_of_qfree,
   apply qfree_of_nqfree hp },
 { intros q hq, rw mem_map at hq,
   cases hq with z hz, cases hz with hz1 hz2,
   subst hz2, apply qfree_disj,
   intros a ha, rw mem_map at ha,
   cases ha with k hk, cases hk with hk1 hk2,
   subst hk2, apply qfree_subst_of_qfree,
   apply qfree_of_nqfree hp }
end

lemma qfree_sqe : ∀ {φ}, nqfree φ → qfree (sqe φ) :=
begin
  unfold sqe, intros p h, apply qfree_sqe_core,
  apply nqfree_unify, apply h
end


/-
Copyright (c) 2018 Robert Y. Lewis. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Author: Robert Y. Lewis
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.data.polynomial.algebra_map
import Mathlib.data.polynomial.div
import Mathlib.topology.metric_space.cau_seq_filter
import Mathlib.PostPort

universes u_1 u_2 u_3 u_4

namespace Mathlib

/-!
# Polynomials and limits

In this file we prove the following lemmas.

* `polynomial.continuous_eval₂: `polynomial.eval₂` defines a continuous function.
* `polynomial.continuous_aeval: `polynomial.aeval` defines a continuous function;
  we also prove convenience lemmas `polynomial.continuous_at_aeval`,
  `polynomial.continuous_within_at_aeval`, `polynomial.continuous_on_aeval`.
* `polynomial.continuous`:  `polynomial.eval` defines a continuous functions;
  we also prove convenience lemmas `polynomial.continuous_at`, `polynomial.continuous_within_at`,
  `polynomial.continuous_on`.
* `polynomial.tendsto_norm_at_top`: `λ x, ∥polynomial.eval (z x) p∥` tends to infinity provided that
  `λ x, ∥z x∥` tends to infinity and `0 < degree p`;
* `polynomial.tendsto_abv_eval₂_at_top`, `polynomial.tendsto_abv_at_top`,
  `polynomial.tendsto_abv_aeval_at_top`: a few versions of the previous statement for
  `is_absolute_value abv` instead of norm.

## Tags

polynomial, continuity
-/

namespace polynomial

protected theorem continuous_eval₂ {R : Type u_1} {S : Type u_2} [semiring R] [topological_space R]
    [topological_semiring R] [semiring S] (p : polynomial S) (f : S →+* R) :
    continuous fun (x : R) => eval₂ f x p :=
  id
    (continuous_finset_sum (finsupp.support p)
      fun (c : ℕ) (hc : c ∈ finsupp.support p) =>
        continuous.mul continuous_const (continuous_pow c))

protected theorem continuous {R : Type u_1} [semiring R] [topological_space R]
    [topological_semiring R] (p : polynomial R) : continuous fun (x : R) => eval x p :=
  polynomial.continuous_eval₂ p (ring_hom.id R)

protected theorem continuous_at {R : Type u_1} [semiring R] [topological_space R]
    [topological_semiring R] (p : polynomial R) {a : R} :
    continuous_at (fun (x : R) => eval x p) a :=
  continuous.continuous_at (polynomial.continuous p)

protected theorem continuous_within_at {R : Type u_1} [semiring R] [topological_space R]
    [topological_semiring R] (p : polynomial R) {s : set R} {a : R} :
    continuous_within_at (fun (x : R) => eval x p) s a :=
  continuous.continuous_within_at (polynomial.continuous p)

protected theorem continuous_on {R : Type u_1} [semiring R] [topological_space R]
    [topological_semiring R] (p : polynomial R) {s : set R} :
    continuous_on (fun (x : R) => eval x p) s :=
  continuous.continuous_on (polynomial.continuous p)

protected theorem continuous_aeval {R : Type u_1} {A : Type u_2} [comm_semiring R] [semiring A]
    [algebra R A] [topological_space A] [topological_semiring A] (p : polynomial R) :
    continuous fun (x : A) => coe_fn (aeval x) p :=
  polynomial.continuous_eval₂ p (algebra_map R A)

protected theorem continuous_at_aeval {R : Type u_1} {A : Type u_2} [comm_semiring R] [semiring A]
    [algebra R A] [topological_space A] [topological_semiring A] (p : polynomial R) {a : A} :
    continuous_at (fun (x : A) => coe_fn (aeval x) p) a :=
  continuous.continuous_at (polynomial.continuous_aeval p)

protected theorem continuous_within_at_aeval {R : Type u_1} {A : Type u_2} [comm_semiring R]
    [semiring A] [algebra R A] [topological_space A] [topological_semiring A] (p : polynomial R)
    {s : set A} {a : A} : continuous_within_at (fun (x : A) => coe_fn (aeval x) p) s a :=
  continuous.continuous_within_at (polynomial.continuous_aeval p)

protected theorem continuous_on_aeval {R : Type u_1} {A : Type u_2} [comm_semiring R] [semiring A]
    [algebra R A] [topological_space A] [topological_semiring A] (p : polynomial R) {s : set A} :
    continuous_on (fun (x : A) => coe_fn (aeval x) p) s :=
  continuous.continuous_on (polynomial.continuous_aeval p)

theorem tendsto_abv_eval₂_at_top {R : Type u_1} {S : Type u_2} {k : Type u_3} {α : Type u_4}
    [semiring R] [ring S] [linear_ordered_field k] (f : R →+* S) (abv : S → k)
    [is_absolute_value abv] (p : polynomial R) (hd : 0 < degree p)
    (hf : coe_fn f (leading_coeff p) ≠ 0) {l : filter α} {z : α → S}
    (hz : filter.tendsto (abv ∘ z) l filter.at_top) :
    filter.tendsto (fun (x : α) => abv (eval₂ f (z x) p)) l filter.at_top :=
  sorry

theorem tendsto_abv_at_top {R : Type u_1} {k : Type u_2} {α : Type u_3} [ring R]
    [linear_ordered_field k] (abv : R → k) [is_absolute_value abv] (p : polynomial R)
    (h : 0 < degree p) {l : filter α} {z : α → R} (hz : filter.tendsto (abv ∘ z) l filter.at_top) :
    filter.tendsto (fun (x : α) => abv (eval (z x) p)) l filter.at_top :=
  tendsto_abv_eval₂_at_top (ring_hom.id R) abv p h
    (mt (iff.mp leading_coeff_eq_zero) (ne_zero_of_degree_gt h)) hz

theorem tendsto_abv_aeval_at_top {R : Type u_1} {A : Type u_2} {k : Type u_3} {α : Type u_4}
    [comm_semiring R] [ring A] [algebra R A] [linear_ordered_field k] (abv : A → k)
    [is_absolute_value abv] (p : polynomial R) (hd : 0 < degree p)
    (h₀ : coe_fn (algebra_map R A) (leading_coeff p) ≠ 0) {l : filter α} {z : α → A}
    (hz : filter.tendsto (abv ∘ z) l filter.at_top) :
    filter.tendsto (fun (x : α) => abv (coe_fn (aeval (z x)) p)) l filter.at_top :=
  tendsto_abv_eval₂_at_top (algebra_map R A) abv p hd h₀ hz

theorem tendsto_norm_at_top {α : Type u_1} {R : Type u_2} [normed_ring R] [is_absolute_value norm]
    (p : polynomial R) (h : 0 < degree p) {l : filter α} {z : α → R}
    (hz : filter.tendsto (fun (x : α) => norm (z x)) l filter.at_top) :
    filter.tendsto (fun (x : α) => norm (eval (z x) p)) l filter.at_top :=
  tendsto_abv_at_top norm p h hz

theorem exists_forall_norm_le {R : Type u_2} [normed_ring R] [is_absolute_value norm]
    [proper_space R] (p : polynomial R) : ∃ (x : R), ∀ (y : R), norm (eval x p) ≤ norm (eval y p) :=
  sorry

end Mathlib


/- For an introduction to the tactic system, let's write a reflective
   tactic that solves goals in intuitionistic propositional logic.
-/

reserve infixl ` ⊢ `:25
reserve infixl ` & `:70

universes u v

inductive rlist (A : Type u) : Type u
| nil {} : rlist
| snoc {} : rlist → A → rlist

infix & := rlist.snoc

namespace rlist

def map {A : Type u} {B : Type v} (f : A → B) : rlist A → rlist B
| nil := nil
| (xs & x) := map xs & f x

inductive mem {A : Type u} : A → rlist A → Prop
| here : ∀ x xs, mem x (xs & x)
| there : ∀ x y ys, mem x ys → mem x (ys & y)

instance has_mem (A : Type u) : has_mem A (rlist A)
:= ⟨ mem ⟩

instance mem_decidable (A : Type u) [decidable_eq A]
  (x : A) (xs : rlist A) : decidable (x ∈ xs)
:= begin
induction xs,
{ apply decidable.is_false, intros contra, cases contra, },
{ induction ih_1,
  { apply (if H : x = a_1 then _ else _),
    subst a_1, apply decidable.is_true, constructor,
    apply decidable.is_false, intros contra,
    cases contra, cc, apply a_2, assumption,
  },
  { apply decidable.is_true, constructor, assumption }
}
end

lemma map_mem {A : Type u} {B : Type v} (f : A → B) (x : A)
  (xs : rlist A)
  (H : x ∈ xs) : f x ∈ xs.map f
:= begin
induction H; dsimp [map], constructor, constructor, assumption,
end

end rlist

namespace sequent

def conjunction  : rlist Prop → Prop
| rlist.nil := true
| (Ps & P) := conjunction Ps ∧ P

def entails (Γ : rlist Prop) (A : Prop)
  := conjunction Γ → A

infix ⊢ := entails

def assumption {Γ : rlist Prop} {P : Prop} (H : P ∈ Γ)
  : Γ ⊢ P
:= begin
unfold entails,
induction H; dsimp [conjunction],
{ intros H, induction H, assumption },
{ intros H, induction H, apply ih_1, assumption, }
end

def intro {Γ : rlist Prop} {P Q : Prop}
  (H : (Γ & P) ⊢ Q)
     : Γ ⊢ (P → Q)
:= begin
dsimp [entails, conjunction] at H,
intros H1 H2, apply H, split; assumption,
end

def revert {Γ : rlist Prop} {P Q : Prop}
  (H : Γ ⊢ (P → Q))
  : Γ & P ⊢ Q
:= begin
dsimp [entails, conjunction],
intros H', induction H', apply H; assumption
end

def entails_top {Γ : rlist Prop}
  : Γ ⊢ true
:= begin
simp [entails],
end

def split {Γ : rlist Prop} {P Q : Prop}
  (HP : Γ ⊢ P)
  (HQ : Γ ⊢ Q)
  : Γ ⊢ P ∧ Q
:= begin
dsimp [entails] at *,
intros, split, apply HP, assumption,
apply HQ, assumption,
end

def left {Γ : rlist Prop} {P Q : Prop}
  (HP : Γ ⊢ P)
  : Γ ⊢ P ∨ Q
:= begin
dsimp [entails] at *,
intros, left, apply HP, assumption,
end

def right {Γ : rlist Prop} {P Q : Prop}
  (HP : Γ ⊢ Q)
  : Γ ⊢ P ∨ Q
:= begin
dsimp [entails] at *,
intros, right, apply HP, assumption,
end

def apply_lemma_conj {Γ Δ : rlist Prop} {P : Prop}
   (H : Δ ⊢ P)
   (Hassumptions : Γ ⊢ conjunction Δ)
   : Γ ⊢ P
:= begin
intros H1, apply H, apply Hassumptions,
assumption,
end

def prove_conjunction_helper (Γ : rlist Prop)
  : rlist Prop → Prop
| rlist.nil := true
| (xs & x) := prove_conjunction_helper xs ∧ (Γ ⊢ x)

def prove_conjunction {Γ Δ : rlist Prop}
  (H : prove_conjunction_helper Γ Δ)
  : Γ ⊢ conjunction Δ
:= begin
induction Δ;
  dsimp [prove_conjunction_helper] at H;
  dsimp [conjunction],
apply entails_top, induction H with H1 H2,
apply split, apply ih_1, assumption, assumption,
end

def apply_lemma (Γ : rlist Prop) (P : Prop)
   {Δ : rlist Prop}
   (H : Δ ⊢ P)
   (Hassumptions : prove_conjunction_helper Γ Δ)
   : Γ ⊢ P
:= begin
apply apply_lemma_conj, assumption,
apply prove_conjunction, assumption,
end

def cut (Γ : rlist Prop) (Q : Prop) (P : Prop)
  (HP : Γ ⊢ P)
  (H : Γ & P ⊢ Q)
  : Γ ⊢ Q
:= begin
apply apply_lemma_conj H,
dsimp [conjunction], apply split,
intros H', assumption, assumption
end

inductive formula (vTy : Type) : Type
| var {} : vTy → formula
| top {} : formula
| bot {} : formula
| and {} : formula → formula → formula
| or {} : formula → formula → formula

namespace formula
def interp{vTy : Type} (ctxt : vTy → Prop)
  : formula vTy → Prop
| (var x) := ctxt x
| top := true
| bot := false
| (and P Q) := interp P ∧ interp Q
| (or P Q) := interp P ∨ interp Q
end formula

instance formula_decidable_eq {vTy : Type}
  [decidable_eq vTy] : decidable_eq (formula vTy)
  := by tactic.mk_dec_eq_instance

/-- Formula entailment holds if the entailment would
    be true in all possible contexts (variable assignments).
-/
def formula_entails {vTy : Type}
  (Γ : rlist (formula vTy)) (A : formula vTy)
  := ∀ ctxt, Γ.map (formula.interp ctxt) ⊢ A.interp ctxt

def interp_impl {vTy : Type}
  (Γ : rlist (formula vTy)) (A : formula vTy) (ctxt : vTy → Prop)
  : formula_entails Γ A → Γ.map (formula.interp ctxt) ⊢ A.interp ctxt
:= begin
intros H, apply H,
end

def formula_entails_auto {vTy : Type}
  [decidable_eq vTy]
  (Γ : rlist (formula vTy))
  : ∀ A : formula vTy, option (plift (formula_entails Γ A))
| formula.top := some (plift.up
  begin
  dsimp [formula_entails, formula.interp], intros ctxt,
  apply entails_top,
   end)
| formula.bot := none
| (formula.and P Q) := do
  plift.up HP ← formula_entails_auto P,
  plift.up HQ ← formula_entails_auto Q,
  some (plift.up begin
  unfold formula_entails, intros,
  dsimp [formula.interp],
  apply split, apply HP, apply HQ,
  end)
| (formula.or P Q) := (do
  plift.up HP ← formula_entails_auto P,
  some (plift.up (begin
     intros x, dsimp [formula.interp],
     apply left, apply HP
     end)))
  <|>
  (do
  plift.up HQ ← formula_entails_auto Q,
  some (plift.up (begin
     intros x, dsimp [formula.interp],
     apply right, apply HQ
     end)))
| x := if H : x ∈ Γ then some (plift.up begin
     intros ctxt, apply assumption,
     apply rlist.map_mem, assumption
  end) else none

meta def intern_var (xs : list expr) (e : expr) : list expr × ℕ
  := (if e ∈ xs then xs else xs ++ [e], xs.index_of e)

meta def reify_helper
  : list expr → expr → tactic (expr ff × list expr)
| xs `(true) := pure (``(formula.top), xs)
| xs `(false) := pure (``(formula.bot), xs)
| xs `(%%P ∧ %%Q) := do
    (P', xs') ← reify_helper xs P,
    (Q', xs'') ← reify_helper xs' Q,
    pure (``(formula.and %%P' %%Q'), xs'')
| xs `(%%P ∨ %%Q) := do
    (P', xs') ← reify_helper xs P,
    (Q', xs'') ← reify_helper xs' Q,
    pure (``(formula.or %%P' %%Q'), xs'')
| xs P := let (xs', n) := intern_var xs P in pure (``(formula.var %%(n.reflect)), xs')

meta def reify_all_helper (e : expr)
  : list expr → list expr → tactic (list (expr ff) × expr ff × list expr)
| ctxt [] := do
  (e', ctxt') ← reify_helper ctxt e,
  pure ([], e', ctxt')
| ctxt (x :: xs) := do
  (x', ctxt') ← reify_helper ctxt x,
  (xs', e', ctxt'') ← reify_all_helper ctxt' xs,
  pure (x' :: xs', e', ctxt'')

meta def reify (es : list expr) (e : expr)
  : tactic (list (expr ff) × expr ff × list expr)
  := reify_all_helper e [] es

end sequent

namespace tactic.interactive
namespace sequent

open tactic lean.parser
open interactive interactive.types

meta def get_rlist : expr → tactic (list expr)
| `(rlist.snoc %%xs %%x) := do
   xs' ← get_rlist xs,
   pure (x :: xs')
| `(rlist.nil) := pure []
| _ := tactic.fail "Expression is not an rlist"

meta def make_list : list expr → expr ff
| [] := ``(list.nil)
| (x :: xs) := ``(list.cons %%x %%(make_list xs))

meta def make_rlist : list (expr ff) → expr ff
| [] := ``(rlist.nil)
| (x :: xs) := ``(rlist.snoc %%(make_rlist xs) %%x)

def list.nth_def (xs : list Prop) (default : Prop) (n : ℕ) : Prop
:= match xs.nth n with
| (some x) := x
| none := default
end

meta def on_sequent_goal {A} (f : expr → expr → tactic A)
  : tactic A := do
  tgt ← target,
  tgt' ← instantiate_mvars tgt,
  match tgt' with
  | `(%%Γ ⊢ %%P) := f Γ P
  | _ := tactic.fail "goal is not a logical entailment"
  end

meta def reify_goal : tactic unit :=
  on_sequent_goal $ λ Γ P, do
    Γ' ← get_rlist Γ,
    (Γ'', P', ctxt) ← sequent.reify Γ' P,
    let ctxt' := make_list ctxt,
    Γ''' ← i_to_expr (make_rlist Γ''),
    P'' ← i_to_expr P',
    ctxtf ← i_to_expr ``(list.nth_def %%ctxt' false),
    e ← i_to_expr ``(sequent.interp_impl %%Γ''' %%P'' %%ctxtf),
    tactic.apply e

meta def entails_tactic (e : parse texpr) : tactic unit := do
  tgt ← target,
  tgt' ← instantiate_mvars tgt,
  match tgt' with
  | `(sequent.formula_entails %%Γ %%A) := do
    e' ← i_to_expr ``(%%e %%Γ %%A) >>= whnf,
    match e' with
    | `(some (plift.up %%x)) := tactic.apply x
    | _ := tactic.fail "Reflective tactic didn't return `some`"
    end
  | _ := tactic.fail "Goal is not a formula entailment"
  end

meta def intros := repeat (apply ``(sequent.intro _))
meta def revert := apply ``(sequent.revert _)
meta def left := apply ``(sequent.left _)
meta def right := apply ``(sequent.right _)
meta def split := apply ``(sequent.split _ _)
meta def prove_mem :=
  apply ``(rlist.mem.here) <|> (do apply ``(rlist.mem.there), prove_mem)
meta def assumption := do
  apply ``(sequent.assumption _),
  prove_mem
meta def apply (e : parse texpr) := do
  on_sequent_goal $ λ Γ P, do
    tactic.interactive.apply ``(sequent.apply_lemma %%Γ %%P %%e),
    repeat tactic.constructor

meta def assert (e : parse texpr) := do
  on_sequent_goal $ λ Γ P, do
    tactic.interactive.apply ``(sequent.cut %%Γ %%P %%e)

end sequent
end tactic.interactive

/- examples -/

lemma example1 {A B C D : Prop}
  (H : rlist.nil & A & B & A & C ⊢ D)
  : rlist.nil & A & B & C ⊢ D
:= begin
sequent.apply H; sequent.assumption
end

lemma example2 {P Q R : Prop} :
  rlist.nil & P & Q ⊢ (R ∧ P) ∨ (Q ∧ P)
:= begin
sequent.right, sequent.split, sequent.assumption,
sequent.assumption,
end

lemma example3 {P Q R : Prop} :
 rlist.nil & P & Q ⊢ (R ∧ P) ∨ (Q ∧ P)
:= begin
sequent.reify_goal, sequent.entails_tactic sequent.formula_entails_auto,
end