/-
Copyright (c) 2018 Sébastien Gouëzel. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Sébastien Gouëzel
-/
import order.bounds
import data.set.intervals.basic
import data.set.finite
import data.set.lattice

/-!
# Theory of conditionally complete lattices.

A conditionally complete lattice is a lattice in which every non-empty bounded subset s
has a least upper bound and a greatest lower bound, denoted below by Sup s and Inf s.
Typical examples are real, nat, int with their usual orders.

The theory is very comparable to the theory of complete lattices, except that suitable
boundedness and nonemptiness assumptions have to be added to most statements.
We introduce two predicates bdd_above and bdd_below to express this boundedness, prove
their basic properties, and then go on to prove most useful properties of Sup and Inf
in conditionally complete lattices.

To differentiate the statements between complete lattices and conditionally complete
lattices, we prefix Inf and Sup in the statements by c, giving cInf and cSup. For instance,
Inf_le is a statement in complete lattices ensuring Inf s ≤ x, while cInf_le is the same
statement in conditionally complete lattices with an additional assumption that s is
bounded below.
-/

set_option old_structure_cmd true

open function order_dual set

variables {α β γ : Type*} {ι : Sort*}

section

/-!
Extension of Sup and Inf from a preorder `α` to `with_top α` and `with_bot α`
-/

open_locale classical

noncomputable instance {α : Type*} [preorder α] [has_Sup α] : has_Sup (with_top α) :=
⟨λ S, if ⊤ ∈ S then ⊤ else
  if bdd_above (coe ⁻¹' S : set α) then ↑(Sup (coe ⁻¹' S : set α)) else ⊤⟩

noncomputable instance {α : Type*} [has_Inf α] : has_Inf (with_top α) :=
⟨λ S, if S ⊆ {⊤} then ⊤ else ↑(Inf (coe ⁻¹' S : set α))⟩

noncomputable instance {α : Type*} [has_Sup α] : has_Sup (with_bot α) :=
⟨(@with_top.has_Inf αᵒᵈ _).Inf⟩

noncomputable instance {α : Type*} [preorder α] [has_Inf α] : has_Inf (with_bot α) :=
⟨(@with_top.has_Sup αᵒᵈ _ _).Sup⟩

@[simp]
theorem with_top.cInf_empty {α : Type*} [has_Inf α] : Inf (∅ : set (with_top α)) = ⊤ :=
if_pos $ set.empty_subset _

@[simp]
theorem with_bot.cSup_empty {α : Type*} [has_Sup α] : Sup (∅ : set (with_bot α)) = ⊥ :=
if_pos $ set.empty_subset _

end -- section

/-- A conditionally complete lattice is a lattice in which
every nonempty subset which is bounded above has a supremum, and
every nonempty subset which is bounded below has an infimum.
Typical examples are real numbers or natural numbers.

To differentiate the statements from the corresponding statements in (unconditional)
complete lattices, we prefix Inf and Sup by a c everywhere. The same statements should
hold in both worlds, sometimes with additional assumptions of nonemptiness or
boundedness.-/
class conditionally_complete_lattice (α : Type*) extends lattice α, has_Sup α, has_Inf α :=
(le_cSup : ∀ s a, bdd_above s → a ∈ s → a ≤ Sup s)
(cSup_le : ∀ s a, set.nonempty s → a ∈ upper_bounds s → Sup s ≤ a)
(cInf_le : ∀ s a, bdd_below s → a ∈ s → Inf s ≤ a)
(le_cInf : ∀ s a, set.nonempty s → a ∈ lower_bounds s → a ≤ Inf s)

/-- A conditionally complete linear order is a linear order in which
every nonempty subset which is bounded above has a supremum, and
every nonempty subset which is bounded below has an infimum.
Typical examples are real numbers or natural numbers.

To differentiate the statements from the corresponding statements in (unconditional)
complete linear orders, we prefix Inf and Sup by a c everywhere. The same statements should
hold in both worlds, sometimes with additional assumptions of nonemptiness or
boundedness.-/
class conditionally_complete_linear_order (α : Type*)
  extends conditionally_complete_lattice α, linear_order α renaming max → sup min → inf

/-- A conditionally complete linear order with `bot` is a linear order with least element, in which
every nonempty subset which is bounded above has a supremum, and every nonempty subset (necessarily
bounded below) has an infimum.  A typical example is the natural numbers.

To differentiate the statements from the corresponding statements in (unconditional)
complete linear orders, we prefix Inf and Sup by a c everywhere. The same statements should
hold in both worlds, sometimes with additional assumptions of nonemptiness or
boundedness.-/
@[ancestor conditionally_complete_linear_order has_bot]
class conditionally_complete_linear_order_bot (α : Type*)
  extends conditionally_complete_linear_order α, has_bot α :=
(bot_le : ∀ x : α, ⊥ ≤ x)
(cSup_empty : Sup ∅ = ⊥)

@[priority 100]  -- see Note [lower instance priority]
instance conditionally_complete_linear_order_bot.to_order_bot
  [h : conditionally_complete_linear_order_bot α] : order_bot α :=
{ ..h }

/-- A complete lattice is a conditionally complete lattice, as there are no restrictions
on the properties of Inf and Sup in a complete lattice.-/
@[priority 100] -- see Note [lower instance priority]
instance complete_lattice.to_conditionally_complete_lattice [complete_lattice α] :
  conditionally_complete_lattice α :=
{ le_cSup := by intros; apply le_Sup; assumption,
  cSup_le := by intros; apply Sup_le; assumption,
  cInf_le := by intros; apply Inf_le; assumption,
  le_cInf := by intros; apply le_Inf; assumption,
  ..‹complete_lattice α› }

@[priority 100] -- see Note [lower instance priority]
instance complete_linear_order.to_conditionally_complete_linear_order_bot {α : Type*}
  [complete_linear_order α] :
  conditionally_complete_linear_order_bot α :=
{ cSup_empty := Sup_empty,
  ..complete_lattice.to_conditionally_complete_lattice, .. ‹complete_linear_order α› }

section
open_locale classical

/-- A well founded linear order is conditionally complete, with a bottom element. -/
@[reducible] noncomputable def is_well_order.conditionally_complete_linear_order_bot
  (α : Type*) [i₁ : linear_order α] [i₂ : order_bot α] [h : is_well_order α (<)] :
  conditionally_complete_linear_order_bot α :=
{ Inf := λ s, if hs : s.nonempty then h.wf.min s hs else ⊥,
  cInf_le := λ s a hs has, begin
    have s_ne : s.nonempty := ⟨a, has⟩,
    simpa [s_ne] using not_lt.1 (h.wf.not_lt_min s s_ne has),
  end,
  le_cInf := λ s a hs has, begin
    simp only [hs, dif_pos],
    exact has (h.wf.min_mem s hs),
  end,
  Sup := λ s, if hs : (upper_bounds s).nonempty then h.wf.min _ hs else ⊥,
  le_cSup := λ s a hs has, begin
    have h's : (upper_bounds s).nonempty := hs,
    simp only [h's, dif_pos],
    exact h.wf.min_mem _ h's has,
  end,
  cSup_le := λ s a hs has, begin
    have h's : (upper_bounds s).nonempty := ⟨a, has⟩,
    simp only [h's, dif_pos],
    simpa using h.wf.not_lt_min _ h's has,
  end,
  cSup_empty := by simpa using eq_bot_iff.2 (not_lt.1 $ h.wf.not_lt_min _ _ $ mem_univ ⊥),
  ..i₁, ..i₂, ..linear_order.to_lattice }

end

section order_dual

instance (α : Type*) [conditionally_complete_lattice α] : conditionally_complete_lattice αᵒᵈ :=
{ le_cSup := @conditionally_complete_lattice.cInf_le α _,
  cSup_le := @conditionally_complete_lattice.le_cInf α _,
  le_cInf := @conditionally_complete_lattice.cSup_le α _,
  cInf_le := @conditionally_complete_lattice.le_cSup α _,
  ..order_dual.has_Inf α,
  ..order_dual.has_Sup α,
  ..order_dual.lattice α }

instance (α : Type*) [conditionally_complete_linear_order α] :
  conditionally_complete_linear_order αᵒᵈ :=
{ ..order_dual.conditionally_complete_lattice α,
  ..order_dual.linear_order α }

end order_dual

section conditionally_complete_lattice
variables [conditionally_complete_lattice α] {s t : set α} {a b : α}

theorem le_cSup (h₁ : bdd_above s) (h₂ : a ∈ s) : a ≤ Sup s :=
conditionally_complete_lattice.le_cSup s a h₁ h₂

theorem cSup_le (h₁ : s.nonempty) (h₂ : ∀ b ∈ s, b ≤ a) : Sup s ≤ a :=
conditionally_complete_lattice.cSup_le s a h₁ h₂

theorem cInf_le (h₁ : bdd_below s) (h₂ : a ∈ s) : Inf s ≤ a :=
conditionally_complete_lattice.cInf_le s a h₁ h₂

theorem le_cInf (h₁ : s.nonempty) (h₂ : ∀ b ∈ s, a ≤ b) : a ≤ Inf s :=
conditionally_complete_lattice.le_cInf s a h₁ h₂

theorem le_cSup_of_le (hs : bdd_above s) (hb : b ∈ s) (h : a ≤ b) : a ≤ Sup s :=
le_trans h (le_cSup hs hb)

theorem cInf_le_of_le (hs : bdd_below s) (hb : b ∈ s) (h : b ≤ a) : Inf s ≤ a :=
le_trans (cInf_le hs hb) h

theorem cSup_le_cSup (ht : bdd_above t) (hs : s.nonempty) (h : s ⊆ t) : Sup s ≤ Sup t :=
cSup_le hs (λ a ha, le_cSup ht (h ha))

theorem cInf_le_cInf (ht : bdd_below t) (hs : s.nonempty) (h : s ⊆ t) : Inf t ≤ Inf s :=
le_cInf hs (λ a ha, cInf_le ht (h ha))

theorem le_cSup_iff (h : bdd_above s) (hs : s.nonempty) :
  a ≤ Sup s ↔ ∀ b, b ∈ upper_bounds s → a ≤ b :=
⟨λ h b hb, le_trans h (cSup_le hs hb), λ hb, hb _ (λ x, le_cSup h)⟩

theorem cInf_le_iff (h : bdd_below s) (hs : s.nonempty) :
  Inf s ≤ a ↔ ∀ b ∈ lower_bounds s, b ≤ a :=
⟨λ h b hb, le_trans (le_cInf hs hb) h, λ hb, hb _ (λ x, cInf_le h)⟩

lemma is_lub_cSup (ne : s.nonempty) (H : bdd_above s) : is_lub s (Sup s) :=
⟨λ x, le_cSup H, λ x, cSup_le ne⟩

lemma is_lub_csupr [nonempty ι] {f : ι → α} (H : bdd_above (range f)) :
  is_lub (range f) (⨆ i, f i) :=
is_lub_cSup (range_nonempty f) H

lemma is_lub_csupr_set {f : β → α} {s : set β} (H : bdd_above (f '' s)) (Hne : s.nonempty) :
  is_lub (f '' s) (⨆ i : s, f i) :=
by { rw ← Sup_image', exact is_lub_cSup (Hne.image _) H }

lemma is_glb_cInf (ne : s.nonempty) (H : bdd_below s) : is_glb s (Inf s) :=
⟨λ x, cInf_le H, λ x, le_cInf ne⟩

lemma is_glb_cinfi [nonempty ι] {f : ι → α} (H : bdd_below (range f)) :
  is_glb (range f) (⨅ i, f i) :=
is_glb_cInf (range_nonempty f) H

lemma is_glb_cinfi_set {f : β → α} {s : set β} (H : bdd_below (f '' s)) (Hne : s.nonempty) :
  is_glb (f '' s) (⨅ i : s, f i) :=
@is_lub_csupr_set αᵒᵈ _ _ _ _ H Hne

lemma csupr_le_iff [nonempty ι] {f : ι → α} {a : α} (hf : bdd_above (range f)) :
  supr f ≤ a ↔ ∀ i, f i ≤ a :=
(is_lub_le_iff $ is_lub_csupr hf).trans forall_range_iff

lemma le_cinfi_iff [nonempty ι] {f : ι → α} {a : α} (hf : bdd_below (range f)) :
  a ≤ infi f ↔ ∀ i, a ≤ f i :=
(le_is_glb_iff $ is_glb_cinfi hf).trans forall_range_iff

lemma csupr_set_le_iff {ι : Type*} {s : set ι} {f : ι → α} {a : α} (hs : s.nonempty)
  (hf : bdd_above (f '' s)) :
  (⨆ i : s, f i) ≤ a ↔ ∀ i ∈ s, f i ≤ a :=
(is_lub_le_iff $ is_lub_csupr_set hf hs).trans ball_image_iff

lemma le_cinfi_set_iff {ι : Type*} {s : set ι} {f : ι → α} {a : α} (hs : s.nonempty)
  (hf : bdd_below (f '' s)) :
  a ≤ (⨅ i : s, f i) ↔ ∀ i ∈ s, a ≤ f i :=
(le_is_glb_iff $ is_glb_cinfi_set hf hs).trans ball_image_iff

lemma is_lub.cSup_eq (H : is_lub s a) (ne : s.nonempty) : Sup s = a :=
(is_lub_cSup ne ⟨a, H.1⟩).unique H

lemma is_lub.csupr_eq [nonempty ι] {f : ι → α} (H : is_lub (range f) a) : (⨆ i, f i) = a :=
H.cSup_eq (range_nonempty f)

lemma is_lub.csupr_set_eq {s : set β} {f : β → α} (H : is_lub (f '' s) a) (Hne : s.nonempty) :
  (⨆ i : s, f i) = a :=
is_lub.cSup_eq (image_eq_range f s ▸ H) (image_eq_range f s ▸ Hne.image f)

/-- A greatest element of a set is the supremum of this set. -/
lemma is_greatest.cSup_eq (H : is_greatest s a) : Sup s = a :=
H.is_lub.cSup_eq H.nonempty

lemma is_greatest.Sup_mem (H : is_greatest s a) : Sup s ∈ s :=
H.cSup_eq.symm ▸ H.1

lemma is_glb.cInf_eq (H : is_glb s a) (ne : s.nonempty) : Inf s = a :=
(is_glb_cInf ne ⟨a, H.1⟩).unique H

lemma is_glb.cinfi_eq [nonempty ι] {f : ι → α} (H : is_glb (range f) a) : (⨅ i, f i) = a :=
H.cInf_eq (range_nonempty f)

lemma is_glb.cinfi_set_eq {s : set β} {f : β → α} (H : is_glb (f '' s) a) (Hne : s.nonempty) :
  (⨅ i : s, f i) = a :=
is_glb.cInf_eq (image_eq_range f s ▸ H) (image_eq_range f s ▸ Hne.image f)

/-- A least element of a set is the infimum of this set. -/
lemma is_least.cInf_eq (H : is_least s a) : Inf s = a :=
H.is_glb.cInf_eq H.nonempty

lemma is_least.Inf_mem (H : is_least s a) : Inf s ∈ s :=
H.cInf_eq.symm ▸ H.1

lemma subset_Icc_cInf_cSup (hb : bdd_below s) (ha : bdd_above s) :
  s ⊆ Icc (Inf s) (Sup s) :=
λ x hx, ⟨cInf_le hb hx, le_cSup ha hx⟩

theorem cSup_le_iff (hb : bdd_above s) (hs : s.nonempty) : Sup s ≤ a ↔ ∀ b ∈ s, b ≤ a :=
is_lub_le_iff (is_lub_cSup hs hb)

theorem le_cInf_iff (hb : bdd_below s) (hs : s.nonempty) : a ≤ Inf s ↔ ∀ b ∈ s, a ≤ b :=
le_is_glb_iff (is_glb_cInf hs hb)

lemma cSup_lower_bounds_eq_cInf {s : set α} (h : bdd_below s) (hs : s.nonempty) :
  Sup (lower_bounds s) = Inf s :=
(is_lub_cSup h $ hs.mono $ λ x hx y hy, hy hx).unique (is_glb_cInf hs h).is_lub

lemma cInf_upper_bounds_eq_cSup {s : set α} (h : bdd_above s) (hs : s.nonempty) :
  Inf (upper_bounds s) = Sup s :=
(is_glb_cInf h $ hs.mono $ λ x hx y hy, hy hx).unique (is_lub_cSup hs h).is_glb

lemma not_mem_of_lt_cInf {x : α} {s : set α} (h : x < Inf s) (hs : bdd_below s) : x ∉ s :=
λ hx, lt_irrefl _ (h.trans_le (cInf_le hs hx))

lemma not_mem_of_cSup_lt {x : α} {s : set α} (h : Sup s < x) (hs : bdd_above s) : x ∉ s :=
@not_mem_of_lt_cInf αᵒᵈ _ x s h hs

/--Introduction rule to prove that `b` is the supremum of `s`: it suffices to check that `b`
is larger than all elements of `s`, and that this is not the case of any `w<b`.
See `Sup_eq_of_forall_le_of_forall_lt_exists_gt` for a version in complete lattices. -/
theorem cSup_eq_of_forall_le_of_forall_lt_exists_gt (hs : s.nonempty)
  (H : ∀ a ∈ s, a ≤ b) (H' : ∀ w, w < b → ∃ a ∈ s, w < a) : Sup s = b :=
eq_of_le_of_not_lt (cSup_le hs H) $ λ hb, let ⟨a, ha, ha'⟩ := H' _ hb in
  lt_irrefl _ $ ha'.trans_le $ le_cSup ⟨b, H⟩ ha

/--Introduction rule to prove that `b` is the infimum of `s`: it suffices to check that `b`
is smaller than all elements of `s`, and that this is not the case of any `w>b`.
See `Inf_eq_of_forall_ge_of_forall_gt_exists_lt` for a version in complete lattices. -/
theorem cInf_eq_of_forall_ge_of_forall_gt_exists_lt : s.nonempty → (∀ a ∈ s, b ≤ a) →
  (∀ w, b < w → ∃ a ∈ s, a < w) → Inf s = b :=
@cSup_eq_of_forall_le_of_forall_lt_exists_gt αᵒᵈ _ _ _

/--b < Sup s when there is an element a in s with b < a, when s is bounded above.
This is essentially an iff, except that the assumptions for the two implications are
slightly different (one needs boundedness above for one direction, nonemptiness and linear
order for the other one), so we formulate separately the two implications, contrary to
the complete_lattice case.-/
lemma lt_cSup_of_lt (hs : bdd_above s) (ha : a ∈ s) (h : b < a) : b < Sup s :=
lt_of_lt_of_le h (le_cSup hs ha)

/--Inf s < b when there is an element a in s with a < b, when s is bounded below.
This is essentially an iff, except that the assumptions for the two implications are
slightly different (one needs boundedness below for one direction, nonemptiness and linear
order for the other one), so we formulate separately the two implications, contrary to
the complete_lattice case.-/
lemma cInf_lt_of_lt : bdd_below s → a ∈ s → a < b → Inf s < b :=
@lt_cSup_of_lt αᵒᵈ _ _ _ _

/-- If all elements of a nonempty set `s` are less than or equal to all elements
of a nonempty set `t`, then there exists an element between these sets. -/
lemma exists_between_of_forall_le (sne : s.nonempty) (tne : t.nonempty)
  (hst : ∀ (x ∈ s) (y ∈ t), x ≤ y) : (upper_bounds s ∩ lower_bounds t).nonempty :=
⟨Inf t, λ x hx, le_cInf tne $ hst x hx, λ y hy, cInf_le (sne.mono hst) hy⟩

/--The supremum of a singleton is the element of the singleton-/
@[simp] theorem cSup_singleton (a : α) : Sup {a} = a :=
is_greatest_singleton.cSup_eq

/--The infimum of a singleton is the element of the singleton-/
@[simp] theorem cInf_singleton (a : α) : Inf {a} = a :=
is_least_singleton.cInf_eq

@[simp] theorem cSup_pair (a b : α) : Sup {a, b} = a ⊔ b :=
(@is_lub_pair _ _ a b).cSup_eq (nonempty_insert _ _)

@[simp] theorem cInf_pair (a b : α) : Inf {a, b} = a ⊓ b :=
(@is_glb_pair _ _ a b).cInf_eq (nonempty_insert _ _)

/--If a set is bounded below and above, and nonempty, its infimum is less than or equal to
its supremum.-/
theorem cInf_le_cSup (hb : bdd_below s) (ha : bdd_above s) (ne : s.nonempty) : Inf s ≤ Sup s :=
is_glb_le_is_lub (is_glb_cInf ne hb) (is_lub_cSup ne ha) ne

/--The sup of a union of two sets is the max of the suprema of each subset, under the assumptions
that all sets are bounded above and nonempty.-/
theorem cSup_union (hs : bdd_above s) (sne : s.nonempty) (ht : bdd_above t) (tne : t.nonempty) :
  Sup (s ∪ t) = Sup s ⊔ Sup t :=
((is_lub_cSup sne hs).union (is_lub_cSup tne ht)).cSup_eq sne.inl

/--The inf of a union of two sets is the min of the infima of each subset, under the assumptions
that all sets are bounded below and nonempty.-/
theorem cInf_union (hs : bdd_below s) (sne : s.nonempty) (ht : bdd_below t) (tne : t.nonempty) :
  Inf (s ∪ t) = Inf s ⊓ Inf t :=
@cSup_union αᵒᵈ _ _ _ hs sne ht tne

/--The supremum of an intersection of two sets is bounded by the minimum of the suprema of each
set, if all sets are bounded above and nonempty.-/
theorem cSup_inter_le (hs : bdd_above s) (ht : bdd_above t) (hst : (s ∩ t).nonempty) :
  Sup (s ∩ t) ≤ Sup s ⊓ Sup t :=
cSup_le hst $ λ x hx, le_inf (le_cSup hs hx.1) (le_cSup ht hx.2)

/--The infimum of an intersection of two sets is bounded below by the maximum of the
infima of each set, if all sets are bounded below and nonempty.-/
theorem le_cInf_inter : bdd_below s → bdd_below t → (s ∩ t).nonempty →
  Inf s ⊔ Inf t ≤ Inf (s ∩ t) :=
@cSup_inter_le αᵒᵈ _ _ _

/-- The supremum of insert a s is the maximum of a and the supremum of s, if s is
nonempty and bounded above.-/
theorem cSup_insert (hs : bdd_above s) (sne : s.nonempty) : Sup (insert a s) = a ⊔ Sup s :=
((is_lub_cSup sne hs).insert a).cSup_eq (insert_nonempty a s)

/-- The infimum of insert a s is the minimum of a and the infimum of s, if s is
nonempty and bounded below.-/
theorem cInf_insert (hs : bdd_below s) (sne : s.nonempty) : Inf (insert a s) = a ⊓ Inf s :=
@cSup_insert αᵒᵈ _ _ _ hs sne

@[simp] lemma cInf_Icc (h : a ≤ b) : Inf (Icc a b) = a :=
(is_glb_Icc h).cInf_eq (nonempty_Icc.2 h)

@[simp] lemma cInf_Ici : Inf (Ici a) = a := is_least_Ici.cInf_eq

@[simp] lemma cInf_Ico (h : a < b) : Inf (Ico a b) = a :=
(is_glb_Ico h).cInf_eq (nonempty_Ico.2 h)

@[simp] lemma cInf_Ioc [densely_ordered α] (h : a < b) : Inf (Ioc a b) = a :=
(is_glb_Ioc h).cInf_eq (nonempty_Ioc.2 h)

@[simp] lemma cInf_Ioi [no_max_order α] [densely_ordered α] : Inf (Ioi a) = a :=
cInf_eq_of_forall_ge_of_forall_gt_exists_lt nonempty_Ioi (λ _, le_of_lt)
  (λ w hw, by simpa using exists_between hw)

@[simp] lemma cInf_Ioo [densely_ordered α] (h : a < b) : Inf (Ioo a b) = a :=
(is_glb_Ioo h).cInf_eq (nonempty_Ioo.2 h)

@[simp] lemma cSup_Icc (h : a ≤ b) : Sup (Icc a b) = b :=
(is_lub_Icc h).cSup_eq (nonempty_Icc.2 h)

@[simp] lemma cSup_Ico [densely_ordered α] (h : a < b) : Sup (Ico a b) = b :=
(is_lub_Ico h).cSup_eq (nonempty_Ico.2 h)

@[simp] lemma cSup_Iic : Sup (Iic a) = a := is_greatest_Iic.cSup_eq

@[simp] lemma cSup_Iio [no_min_order α] [densely_ordered α] : Sup (Iio a) = a :=
cSup_eq_of_forall_le_of_forall_lt_exists_gt nonempty_Iio (λ _, le_of_lt)
  (λ w hw, by simpa [and_comm] using exists_between hw)

@[simp] lemma cSup_Ioc (h : a < b) : Sup (Ioc a b) = b :=
(is_lub_Ioc h).cSup_eq (nonempty_Ioc.2 h)

@[simp] lemma cSup_Ioo [densely_ordered α] (h : a < b) : Sup (Ioo a b) = b :=
(is_lub_Ioo h).cSup_eq (nonempty_Ioo.2 h)

/--The indexed supremum of a function is bounded above by a uniform bound-/
lemma csupr_le [nonempty ι] {f : ι → α} {c : α} (H : ∀ x, f x ≤ c) : supr f ≤ c :=
cSup_le (range_nonempty f) (by rwa forall_range_iff)

/--The indexed supremum of a function is bounded below by the value taken at one point-/
lemma le_csupr {f : ι → α} (H : bdd_above (range f)) (c : ι) : f c ≤ supr f :=
le_cSup H (mem_range_self _)

lemma le_csupr_of_le {f : ι → α} (H : bdd_above (range f)) (c : ι) (h : a ≤ f c) : a ≤ supr f :=
le_trans h (le_csupr H c)

/--The indexed supremum of two functions are comparable if the functions are pointwise comparable-/
lemma csupr_mono {f g : ι → α} (B : bdd_above (range g)) (H : ∀ x, f x ≤ g x) :
  supr f ≤ supr g :=
begin
  casesI is_empty_or_nonempty ι,
  { rw [supr_of_empty', supr_of_empty'] },
  { exact csupr_le (λ x, le_csupr_of_le B x (H x)) },
end

lemma le_csupr_set {f : β → α} {s : set β}
  (H : bdd_above (f '' s)) {c : β} (hc : c ∈ s) : f c ≤ ⨆ i : s, f i :=
(le_cSup H $ mem_image_of_mem f hc).trans_eq Sup_image'

/--The indexed infimum of two functions are comparable if the functions are pointwise comparable-/
lemma cinfi_mono {f g : ι → α} (B : bdd_below (range f)) (H : ∀ x, f x ≤ g x) :
  infi f ≤ infi g :=
@csupr_mono αᵒᵈ _ _ _ _ B H

/--The indexed minimum of a function is bounded below by a uniform lower bound-/
lemma le_cinfi [nonempty ι] {f : ι → α} {c : α} (H : ∀ x, c ≤ f x) : c ≤ infi f :=
@csupr_le αᵒᵈ _ _ _ _ _ H

/--The indexed infimum of a function is bounded above by the value taken at one point-/
lemma cinfi_le {f : ι → α} (H : bdd_below (range f)) (c : ι) : infi f ≤ f c :=
@le_csupr αᵒᵈ _ _ _ H c

lemma cinfi_le_of_le {f : ι → α} (H : bdd_below (range f)) (c : ι) (h : f c ≤ a) : infi f ≤ a :=
@le_csupr_of_le αᵒᵈ _ _ _ _ H c h

lemma cinfi_set_le {f : β → α} {s : set β}
  (H : bdd_below (f '' s)) {c : β} (hc : c ∈ s) : (⨅ i : s, f i) ≤ f c :=
@le_csupr_set αᵒᵈ _ _ _ _ H _ hc

@[simp] theorem csupr_const [hι : nonempty ι] {a : α} : (⨆ b : ι, a) = a :=
by rw [supr, range_const, cSup_singleton]

@[simp] theorem cinfi_const [hι : nonempty ι] {a : α} : (⨅ b:ι, a) = a := @csupr_const αᵒᵈ _ _ _ _

@[simp] theorem supr_unique [unique ι] {s : ι → α} : (⨆ i, s i) = s default :=
have ∀ i, s i = s default := λ i, congr_arg s (unique.eq_default i),
by simp only [this, csupr_const]

@[simp] theorem infi_unique [unique ι] {s : ι → α} : (⨅ i, s i) = s default :=
@supr_unique αᵒᵈ _ _ _ _

@[simp] lemma csupr_pos {p : Prop} {f : p → α} (hp : p) : (⨆ h : p, f h) = f hp :=
by haveI := unique_prop hp; exact supr_unique

@[simp] lemma cinfi_pos {p : Prop} {f : p → α} (hp : p) : (⨅ h : p, f h) = f hp :=
@csupr_pos αᵒᵈ _ _ _ hp

lemma csupr_set {s : set β} {f : β → α} : (⨆ x : s, f x) = Sup (f '' s) :=
begin
  rw supr,
  congr,
  ext,
  rw [mem_image, mem_range, set_coe.exists],
  simp_rw [subtype.coe_mk, exists_prop],
end

lemma cinfi_set {s : set β} {f : β → α} : (⨅ x : s, f x) = Inf (f '' s) := @csupr_set αᵒᵈ _ _ _ _

/--Introduction rule to prove that `b` is the supremum of `f`: it suffices to check that `b`
is larger than `f i` for all `i`, and that this is not the case of any `w<b`.
See `supr_eq_of_forall_le_of_forall_lt_exists_gt` for a version in complete lattices. -/
theorem csupr_eq_of_forall_le_of_forall_lt_exists_gt [nonempty ι] {f : ι → α} (h₁ : ∀ i, f i ≤ b)
  (h₂ : ∀ w, w < b → (∃ i, w < f i)) : (⨆ (i : ι), f i) = b :=
cSup_eq_of_forall_le_of_forall_lt_exists_gt (range_nonempty f) (forall_range_iff.mpr h₁)
  (λ w hw, exists_range_iff.mpr $ h₂ w hw)

/--Introduction rule to prove that `b` is the infimum of `f`: it suffices to check that `b`
is smaller than `f i` for all `i`, and that this is not the case of any `w>b`.
See `infi_eq_of_forall_ge_of_forall_gt_exists_lt` for a version in complete lattices. -/
theorem cinfi_eq_of_forall_ge_of_forall_gt_exists_lt [nonempty ι] {f : ι → α} (h₁ : ∀ i, b ≤ f i)
  (h₂ : ∀ w, b < w → (∃ i, f i < w)) : (⨅ (i : ι), f i) = b :=
@csupr_eq_of_forall_le_of_forall_lt_exists_gt αᵒᵈ _ _ _ _ ‹_› ‹_› ‹_›

/-- Nested intervals lemma: if `f` is a monotone sequence, `g` is an antitone sequence, and
`f n ≤ g n` for all `n`, then `⨆ n, f n` belongs to all the intervals `[f n, g n]`. -/
lemma monotone.csupr_mem_Inter_Icc_of_antitone [semilattice_sup β]
  {f g : β → α} (hf : monotone f) (hg : antitone g) (h : f ≤ g) :
  (⨆ n, f n) ∈ ⋂ n, Icc (f n) (g n) :=
begin
  refine mem_Inter.2 (λ n, _),
  haveI : nonempty β := ⟨n⟩,
  have : ∀ m, f m ≤ g n := λ m, hf.forall_le_of_antitone hg h m n,
  exact ⟨le_csupr ⟨g $ n, forall_range_iff.2 this⟩ _, csupr_le this⟩
end

/-- Nested intervals lemma: if `[f n, g n]` is an antitone sequence of nonempty
closed intervals, then `⨆ n, f n` belongs to all the intervals `[f n, g n]`. -/
lemma csupr_mem_Inter_Icc_of_antitone_Icc [semilattice_sup β]
  {f g : β → α} (h : antitone (λ n, Icc (f n) (g n))) (h' : ∀ n, f n ≤ g n) :
  (⨆ n, f n) ∈ ⋂ n, Icc (f n) (g n) :=
monotone.csupr_mem_Inter_Icc_of_antitone (λ m n hmn, ((Icc_subset_Icc_iff (h' n)).1 (h hmn)).1)
  (λ m n hmn, ((Icc_subset_Icc_iff (h' n)).1 (h hmn)).2) h'

lemma finset.nonempty.sup'_eq_cSup_image {s : finset β} (hs : s.nonempty) (f : β → α) :
  s.sup' hs f = Sup (f '' s) :=
eq_of_forall_ge_iff $ λ a,
  by simp [cSup_le_iff (s.finite_to_set.image f).bdd_above (hs.to_set.image f)]

lemma finset.nonempty.sup'_id_eq_cSup {s : finset α} (hs : s.nonempty) :
  s.sup' hs id = Sup s :=
by rw [hs.sup'_eq_cSup_image, image_id]

/--Introduction rule to prove that b is the supremum of s: it suffices to check that
1) b is an upper bound
2) every other upper bound b' satisfies b ≤ b'.-/
theorem cSup_eq_of_is_forall_le_of_forall_le_imp_ge (hs : s.nonempty)
  (h_is_ub : ∀ a ∈ s, a ≤ b) (h_b_le_ub : ∀ub, (∀ a ∈ s, a ≤ ub) → (b ≤ ub)) : Sup s = b :=
(cSup_le hs h_is_ub).antisymm (h_b_le_ub _ $ λ a, le_cSup ⟨b, h_is_ub⟩)

end conditionally_complete_lattice

instance pi.conditionally_complete_lattice {ι : Type*} {α : Π i : ι, Type*}
  [Π i, conditionally_complete_lattice (α i)] :
  conditionally_complete_lattice (Π i, α i) :=
{ le_cSup := λ s f ⟨g, hg⟩ hf i, le_cSup ⟨g i, set.forall_range_iff.2 $ λ ⟨f', hf'⟩, hg hf' i⟩
    ⟨⟨f, hf⟩, rfl⟩,
  cSup_le := λ s f hs hf i, cSup_le (by haveI := hs.to_subtype; apply range_nonempty) $
    λ b ⟨⟨g, hg⟩, hb⟩, hb ▸ hf hg i,
  cInf_le := λ s f ⟨g, hg⟩ hf i, cInf_le ⟨g i, set.forall_range_iff.2 $ λ ⟨f', hf'⟩, hg hf' i⟩
    ⟨⟨f, hf⟩, rfl⟩,
  le_cInf := λ s f hs hf i, le_cInf (by haveI := hs.to_subtype; apply range_nonempty) $
    λ b ⟨⟨g, hg⟩, hb⟩, hb ▸ hf hg i,
  .. pi.lattice, .. pi.has_Sup, .. pi.has_Inf }

section conditionally_complete_linear_order
variables [conditionally_complete_linear_order α] {s t : set α} {a b : α}

lemma finset.nonempty.cSup_eq_max' {s : finset α} (h : s.nonempty) : Sup ↑s = s.max' h :=
eq_of_forall_ge_iff $ λ a, (cSup_le_iff s.bdd_above h.to_set).trans (s.max'_le_iff h).symm

lemma finset.nonempty.cInf_eq_min' {s : finset α} (h : s.nonempty) : Inf ↑s = s.min' h :=
@finset.nonempty.cSup_eq_max' αᵒᵈ _ s h

lemma finset.nonempty.cSup_mem {s : finset α} (h : s.nonempty) : Sup (s : set α) ∈ s :=
by { rw h.cSup_eq_max', exact s.max'_mem _ }

lemma finset.nonempty.cInf_mem {s : finset α} (h : s.nonempty) : Inf (s : set α) ∈ s :=
@finset.nonempty.cSup_mem αᵒᵈ _ _ h

lemma set.nonempty.cSup_mem (h : s.nonempty) (hs : s.finite) : Sup s ∈ s :=
by { lift s to finset α using hs, exact finset.nonempty.cSup_mem h }

lemma set.nonempty.cInf_mem (h : s.nonempty) (hs : s.finite) : Inf s ∈ s :=
@set.nonempty.cSup_mem αᵒᵈ _ _ h hs

lemma set.finite.cSup_lt_iff (hs : s.finite) (h : s.nonempty) : Sup s < a ↔ ∀ x ∈ s, x < a :=
⟨λ h x hx, (le_cSup hs.bdd_above hx).trans_lt h, λ H, H _ $ h.cSup_mem hs⟩

lemma set.finite.lt_cInf_iff (hs : s.finite) (h : s.nonempty) : a < Inf s ↔ ∀ x ∈ s, a < x :=
@set.finite.cSup_lt_iff αᵒᵈ _ _ _ hs h

/-- When b < Sup s, there is an element a in s with b < a, if s is nonempty and the order is
a linear order. -/
lemma exists_lt_of_lt_cSup (hs : s.nonempty) (hb : b < Sup s) : ∃ a ∈ s, b < a :=
by { contrapose! hb, exact cSup_le hs hb }

/--
Indexed version of the above lemma `exists_lt_of_lt_cSup`.
When `b < supr f`, there is an element `i` such that `b < f i`.
-/
lemma exists_lt_of_lt_csupr [nonempty ι] {f : ι → α} (h : b < supr f) : ∃ i, b < f i :=
let ⟨_, ⟨i, rfl⟩, h⟩ := exists_lt_of_lt_cSup (range_nonempty f) h in ⟨i, h⟩

/--When Inf s < b, there is an element a in s with a < b, if s is nonempty and the order is
a linear order.-/
lemma exists_lt_of_cInf_lt (hs : s.nonempty) (hb : Inf s < b) : ∃ a ∈ s, a < b :=
@exists_lt_of_lt_cSup αᵒᵈ _ _ _ hs hb

/--
Indexed version of the above lemma `exists_lt_of_cInf_lt`
When `infi f < a`, there is an element `i` such that `f i < a`.
-/
lemma exists_lt_of_cinfi_lt [nonempty ι] {f : ι → α} (h : infi f < a) : ∃ i, f i < a :=
@exists_lt_of_lt_csupr αᵒᵈ _ _ _ _ _ h

open function
variables [is_well_order α (<)]

lemma Inf_eq_argmin_on (hs : s.nonempty) : Inf s = argmin_on id (@is_well_order.wf α (<) _) s hs :=
is_least.cInf_eq ⟨argmin_on_mem _ _ _ _, λ a ha, argmin_on_le id _ _ ha⟩

lemma is_least_Inf (hs : s.nonempty) : is_least s (Inf s) :=
by { rw Inf_eq_argmin_on hs, exact ⟨argmin_on_mem _ _ _ _, λ a ha, argmin_on_le id _ _ ha⟩ }

lemma le_cInf_iff' (hs : s.nonempty) : b ≤ Inf s ↔ b ∈ lower_bounds s :=
le_is_glb_iff (is_least_Inf hs).is_glb

lemma Inf_mem (hs : s.nonempty) : Inf s ∈ s := (is_least_Inf hs).1

lemma monotone_on.map_Inf {β : Type*} [conditionally_complete_lattice β] {f : α → β}
  (hf : monotone_on f s) (hs : s.nonempty) : f (Inf s) = Inf (f '' s) :=
(hf.map_is_least (is_least_Inf hs)).cInf_eq.symm

lemma monotone.map_Inf {β : Type*} [conditionally_complete_lattice β] {f : α → β} (hf : monotone f)
  (hs : s.nonempty) : f (Inf s) = Inf (f '' s) :=
(hf.map_is_least (is_least_Inf hs)).cInf_eq.symm

end conditionally_complete_linear_order

/-!
### Lemmas about a conditionally complete linear order with bottom element

In this case we have `Sup ∅ = ⊥`, so we can drop some `nonempty`/`set.nonempty` assumptions.
-/

section conditionally_complete_linear_order_bot

variables [conditionally_complete_linear_order_bot α]

@[simp] lemma cSup_empty : (Sup ∅ : α) = ⊥ :=
conditionally_complete_linear_order_bot.cSup_empty

@[simp] lemma csupr_of_empty [is_empty ι] (f : ι → α) : (⨆ i, f i) = ⊥ :=
by rw [supr_of_empty', cSup_empty]

@[simp] lemma csupr_false (f : false → α) : (⨆ i, f i) = ⊥ := csupr_of_empty f

@[simp] lemma cInf_univ : Inf (univ : set α) = ⊥ := is_least_univ.cInf_eq

lemma is_lub_cSup' {s : set α} (hs : bdd_above s) : is_lub s (Sup s) :=
begin
  rcases eq_empty_or_nonempty s with (rfl|hne),
  { simp only [cSup_empty, is_lub_empty] },
  { exact is_lub_cSup hne hs }
end

lemma cSup_le_iff' {s : set α} (hs : bdd_above s) {a : α} : Sup s ≤ a ↔ ∀ x ∈ s, x ≤ a :=
is_lub_le_iff (is_lub_cSup' hs)

lemma cSup_le' {s : set α} {a : α} (h : a ∈ upper_bounds s) : Sup s ≤ a :=
(cSup_le_iff' ⟨a, h⟩).2 h

theorem le_cSup_iff' {s : set α} {a : α} (h : bdd_above s) :
  a ≤ Sup s ↔ ∀ b, b ∈ upper_bounds s → a ≤ b :=
⟨λ h b hb, le_trans h (cSup_le' hb), λ hb, hb _ (λ x, le_cSup h)⟩

lemma le_csupr_iff' {s : ι → α} {a : α} (h : bdd_above (range s)) :
  a ≤ supr s ↔ ∀ b, (∀ i, s i ≤ b) → a ≤ b :=
by simp [supr, h, le_cSup_iff', upper_bounds]

theorem le_cInf_iff'' {s : set α} {a : α} (ne : s.nonempty) :
  a ≤ Inf s ↔ ∀ (b : α), b ∈ s → a ≤ b :=
le_cInf_iff ⟨⊥, λ a _, bot_le⟩ ne

theorem cInf_le' {s : set α} {a : α} (h : a ∈ s) : Inf s ≤ a :=
cInf_le ⟨⊥, λ a _, bot_le⟩ h

lemma exists_lt_of_lt_cSup' {s : set α} {a : α} (h : a < Sup s) : ∃ b ∈ s, a < b :=
by { contrapose! h, exact cSup_le' h }

lemma csupr_le_iff' {f : ι → α} (h : bdd_above (range f)) {a : α} :
  (⨆ i, f i) ≤ a ↔ ∀ i, f i ≤ a :=
(cSup_le_iff' h).trans forall_range_iff

lemma csupr_le' {f : ι → α} {a : α} (h : ∀ i, f i ≤ a) : (⨆ i, f i) ≤ a :=
cSup_le' $ forall_range_iff.2 h

lemma exists_lt_of_lt_csupr' {f : ι → α} {a : α} (h : a < ⨆ i, f i) : ∃ i, a < f i :=
by { contrapose! h, exact csupr_le' h }

lemma csupr_mono' {ι'} {f : ι → α} {g : ι' → α} (hg : bdd_above (range g))
  (h : ∀ i, ∃ i', f i ≤ g i') : supr f ≤ supr g :=
csupr_le' $ λ i, exists.elim (h i) (le_csupr_of_le hg)

lemma cInf_le_cInf' {s t : set α} (h₁ : t.nonempty) (h₂ : t ⊆ s) : Inf s ≤ Inf t :=
cInf_le_cInf (order_bot.bdd_below s) h₁ h₂

end conditionally_complete_linear_order_bot

namespace with_top
open_locale classical

variables [conditionally_complete_linear_order_bot α]

/-- The Sup of a non-empty set is its least upper bound for a conditionally
complete lattice with a top. -/
lemma is_lub_Sup' {β : Type*} [conditionally_complete_lattice β]
  {s : set (with_top β)} (hs : s.nonempty) : is_lub s (Sup s) :=
begin
  split,
  { show ite _ _ _ ∈ _,
    split_ifs,
    { intros _ _, exact le_top },
    { rintro (⟨⟩|a) ha,
      { contradiction },
      apply some_le_some.2,
      exact le_cSup h_1 ha },
    { intros _ _, exact le_top } },
  { show ite _ _ _ ∈ _,
    split_ifs,
    { rintro (⟨⟩|a) ha,
      { exact le_rfl },
      { exact false.elim (not_top_le_coe a (ha h)) } },
    { rintro (⟨⟩|b) hb,
      { exact le_top },
      refine some_le_some.2 (cSup_le _ _),
      { rcases hs with ⟨⟨⟩|b, hb⟩,
        { exact absurd hb h },
        { exact ⟨b, hb⟩ } },
      { intros a ha, exact some_le_some.1 (hb ha) } },
    { rintro (⟨⟩|b) hb,
      { exact le_rfl },
      { exfalso, apply h_1, use b, intros a ha, exact some_le_some.1 (hb ha) } } }
end

lemma is_lub_Sup (s : set (with_top α)) : is_lub s (Sup s) :=
begin
  cases s.eq_empty_or_nonempty with hs hs,
  { rw hs,
    show is_lub ∅ (ite _ _ _),
    split_ifs,
    { cases h },
    { rw [preimage_empty, cSup_empty], exact is_lub_empty },
    { exfalso, apply h_1, use ⊥, rintro a ⟨⟩ } },
  exact is_lub_Sup' hs,
end

/-- The Inf of a bounded-below set is its greatest lower bound for a conditionally
complete lattice with a top. -/
lemma is_glb_Inf' {β : Type*} [conditionally_complete_lattice β]
  {s : set (with_top β)} (hs : bdd_below s) : is_glb s (Inf s) :=
begin
  split,
  { show ite _ _ _ ∈ _,
    split_ifs,
    { intros a ha, exact top_le_iff.2 (set.mem_singleton_iff.1 (h ha)) },
    { rintro (⟨⟩|a) ha,
      { exact le_top },
      refine some_le_some.2 (cInf_le _ ha),
      rcases hs with ⟨⟨⟩|b, hb⟩,
      { exfalso,
        apply h,
        intros c hc,
        rw [mem_singleton_iff, ←top_le_iff],
        exact hb hc },
      use b,
      intros c hc,
      exact some_le_some.1 (hb hc) } },
  { show ite _ _ _ ∈ _,
    split_ifs,
    { intros _ _, exact le_top },
    { rintro (⟨⟩|a) ha,
      { exfalso, apply h, intros b hb, exact set.mem_singleton_iff.2 (top_le_iff.1 (ha hb)) },
      { refine some_le_some.2 (le_cInf _ _),
        { classical, contrapose! h,
          rintros (⟨⟩|a) ha,
          { exact mem_singleton ⊤ },
          { exact (h ⟨a, ha⟩).elim }},
        { intros b hb,
          rw ←some_le_some,
          exact ha hb } } } }
end

lemma is_glb_Inf (s : set (with_top α)) : is_glb s (Inf s) :=
begin
  by_cases hs : bdd_below s,
  { exact is_glb_Inf' hs },
  { exfalso, apply hs, use ⊥, intros _ _, exact bot_le },
end

noncomputable instance : complete_linear_order (with_top α) :=
{ Sup := Sup, le_Sup := λ s, (is_lub_Sup s).1, Sup_le := λ s, (is_lub_Sup s).2,
  Inf := Inf, le_Inf := λ s, (is_glb_Inf s).2, Inf_le := λ s, (is_glb_Inf s).1,
  .. with_top.linear_order, ..with_top.lattice, ..with_top.order_top, ..with_top.order_bot }

lemma coe_Sup {s : set α} (hb : bdd_above s) : (↑(Sup s) : with_top α) = ⨆ a ∈ s, ↑a :=
begin
  cases s.eq_empty_or_nonempty with hs hs,
  { rw [hs, cSup_empty], simp only [set.mem_empty_eq, supr_bot, supr_false], refl },
  apply le_antisymm,
  { refine (coe_le_iff.2 $ λ b hb, cSup_le hs $ λ a has, coe_le_coe.1 $ hb ▸ _),
    exact le_supr₂_of_le a has le_rfl },
  { exact supr₂_le (λ a ha, coe_le_coe.2 $ le_cSup hb ha) }
end

lemma coe_Inf {s : set α} (hs : s.nonempty) : (↑(Inf s) : with_top α) = ⨅ a ∈ s, ↑a :=
begin
  obtain ⟨x, hx⟩ := hs,
  have : (⨅ a ∈ s, ↑a : with_top α) ≤ x := infi₂_le_of_le x hx le_rfl,
  rcases le_coe_iff.1 this with ⟨r, r_eq, hr⟩,
  refine le_antisymm
    (le_infi₂ $ λ a ha, coe_le_coe.2 $ cInf_le (order_bot.bdd_below s) ha) _,
  { rw r_eq,
    apply coe_le_coe.2 (le_cInf ⟨x, hx⟩ (λ a has, coe_le_coe.1 _)),
    rw ←r_eq,
    exact infi₂_le_of_le a has le_rfl }
end

end with_top

namespace monotone
variables [preorder α] [conditionally_complete_lattice β] {f : α → β} (h_mono : monotone f)

/-! A monotone function into a conditionally complete lattice preserves the ordering properties of
`Sup` and `Inf`. -/

lemma le_cSup_image {s : set α} {c : α} (hcs : c ∈ s) (h_bdd : bdd_above s) :
  f c ≤ Sup (f '' s) :=
le_cSup (map_bdd_above h_mono h_bdd) (mem_image_of_mem f hcs)

lemma cSup_image_le {s : set α} (hs : s.nonempty) {B : α} (hB: B ∈ upper_bounds s) :
  Sup (f '' s) ≤ f B :=
cSup_le (nonempty.image f hs) (h_mono.mem_upper_bounds_image hB)

lemma cInf_image_le {s : set α} {c : α} (hcs : c ∈ s) (h_bdd : bdd_below s) :
  Inf (f '' s) ≤ f c :=
@le_cSup_image αᵒᵈ βᵒᵈ _ _ _ (λ x y hxy, h_mono hxy) _ _ hcs h_bdd

lemma le_cInf_image {s : set α} (hs : s.nonempty) {B : α} (hB: B ∈ lower_bounds s) :
  f B ≤ Inf (f '' s) :=
@cSup_image_le αᵒᵈ βᵒᵈ _ _ _ (λ x y hxy, h_mono hxy) _ hs _ hB

end monotone

namespace galois_connection
variables [conditionally_complete_lattice α] [conditionally_complete_lattice β] [nonempty ι]
  {l : α → β} {u : β → α}

lemma l_cSup (gc : galois_connection l u) {s : set α} (hne : s.nonempty)
  (hbdd : bdd_above s) :
  l (Sup s) = ⨆ x : s, l x :=
eq.symm $ is_lub.csupr_set_eq (gc.is_lub_l_image $ is_lub_cSup hne hbdd) hne

lemma l_cSup' (gc : galois_connection l u) {s : set α} (hne : s.nonempty) (hbdd : bdd_above s) :
  l (Sup s) = Sup (l '' s) :=
by rw [gc.l_cSup hne hbdd, csupr_set]

lemma l_csupr (gc : galois_connection l u) {f : ι → α}
  (hf : bdd_above (range f)) :
  l (⨆ i, f i) = ⨆ i, l (f i) :=
by rw [supr, gc.l_cSup (range_nonempty _) hf, supr_range']

lemma l_csupr_set (gc : galois_connection l u) {s : set γ} {f : γ → α}
  (hf : bdd_above (f '' s)) (hne : s.nonempty) :
  l (⨆ i : s, f i) = ⨆ i : s, l (f i) :=
by { haveI := hne.to_subtype, rw image_eq_range at hf, exact gc.l_csupr hf }

lemma u_cInf (gc : galois_connection l u) {s : set β} (hne : s.nonempty)
  (hbdd : bdd_below s) :
  u (Inf s) = ⨅ x : s, u x :=
gc.dual.l_cSup hne hbdd

lemma u_cInf' (gc : galois_connection l u) {s : set β} (hne : s.nonempty) (hbdd : bdd_below s) :
  u (Inf s) = Inf (u '' s) :=
gc.dual.l_cSup' hne hbdd

lemma u_cinfi (gc : galois_connection l u) {f : ι → β}
  (hf : bdd_below (range f)) :
  u (⨅ i, f i) = ⨅ i, u (f i) :=
gc.dual.l_csupr hf

lemma u_cinfi_set (gc : galois_connection l u) {s : set γ} {f : γ → β}
  (hf : bdd_below (f '' s)) (hne : s.nonempty) :
  u (⨅ i : s, f i) = ⨅ i : s, u (f i) :=
gc.dual.l_csupr_set hf hne

end galois_connection

namespace order_iso
variables [conditionally_complete_lattice α] [conditionally_complete_lattice β] [nonempty ι]

lemma map_cSup (e : α ≃o β) {s : set α} (hne : s.nonempty) (hbdd : bdd_above s) :
  e (Sup s) = ⨆ x : s, e x :=
e.to_galois_connection.l_cSup hne hbdd

lemma map_cSup' (e : α ≃o β) {s : set α} (hne : s.nonempty) (hbdd : bdd_above s) :
  e (Sup s) = Sup (e '' s) :=
e.to_galois_connection.l_cSup' hne hbdd

lemma map_csupr (e : α ≃o β) {f : ι → α} (hf : bdd_above (range f)) :
  e (⨆ i, f i) = ⨆ i, e (f i) :=
e.to_galois_connection.l_csupr hf

lemma map_csupr_set (e : α ≃o β) {s : set γ} {f : γ → α}
  (hf : bdd_above (f '' s)) (hne : s.nonempty) :
  e (⨆ i : s, f i) = ⨆ i : s, e (f i) :=
e.to_galois_connection.l_csupr_set hf hne

lemma map_cInf (e : α ≃o β) {s : set α} (hne : s.nonempty) (hbdd : bdd_below s) :
  e (Inf s) = ⨅ x : s, e x :=
e.dual.map_cSup hne hbdd

lemma map_cInf' (e : α ≃o β) {s : set α} (hne : s.nonempty) (hbdd : bdd_below s) :
  e (Inf s) = Inf (e '' s) :=
e.dual.map_cSup' hne hbdd

lemma map_cinfi (e : α ≃o β) {f : ι → α} (hf : bdd_below (range f)) :
  e (⨅ i, f i) = ⨅ i, e (f i) :=
e.dual.map_csupr hf

lemma map_cinfi_set (e : α ≃o β) {s : set γ} {f : γ → α}
  (hf : bdd_below (f '' s)) (hne : s.nonempty) :
  e (⨅ i : s, f i) = ⨅ i : s, e (f i) :=
e.dual.map_csupr_set hf hne

end order_iso

/-!
### Supremum/infimum of `set.image2`

A collection of lemmas showing what happens to the suprema/infima of `s` and `t` when mapped under
a binary function whose partial evaluations are lower/upper adjoints of Galois connections.
-/

section
variables [conditionally_complete_lattice α] [conditionally_complete_lattice β]
  [conditionally_complete_lattice γ] {f : α → β → γ} {s : set α} {t : set β}

variables {l u : α → β → γ} {l₁ u₁ : β → γ → α} {l₂ u₂ : α → γ → β}

lemma cSup_image2_eq_cSup_cSup (h₁ : ∀ b, galois_connection (swap l b) (u₁ b))
  (h₂ : ∀ a, galois_connection (l a) (u₂ a))
  (hs₀ : s.nonempty) (hs₁ : bdd_above s) (ht₀ : t.nonempty) (ht₁ : bdd_above t) :
  Sup (image2 l s t) = l (Sup s) (Sup t) :=
begin
  refine eq_of_forall_ge_iff (λ c, _),
  rw [cSup_le_iff (hs₁.image2 (λ _, (h₁ _).monotone_l) (λ _, (h₂ _).monotone_l) ht₁)
    (hs₀.image2 ht₀), forall_image2_iff, forall₂_swap, (h₂ _).le_iff_le, cSup_le_iff ht₁ ht₀],
  simp_rw [←(h₂ _).le_iff_le, (h₁ _).le_iff_le, cSup_le_iff hs₁ hs₀],
end

lemma cSup_image2_eq_cSup_cInf (h₁ : ∀ b, galois_connection (swap l b) (u₁ b))
  (h₂ : ∀ a, galois_connection (l a ∘ of_dual) (to_dual ∘ u₂ a)) :
  s.nonempty → bdd_above s → t.nonempty → bdd_below t → Sup (image2 l s t) = l (Sup s) (Inf t) :=
@cSup_image2_eq_cSup_cSup _ βᵒᵈ _ _ _ _ _ _ _ _ _ h₁ h₂

lemma cSup_image2_eq_cInf_cSup (h₁ : ∀ b, galois_connection (swap l b ∘ of_dual) (to_dual ∘ u₁ b))
  (h₂ : ∀ a, galois_connection (l a) (u₂ a)) :
  s.nonempty → bdd_below s → t.nonempty → bdd_above t → Sup (image2 l s t) = l (Inf s) (Sup t) :=
@cSup_image2_eq_cSup_cSup αᵒᵈ _ _ _ _ _ _ _ _ _ _ h₁ h₂

lemma cSup_image2_eq_cInf_cInf (h₁ : ∀ b, galois_connection (swap l b ∘ of_dual) (to_dual ∘ u₁ b))
  (h₂ : ∀ a, galois_connection (l a ∘ of_dual) (to_dual ∘ u₂ a)) :
  s.nonempty → bdd_below s → t.nonempty → bdd_below t → Sup (image2 l s t) = l (Inf s) (Inf t) :=
@cSup_image2_eq_cSup_cSup αᵒᵈ βᵒᵈ _ _ _ _ _ _ _ _ _ h₁ h₂

lemma cInf_image2_eq_cInf_cInf (h₁ : ∀ b, galois_connection (l₁ b) (swap u b))
  (h₂ : ∀ a, galois_connection (l₂ a) (u a)) :
  s.nonempty → bdd_below s → t.nonempty → bdd_below t →
  Inf (image2 u s t) = u (Inf s) (Inf t) :=
@cSup_image2_eq_cSup_cSup αᵒᵈ βᵒᵈ γᵒᵈ _ _ _ _ _ _ l₁ l₂ (λ _, (h₁ _).dual) (λ _, (h₂ _).dual)

lemma cInf_image2_eq_cInf_cSup (h₁ : ∀ b, galois_connection (l₁ b) (swap u b))
  (h₂ : ∀ a, galois_connection (to_dual ∘ l₂ a) (u a ∘ of_dual)) :
  s.nonempty → bdd_below s → t.nonempty → bdd_above t → Inf (image2 u s t) = u (Inf s) (Sup t) :=
@cInf_image2_eq_cInf_cInf _ βᵒᵈ _ _ _ _ _ _ _ _ _ h₁ h₂

lemma cInf_image2_eq_cSup_cInf (h₁ : ∀ b, galois_connection (to_dual ∘ l₁ b) (swap u b ∘ of_dual))
  (h₂ : ∀ a, galois_connection (l₂ a) (u a)) :
  s.nonempty → bdd_above s → t.nonempty → bdd_below t → Inf (image2 u s t) = u (Sup s) (Inf t) :=
@cInf_image2_eq_cInf_cInf αᵒᵈ _ _ _ _ _ _ _ _ _ _ h₁ h₂

lemma cInf_image2_eq_cSup_cSup (h₁ : ∀ b, galois_connection (to_dual ∘ l₁ b) (swap u b ∘ of_dual))
  (h₂ : ∀ a, galois_connection (to_dual ∘ l₂ a) (u a ∘ of_dual)) :
  s.nonempty →  bdd_above s → t.nonempty → bdd_above t → Inf (image2 u s t) = u (Sup s) (Sup t) :=
@cInf_image2_eq_cInf_cInf αᵒᵈ βᵒᵈ _ _ _ _ _ _ _ _ _ h₁ h₂

end

/-!
### Relation between `Sup` / `Inf` and `finset.sup'` / `finset.inf'`

Like the `Sup` of a `conditionally_complete_lattice`, `finset.sup'` also requires the set to be
non-empty. As a result, we can translate between the two.
-/

namespace finset

lemma sup'_eq_cSup_image [conditionally_complete_lattice β] (s : finset α) (H) (f : α → β) :
  s.sup' H f = Sup (f '' s) :=
begin
  apply le_antisymm,
  { refine (finset.sup'_le _ _ $ λ a ha, _),
    refine le_cSup ⟨s.sup' H f, _⟩ ⟨a, ha, rfl⟩,
    rintros i ⟨j, hj, rfl⟩,
    exact finset.le_sup' _ hj },
  { apply cSup_le ((coe_nonempty.mpr H).image _),
    rintros _ ⟨a, ha, rfl⟩,
    exact finset.le_sup' _ ha, }
end

lemma inf'_eq_cInf_image [conditionally_complete_lattice β] (s : finset α) (H) (f : α → β) :
  s.inf' H f = Inf (f '' s) :=
@sup'_eq_cSup_image _ βᵒᵈ _ _ _ _

lemma sup'_id_eq_cSup [conditionally_complete_lattice α] (s : finset α) (H) :
  s.sup' H id = Sup s :=
by rw [sup'_eq_cSup_image s H, set.image_id]

lemma inf'_id_eq_cInf [conditionally_complete_lattice α] (s : finset α) (H) :
  s.inf' H id = Inf s :=
@sup'_id_eq_cSup αᵒᵈ _ _ _

end finset

section with_top_bot

/-!
### Complete lattice structure on `with_top (with_bot α)`

If `α` is a `conditionally_complete_lattice`, then we show that `with_top α` and `with_bot α`
also inherit the structure of conditionally complete lattices. Furthermore, we show
that `with_top (with_bot α)` naturally inherits the structure of a complete lattice. Note that
for α a conditionally complete lattice, `Sup` and `Inf` both return junk values
for sets which are empty or unbounded. The extension of `Sup` to `with_top α` fixes
the unboundedness problem and the extension to `with_bot α` fixes the problem with
the empty set.

This result can be used to show that the extended reals [-∞, ∞] are a complete lattice.
-/

open_locale classical

/-- Adding a top element to a conditionally complete lattice
gives a conditionally complete lattice -/
noncomputable instance with_top.conditionally_complete_lattice
  {α : Type*} [conditionally_complete_lattice α] :
  conditionally_complete_lattice (with_top α) :=
{ le_cSup := λ S a hS haS, (with_top.is_lub_Sup' ⟨a, haS⟩).1 haS,
  cSup_le := λ S a hS haS, (with_top.is_lub_Sup' hS).2 haS,
  cInf_le := λ S a hS haS, (with_top.is_glb_Inf' hS).1 haS,
  le_cInf := λ S a hS haS, (with_top.is_glb_Inf' ⟨a, haS⟩).2 haS,
  ..with_top.lattice,
  ..with_top.has_Sup,
  ..with_top.has_Inf }

/-- Adding a bottom element to a conditionally complete lattice
gives a conditionally complete lattice -/
noncomputable instance with_bot.conditionally_complete_lattice
  {α : Type*} [conditionally_complete_lattice α] :
  conditionally_complete_lattice (with_bot α) :=
{ le_cSup := (@with_top.conditionally_complete_lattice αᵒᵈ _).cInf_le,
  cSup_le := (@with_top.conditionally_complete_lattice αᵒᵈ _).le_cInf,
  cInf_le := (@with_top.conditionally_complete_lattice αᵒᵈ _).le_cSup,
  le_cInf := (@with_top.conditionally_complete_lattice αᵒᵈ _).cSup_le,
  ..with_bot.lattice,
  ..with_bot.has_Sup,
  ..with_bot.has_Inf }

noncomputable instance with_top.with_bot.complete_lattice {α : Type*}
  [conditionally_complete_lattice α] : complete_lattice (with_top (with_bot α)) :=
{ le_Sup := λ S a haS, (with_top.is_lub_Sup' ⟨a, haS⟩).1 haS,
  Sup_le := λ S a ha,
    begin
      cases S.eq_empty_or_nonempty with h,
      { show ite _ _ _ ≤ a,
        split_ifs,
        { rw h at h_1, cases h_1 },
        { convert bot_le, convert with_bot.cSup_empty, rw h, refl },
        { exfalso, apply h_2, use ⊥, rw h, rintro b ⟨⟩ } },
      { refine (with_top.is_lub_Sup' h).2 ha }
    end,
  Inf_le := λ S a haS,
    show ite _ _ _ ≤ a,
    begin
      split_ifs,
      { cases a with a, exact le_rfl,
        cases (h haS); tauto },
      { cases a,
        { exact le_top },
        { apply with_top.some_le_some.2, refine cInf_le _ haS, use ⊥, intros b hb, exact bot_le } }
    end,
  le_Inf := λ S a haS, (with_top.is_glb_Inf' ⟨a, haS⟩).2 haS,
  ..with_top.has_Inf,
  ..with_top.has_Sup,
  ..with_top.bounded_order,
  ..with_top.lattice }

noncomputable instance with_top.with_bot.complete_linear_order {α : Type*}
  [conditionally_complete_linear_order α] : complete_linear_order (with_top (with_bot α)) :=
{ .. with_top.with_bot.complete_lattice,
  .. with_top.linear_order }

end with_top_bot

section group

variables {ι' : Sort*} [nonempty ι] [nonempty ι'] [conditionally_complete_lattice α] [group α]

@[to_additive]
lemma le_mul_cinfi [covariant_class α α (*) (≤)] {a : α} {g : α} {h : ι → α}
  (H : ∀ j, a ≤ g * h j) : a ≤ g * infi h :=
inv_mul_le_iff_le_mul.mp $ le_cinfi $ λ hi, inv_mul_le_iff_le_mul.mpr $ H _

@[to_additive]
lemma mul_csupr_le [covariant_class α α (*) (≤)] {a : α} {g : α} {h : ι → α}
  (H : ∀ j, g * h j ≤ a) : g * supr h ≤ a :=
@le_mul_cinfi αᵒᵈ _ _ _ _ _ _ _ _ H

@[to_additive]
lemma le_cinfi_mul [covariant_class α α (function.swap (*)) (≤)] {a : α} {g : ι → α} {h : α}
  (H : ∀ i, a ≤ g i * h) : a ≤ infi g * h :=
mul_inv_le_iff_le_mul.mp $ le_cinfi $ λ gi, mul_inv_le_iff_le_mul.mpr $ H _

@[to_additive]
lemma csupr_mul_le [covariant_class α α (function.swap (*)) (≤)] {a : α} {g : ι → α} {h : α}
  (H : ∀ i, g i * h ≤ a) : supr g * h ≤ a :=
@le_cinfi_mul αᵒᵈ _ _ _ _ _ _ _ _ H

@[to_additive]
lemma le_cinfi_mul_cinfi [covariant_class α α (*) (≤)] [covariant_class α α (function.swap (*)) (≤)]
  {a : α} {g : ι → α} {h : ι' → α} (H : ∀ i j, a ≤ g i * h j) : a ≤ infi g * infi h :=
le_cinfi_mul $ λ i, le_mul_cinfi $ H _

@[to_additive]
lemma csupr_mul_csupr_le [covariant_class α α (*) (≤)] [covariant_class α α (function.swap (*)) (≤)]
  {a : α} {g : ι → α} {h : ι' → α} (H : ∀ i j, g i * h j ≤ a) : supr g * supr h ≤ a :=
csupr_mul_le $ λ i, mul_csupr_le $ H _

end group


import analysis.normed_space.basic

/-!
#  The typeclass `nnnorm_add_class α`

In this file, we introduce the typeclass `nnnorm_add_class α`.

Let `α` be a type with a non-negative norm `∥_∥₊`, a zero `0`, an addition `+` and a negation `-`.

The typeclass `nnnorm_add_class α` requires to prove the identities:
* the nnnorm of `0` is `0` : `∥0∥₊ = 0`;
* the nnnorm of `-x` is equal to the nnnorm of `x`: `∥- x∥₊ = ∥x∥₊`;
* the nnnorm of a sum is at most the sum of the nnnorms: `∥x + y∥₊ ≤ ∥x∥₊ + ∥y∥₊`.
-/

open_locale nnreal

variables (α : Type*) [has_nnnorm α]

/--  A typeclass for an additive monoid `α` with a nnnorm.
Its fields `nnn_zero, nnn_neg, nnn_add_le` assert that
* `∥0∥₊ = 0`;
* `∥- x∥₊ = ∥x∥₊`;
* `∥x + y∥₊ ≤ ∥x∥₊ + ∥y∥₊`.

The class only assumes that `α` has `0, +, -`. -/
class nnnorm_add_class [has_zero α] [has_add α] [has_neg α] : Prop :=
(nnn_zero   : ∥(0 : α)∥₊ = 0)
(nnn_neg    : ∀ ⦃x : α⦄, ∥- x∥₊ = ∥x∥₊)
(nnn_add_le : ∀ ⦃x y : α⦄, ∥x + y∥₊ ≤ ∥x∥₊ + ∥y∥₊)

namespace nnnorm_add_class
variables {α}

section def_lemmas
variables [has_zero α] [has_add α] [has_neg α] [nnnorm_add_class α]

@[simp] lemma nnnorm_zero : ∥(0 : α)∥₊ = 0 := nnn_zero

@[simp] lemma nnnorm_neg (x : α) : ∥- x∥₊ = ∥x∥₊ :=
by apply nnn_neg

lemma nnnorm_add_le (x y : α) : ∥x + y∥₊ ≤ ∥x∥₊ + ∥y∥₊ :=
by apply nnn_add_le

end def_lemmas

variables [add_group α] [nnnorm_add_class α]

lemma nnnorm_sub (x y : α) : ∥x - y∥₊ = ∥y - x∥₊ :=
(nnnorm_neg _).symm.trans (congr_arg _ (neg_sub _ _))

lemma nnnorm_triangle (x y z : α) : ∥x - z∥₊ ≤ ∥x - y∥₊ + ∥y - z∥₊ :=
(le_of_eq (by simp only [sub_add_sub_cancel])).trans (nnnorm_add_le _ _)

end nnnorm_add_class


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

import algebra.algebra.basic
import linear_algebra.prod
import algebra.hom.non_unital_alg

/-!
# Unitization of a non-unital algebra

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

Given a non-unital `R`-algebra `A` (given via the type classes
`[non_unital_ring A] [module R A] [smul_comm_class R A A] [is_scalar_tower R A A]`) we construct
the minimal unital `R`-algebra containing `A` as an ideal. This object `algebra.unitization R A` is
a type synonym for `R × A` on which we place a different multiplicative structure, namely,
`(r₁, a₁) * (r₂, a₂) = (r₁ * r₂, r₁ • a₂ + r₂ • a₁ + a₁ * a₂)` where the multiplicative identity
is `(1, 0)`.

Note, when `A` is a *unital* `R`-algebra, then `unitization R A` constructs a new multiplicative
identity different from the old one, and so in general `unitization R A` and `A` will not be
isomorphic even in the unital case. This approach actually has nice functorial properties.

There is a natural coercion from `A` to `unitization R A` given by `λ a, (0, a)`, the image
of which is a proper ideal (TODO), and when `R` is a field this ideal is maximal. Moreover,
this ideal is always an essential ideal (it has nontrivial intersection with every other nontrivial
ideal).

Every non-unital algebra homomorphism from `A` into a *unital* `R`-algebra `B` has a unique
extension to a (unital) algebra homomorphism from `unitization R A` to `B`.

## Main definitions

* `unitization R A`: the unitization of a non-unital `R`-algebra `A`.
* `unitization.algebra`: the unitization of `A` as a (unital) `R`-algebra.
* `unitization.coe_non_unital_alg_hom`: coercion as a non-unital algebra homomorphism.
* `non_unital_alg_hom.to_alg_hom φ`: the extension of a non-unital algebra homomorphism `φ : A → B`
  into a unital `R`-algebra `B` to an algebra homomorphism `unitization R A →ₐ[R] B`.

## Main results

* `non_unital_alg_hom.to_alg_hom_unique`: the extension is unique

## TODO

* prove the unitization operation is a functor between the appropriate categories
* prove the image of the coercion is an essential ideal, maximal if scalars are a field.
-/

/-- The minimal unitization of a non-unital `R`-algebra `A`. This is just a type synonym for
`R × A`.-/
def unitization (R A : Type*) := R × A

namespace unitization

section basic

variables {R A : Type*}

/-- The canonical inclusion `R → unitization R A`. -/
def inl [has_zero A] (r : R) : unitization R A :=
(r, 0)

/-- The canonical inclusion `A → unitization R A`. -/
instance [has_zero R] : has_coe_t A (unitization R A) := { coe := λ a, (0, a) }

/-- The canonical projection `unitization R A → R`. -/
def fst (x : unitization R A) : R :=
x.1

/-- The canonical projection `unitization R A → A`. -/
def snd (x : unitization R A) : A :=
x.2

@[ext] lemma ext {x y : unitization R A} (h1 : x.fst = y.fst) (h2 : x.snd = y.snd) : x = y :=
prod.ext h1 h2

section
variables (A)
@[simp] lemma fst_inl [has_zero A] (r : R) : (inl r : unitization R A).fst = r := rfl
@[simp] lemma snd_inl [has_zero A] (r : R) : (inl r : unitization R A).snd = 0 := rfl
end

section
variables (R)
@[simp] lemma fst_coe [has_zero R] (a : A) : (a : unitization R A).fst = 0 := rfl
@[simp] lemma snd_coe [has_zero R] (a : A) : (a : unitization R A).snd = a := rfl
end

lemma inl_injective [has_zero A] : function.injective (inl : R → unitization R A) :=
function.left_inverse.injective $ fst_inl _

lemma coe_injective [has_zero R] : function.injective (coe : A → unitization R A) :=
function.left_inverse.injective $ snd_coe _

end basic

/-! ### Structures inherited from `prod`

Additive operators and scalar multiplication operate elementwise. -/

section additive

variables {T : Type*} {S : Type*} {R : Type*} {A : Type*}

instance [inhabited R] [inhabited A] : inhabited (unitization R A) :=
prod.inhabited

instance [has_zero R] [has_zero A] : has_zero (unitization R A) :=
prod.has_zero

instance [has_add R] [has_add A] : has_add (unitization R A) :=
prod.has_add

instance [has_neg R] [has_neg A] : has_neg (unitization R A) :=
prod.has_neg

instance [add_semigroup R] [add_semigroup A] : add_semigroup (unitization R A) :=
prod.add_semigroup

instance [add_zero_class R] [add_zero_class A] : add_zero_class (unitization R A) :=
prod.add_zero_class

instance [add_monoid R] [add_monoid A] : add_monoid (unitization R A) :=
prod.add_monoid

instance [add_group R] [add_group A] : add_group (unitization R A) :=
prod.add_group

instance [add_comm_semigroup R] [add_comm_semigroup A] : add_comm_semigroup (unitization R A) :=
prod.add_comm_semigroup

instance [add_comm_monoid R] [add_comm_monoid A] : add_comm_monoid (unitization R A) :=
prod.add_comm_monoid

instance [add_comm_group R] [add_comm_group A] : add_comm_group (unitization R A) :=
prod.add_comm_group

instance [has_smul S R] [has_smul S A] : has_smul S (unitization R A) :=
prod.has_smul

instance [has_smul T R] [has_smul T A] [has_smul S R] [has_smul S A] [has_smul T S]
  [is_scalar_tower T S R] [is_scalar_tower T S A] : is_scalar_tower T S (unitization R A) :=
prod.is_scalar_tower

instance [has_smul T R] [has_smul T A] [has_smul S R] [has_smul S A]
  [smul_comm_class T S R] [smul_comm_class T S A] : smul_comm_class T S (unitization R A) :=
prod.smul_comm_class

instance [has_smul S R] [has_smul S A] [has_smul Sᵐᵒᵖ R] [has_smul Sᵐᵒᵖ A]
  [is_central_scalar S R] [is_central_scalar S A] : is_central_scalar S (unitization R A) :=
prod.is_central_scalar

instance [monoid S] [mul_action S R] [mul_action S A] : mul_action S (unitization R A) :=
prod.mul_action

instance [monoid S] [add_monoid R] [add_monoid A]
  [distrib_mul_action S R] [distrib_mul_action S A] : distrib_mul_action S (unitization R A) :=
prod.distrib_mul_action

instance [semiring S] [add_comm_monoid R] [add_comm_monoid A]
  [module S R] [module S A] : module S (unitization R A) :=
prod.module

@[simp] lemma fst_zero [has_zero R] [has_zero A] : (0 : unitization R A).fst = 0 := rfl
@[simp] lemma snd_zero [has_zero R] [has_zero A] : (0 : unitization R A).snd = 0 := rfl

@[simp] lemma fst_add [has_add R] [has_add A] (x₁ x₂ : unitization R A) :
  (x₁ + x₂).fst = x₁.fst + x₂.fst := rfl
@[simp] lemma snd_add [has_add R] [has_add A] (x₁ x₂ : unitization R A) :
  (x₁ + x₂).snd = x₁.snd + x₂.snd := rfl

@[simp] lemma fst_neg [has_neg R] [has_neg A] (x : unitization R A) : (-x).fst = -x.fst := rfl
@[simp] lemma snd_neg [has_neg R] [has_neg A] (x : unitization R A) : (-x).snd = -x.snd := rfl

@[simp] lemma fst_smul [has_smul S R] [has_smul S A] (s : S) (x : unitization R A) :
  (s • x).fst = s • x.fst := rfl
@[simp] lemma snd_smul [has_smul S R] [has_smul S A] (s : S) (x : unitization R A) :
  (s • x).snd = s • x.snd := rfl

section
variables (A)

@[simp] lemma inl_zero [has_zero R] [has_zero A] : (inl 0 : unitization R A) = 0 := rfl

@[simp] lemma inl_add [has_add R] [add_zero_class A] (r₁ r₂ : R) :
  (inl (r₁ + r₂) : unitization R A) = inl r₁ + inl r₂ :=
ext rfl (add_zero 0).symm

@[simp] lemma inl_neg [has_neg R] [add_group A] (r : R) :
  (inl (-r) : unitization R A) = -inl r :=
ext rfl neg_zero.symm

@[simp] lemma inl_smul [monoid S] [add_monoid A] [has_smul S R] [distrib_mul_action S A]
  (s : S) (r : R) : (inl (s • r) : unitization R A) = s • inl r :=
ext rfl (smul_zero s).symm

end

section
variables (R)

@[simp] lemma coe_zero [has_zero R] [has_zero A] : ↑(0 : A) = (0 : unitization R A) := rfl

@[simp] lemma coe_add [add_zero_class R] [has_add A] (m₁ m₂ : A) :
  (↑(m₁ + m₂) : unitization R A)  = m₁ + m₂ :=
ext (add_zero 0).symm rfl

@[simp] lemma coe_neg [add_group R] [has_neg A] (m : A) :
  (↑(-m) : unitization R A) = -m :=
ext neg_zero.symm rfl

@[simp] lemma coe_smul [has_zero R] [has_zero S] [smul_with_zero S R] [has_smul S A]
  (r : S) (m : A) : (↑(r • m) : unitization R A) = r • m :=
ext (smul_zero _).symm rfl

end

lemma inl_fst_add_coe_snd_eq [add_zero_class R] [add_zero_class A] (x : unitization R A) :
  inl x.fst + ↑x.snd = x :=
ext (add_zero x.1) (zero_add x.2)

/-- To show a property hold on all `unitization R A` it suffices to show it holds
on terms of the form `inl r + a`.

This can be used as `induction x using unitization.ind`. -/
lemma ind {R A} [add_zero_class R] [add_zero_class A] {P : unitization R A → Prop}
  (h : ∀ (r : R) (a : A), P (inl r + a)) (x) : P x :=
inl_fst_add_coe_snd_eq x ▸ h x.1 x.2

/-- This cannot be marked `@[ext]` as it ends up being used instead of `linear_map.prod_ext` when
working with `R × A`. -/
lemma linear_map_ext {N} [semiring S] [add_comm_monoid R] [add_comm_monoid A] [add_comm_monoid N]
  [module S R] [module S A] [module S N] ⦃f g : unitization R A →ₗ[S] N⦄
  (hl : ∀ r, f (inl r) = g (inl r)) (hr : ∀ a : A, f a = g a) :
  f = g :=
linear_map.prod_ext (linear_map.ext hl) (linear_map.ext hr)

variables (R A)

/-- The canonical `R`-linear inclusion `A → unitization R A`. -/
@[simps apply]
def coe_hom [semiring R] [add_comm_monoid A] [module R A] : A →ₗ[R] unitization R A :=
{ to_fun := coe, ..linear_map.inr R R A }

/-- The canonical `R`-linear projection `unitization R A → A`. -/
@[simps apply]
def snd_hom [semiring R] [add_comm_monoid A] [module R A] : unitization R A →ₗ[R] A :=
{ to_fun := snd, ..linear_map.snd _ _ _ }

end additive

/-! ### Multiplicative structure -/

section mul
variables {R A : Type*}

instance [has_one R] [has_zero A] : has_one (unitization R A) :=
⟨(1, 0)⟩

instance [has_mul R] [has_add A] [has_mul A] [has_smul R A] : has_mul (unitization R A) :=
⟨λ x y, (x.1 * y.1, x.1 • y.2 + y.1 • x.2 + x.2 * y.2)⟩

@[simp] lemma fst_one [has_one R] [has_zero A] : (1 : unitization R A).fst = 1 := rfl
@[simp] lemma snd_one [has_one R] [has_zero A] : (1 : unitization R A).snd = 0 := rfl

@[simp] lemma fst_mul [has_mul R] [has_add A] [has_mul A] [has_smul R A]
  (x₁ x₂ : unitization R A) : (x₁ * x₂).fst = x₁.fst * x₂.fst := rfl
@[simp] lemma snd_mul [has_mul R] [has_add A] [has_mul A] [has_smul R A]
  (x₁ x₂ : unitization R A) : (x₁ * x₂).snd = x₁.fst • x₂.snd + x₂.fst • x₁.snd + x₁.snd * x₂.snd :=
rfl

section
variables (A)

@[simp] lemma inl_one [has_one R] [has_zero A] : (inl 1 : unitization R A) = 1 := rfl

@[simp] lemma inl_mul [monoid R] [non_unital_non_assoc_semiring A] [distrib_mul_action R A]
  (r₁ r₂ : R) : (inl (r₁ * r₂) : unitization R A) = inl r₁ * inl r₂ :=
ext rfl $ show (0 : A) = r₁ • (0 : A) + r₂ • 0 + 0 * 0, by simp only [smul_zero, add_zero, mul_zero]

lemma inl_mul_inl [monoid R] [non_unital_non_assoc_semiring A] [distrib_mul_action R A]
  (r₁ r₂ : R) : (inl r₁ * inl r₂ : unitization R A) = inl (r₁ * r₂) :=
(inl_mul A r₁ r₂).symm

end

section
variables (R)

@[simp]

end

lemma inl_mul_coe [semiring R] [non_unital_non_assoc_semiring A] [distrib_mul_action R A]
  (r : R) (a : A) : (inl r * a : unitization R A) = ↑(r • a) :=
ext (mul_zero r) $ show r • a + (0 : R) • 0 + 0 * a = r • a,
  by rw [smul_zero, add_zero, zero_mul, add_zero]

lemma coe_mul_inl [semiring R] [non_unital_non_assoc_semiring A] [distrib_mul_action R A]
  (r : R) (a : A) : (a * inl r : unitization R A) = ↑(r • a) :=
ext (zero_mul r) $ show (0 : R) • 0 + r • a + a * 0 = r • a,
  by rw [smul_zero, zero_add, mul_zero, add_zero]

instance mul_one_class [monoid R] [non_unital_non_assoc_semiring A] [distrib_mul_action R A] :
  mul_one_class (unitization R A) :=
{ one_mul := λ x, ext (one_mul x.1) $ show (1 : R) • x.2 + x.1 • 0 + 0 * x.2 = x.2,
    by rw [one_smul, smul_zero, add_zero, zero_mul, add_zero],
  mul_one := λ x, ext (mul_one x.1) $ show (x.1 • 0 : A) + (1 : R) • x.2 + x.2 * 0 = x.2,
    by rw [smul_zero, zero_add, one_smul, mul_zero, add_zero],
  .. unitization.has_one,
  .. unitization.has_mul }

instance [semiring R] [non_unital_non_assoc_semiring A] [module R A] :
  non_assoc_semiring (unitization R A) :=
{ zero_mul := λ x, ext (zero_mul x.1) $ show (0 : R) • x.2 + x.1 • 0 + 0 * x.2 = 0,
    by rw [zero_smul, zero_add, smul_zero, zero_mul, add_zero],
  mul_zero := λ x, ext (mul_zero x.1) $ show (x.1 • 0 : A) + (0 : R) • x.2 + x.2 * 0 = 0,
    by rw [smul_zero, zero_add, zero_smul, mul_zero, add_zero],
  left_distrib := λ x₁ x₂ x₃, ext (mul_add x₁.1 x₂.1 x₃.1) $
    show x₁.1 • (x₂.2 + x₃.2) + (x₂.1 + x₃.1) • x₁.2 + x₁.2 * (x₂.2 + x₃.2) =
      x₁.1 • x₂.2 + x₂.1 • x₁.2 + x₁.2 * x₂.2 + (x₁.1 • x₃.2 + x₃.1 • x₁.2 + x₁.2 * x₃.2),
    by { simp only [smul_add, add_smul, mul_add], abel },
  right_distrib := λ x₁ x₂ x₃, ext (add_mul x₁.1 x₂.1 x₃.1) $
    show (x₁.1 + x₂.1) • x₃.2 + x₃.1 • (x₁.2 + x₂.2) + (x₁.2 + x₂.2) * x₃.2 =
      x₁.1 • x₃.2 + x₃.1 • x₁.2 + x₁.2 * x₃.2 + (x₂.1 • x₃.2 + x₃.1 • x₂.2 + x₂.2 * x₃.2),
    by { simp only [add_smul, smul_add, add_mul], abel },
  .. unitization.mul_one_class,
  .. unitization.add_comm_monoid }

instance [comm_monoid R] [non_unital_semiring A] [distrib_mul_action R A] [is_scalar_tower R A A]
  [smul_comm_class R A A] : monoid (unitization R A) :=
{ mul_assoc := λ x y z, ext (mul_assoc x.1 y.1 z.1) $
    show (x.1 * y.1) • z.2 + z.1 • (x.1 • y.2 + y.1 • x.2 + x.2 * y.2) +
      (x.1 • y.2 + y.1 • x.2 + x.2 * y.2) * z.2 =
      x.1 • (y.1 • z.2 + z.1 • y.2 + y.2 * z.2) + (y.1 * z.1) • x.2 +
      x.2 * (y.1 • z.2 + z.1 • y.2 + y.2 * z.2),
    { simp only [smul_add, mul_add, add_mul, smul_smul, smul_mul_assoc, mul_smul_comm, mul_assoc],
      nth_rewrite 1 mul_comm,
      nth_rewrite 2 mul_comm,
      abel },
  ..unitization.mul_one_class }

instance [comm_monoid R] [non_unital_comm_semiring A] [distrib_mul_action R A]
  [is_scalar_tower R A A] [smul_comm_class R A A] : comm_monoid (unitization R A) :=
{ mul_comm := λ x₁ x₂, ext (mul_comm x₁.1 x₂.1) $
    show x₁.1 • x₂.2 + x₂.1 • x₁.2 + x₁.2 * x₂.2 = x₂.1 • x₁.2 + x₁.1 • x₂.2 + x₂.2 * x₁.2,
    by rw [add_comm (x₁.1 • x₂.2), mul_comm],
  ..unitization.monoid }

instance [comm_semiring R] [non_unital_semiring A] [module R A] [is_scalar_tower R A A]
  [smul_comm_class R A A] : semiring (unitization R A) :=
{ ..unitization.monoid,
  ..unitization.non_assoc_semiring }

instance [comm_semiring R] [non_unital_comm_semiring A] [module R A] [is_scalar_tower R A A]
  [smul_comm_class R A A] : comm_semiring (unitization R A) :=
{ ..unitization.comm_monoid,
  ..unitization.non_assoc_semiring }

variables (R A)

/-- The canonical inclusion of rings `R →+* unitization R A`. -/
@[simps apply]
def inl_ring_hom [semiring R] [non_unital_semiring A] [module R A] : R →+* unitization R A :=
{ to_fun := inl,
  map_one' := inl_one A,
  map_mul' := inl_mul A,
  map_zero' := inl_zero A,
  map_add' := inl_add A }

end mul

/-! ### Star structure -/

section star

variables {R A : Type*}

instance [has_star R] [has_star A] : has_star (unitization R A) :=
⟨λ ra, (star ra.fst, star ra.snd)⟩

@[simp] lemma fst_star [has_star R] [has_star A] (x : unitization R A) :
  (star x).fst = star x.fst := rfl

@[simp] lemma snd_star [has_star R] [has_star A] (x : unitization R A) :
  (star x).snd = star x.snd := rfl

@[simp] lemma inl_star [has_star R] [add_monoid A] [star_add_monoid A] (r : R) :
  inl (star r) = star (inl r : unitization R A) :=
ext rfl (by simp only [snd_star, star_zero, snd_inl])

@[simp] lemma coe_star [add_monoid R] [star_add_monoid R] [has_star A] (a : A) :
  ↑(star a) = star (a : unitization R A) :=
ext (by simp only [fst_star, star_zero, fst_coe]) rfl

instance [add_monoid R] [add_monoid A] [star_add_monoid R] [star_add_monoid A] :
  star_add_monoid (unitization R A) :=
{ star_involutive := λ x, ext (star_star x.fst) (star_star x.snd),
  star_add := λ x y, ext (star_add x.fst y.fst) (star_add x.snd y.snd) }

instance [comm_semiring R] [star_ring R] [add_comm_monoid A] [star_add_monoid A]
  [module R A] [star_module R A] : star_module R (unitization R A) :=
{ star_smul := λ r x, ext (by simp) (by simp) }

instance [comm_semiring R] [star_ring R] [non_unital_semiring A] [star_ring A]
  [module R A] [is_scalar_tower R A A] [smul_comm_class R A A] [star_module R A] :
  star_ring (unitization R A) :=
{ star_mul := λ x y, ext (by simp [star_mul])
    (by simp [star_mul, add_comm (star x.fst • star y.snd)]),
  ..unitization.star_add_monoid }

end star

/-! ### Algebra structure -/

section algebra
variables (S R A : Type*)
[comm_semiring S] [comm_semiring R] [non_unital_semiring A]
[module R A] [is_scalar_tower R A A] [smul_comm_class R A A]
[algebra S R] [distrib_mul_action S A] [is_scalar_tower S R A]

instance algebra : algebra S (unitization R A) :=
{ commutes' := λ r x,
  begin
    induction x using unitization.ind,
    simp only [mul_add, add_mul, ring_hom.to_fun_eq_coe, ring_hom.coe_comp, function.comp_app,
      inl_ring_hom_apply, inl_mul_inl],
    rw [inl_mul_coe, coe_mul_inl, mul_comm]
  end,
  smul_def' := λ s x,
  begin
    induction x using unitization.ind,
    simp only [mul_add, smul_add, ring_hom.to_fun_eq_coe, ring_hom.coe_comp, function.comp_app,
      inl_ring_hom_apply, algebra.algebra_map_eq_smul_one],
    rw [inl_mul_inl, inl_mul_coe, smul_one_mul, inl_smul, coe_smul, smul_one_smul]
  end,
  ..(unitization.inl_ring_hom R A).comp (algebra_map S R) }

lemma algebra_map_eq_inl_comp : ⇑(algebra_map S (unitization R A)) = inl ∘ algebra_map S R := rfl
lemma algebra_map_eq_inl_ring_hom_comp :
  algebra_map S (unitization R A) = (inl_ring_hom R A).comp (algebra_map S R) := rfl
lemma algebra_map_eq_inl : ⇑(algebra_map R (unitization R A)) = inl := rfl
lemma algebra_map_eq_inl_hom : algebra_map R (unitization R A) = inl_ring_hom R A := rfl

/-- The canonical `R`-algebra projection `unitization R A → R`. -/
@[simps]
def fst_hom : unitization R A →ₐ[R] R :=
{ to_fun := fst,
  map_one' := fst_one,
  map_mul' := fst_mul,
  map_zero' := fst_zero,
  map_add' := fst_add,
  commutes' := fst_inl A }

end algebra

section coe

/-- The coercion from a non-unital `R`-algebra `A` to its unitization `unitization R A`
realized as a non-unital algebra homomorphism. -/
@[simps]
def coe_non_unital_alg_hom (R A : Type*) [comm_semiring R] [non_unital_semiring A] [module R A] :
  A →ₙₐ[R] unitization R A :=
{ to_fun := coe,
  map_smul' := coe_smul R,
  map_zero' := coe_zero R,
  map_add' := coe_add R,
  map_mul' := coe_mul R }

end coe

section alg_hom

variables {S R A : Type*}
  [comm_semiring S] [comm_semiring R] [non_unital_semiring A]
  [module R A] [smul_comm_class R A A] [is_scalar_tower R A A]
  {B : Type*} [semiring B] [algebra S B]
  [algebra S R] [distrib_mul_action S A] [is_scalar_tower S R A]
  {C : Type*} [ring C] [algebra R C]

lemma alg_hom_ext {φ ψ : unitization R A →ₐ[S] B} (h : ∀ a : A, φ a = ψ a)
  (h' : ∀ r, φ (algebra_map R (unitization R A) r) = ψ (algebra_map R (unitization R A) r)) :
  φ = ψ :=
begin
  ext,
  induction x using unitization.ind,
  simp only [map_add, ←algebra_map_eq_inl, h, h'],
end

/-- See note [partially-applied ext lemmas] -/
@[ext]
lemma alg_hom_ext' {φ ψ : unitization R A →ₐ[R] C}
  (h : φ.to_non_unital_alg_hom.comp (coe_non_unital_alg_hom R A) =
    ψ.to_non_unital_alg_hom.comp (coe_non_unital_alg_hom R A)) :
  φ = ψ :=
alg_hom_ext (non_unital_alg_hom.congr_fun h) (by simp [alg_hom.commutes])

/-- Non-unital algebra homomorphisms from `A` into a unital `R`-algebra `C` lift uniquely to
`unitization R A →ₐ[R] C`. This is the universal property of the unitization. -/
@[simps apply_apply]
def lift : (A →ₙₐ[R] C) ≃ (unitization R A →ₐ[R] C) :=
{ to_fun := λ φ,
  { to_fun := λ x, algebra_map R C x.fst + φ x.snd,
    map_one' := by simp only [fst_one, map_one, snd_one, φ.map_zero, add_zero],
    map_mul' := λ x y,
    begin
      induction x using unitization.ind,
      induction y using unitization.ind,
      simp only [mul_add, add_mul, coe_mul, fst_add, fst_mul, fst_inl, fst_coe, mul_zero,
        add_zero, zero_mul, map_mul, snd_add, snd_mul, snd_inl, smul_zero, snd_coe, zero_add,
        φ.map_add, φ.map_smul, φ.map_mul, zero_smul, zero_add],
      rw ←algebra.commutes _ (φ x_a),
      simp only [algebra.algebra_map_eq_smul_one, smul_one_mul, add_assoc],
    end,
    map_zero' := by simp only [fst_zero, map_zero, snd_zero, φ.map_zero, add_zero],
    map_add' := λ x y,
    begin
      induction x using unitization.ind,
      induction y using unitization.ind,
      simp only [fst_add, fst_inl, fst_coe, add_zero, map_add, snd_add, snd_inl, snd_coe, zero_add,
        φ.map_add],
      rw add_add_add_comm,
    end,
    commutes' := λ r, by simp only [algebra_map_eq_inl, fst_inl, snd_inl, φ.map_zero, add_zero] },
  inv_fun := λ φ, φ.to_non_unital_alg_hom.comp (coe_non_unital_alg_hom R A),
  left_inv := λ φ, by { ext, simp, },
  right_inv := λ φ, unitization.alg_hom_ext' (by { ext, simp }), }

lemma lift_symm_apply (φ : unitization R A →ₐ[R] C) (a : A) :
  unitization.lift.symm φ a = φ a := rfl

end alg_hom

end unitization


/-
Copyright (c) 2021 Damiano Testa. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Damiano Testa
-/
import algebra.group.defs
import logic.embedding.basic

/-!
# The embedding of a cancellative semigroup into itself by multiplication by a fixed element.

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

variables {R : Type*}

section left_or_right_cancel_semigroup

/--
The embedding of a left cancellative semigroup into itself
by left multiplication by a fixed element.
 -/
@[to_additive
  "The embedding of a left cancellative additive semigroup into itself
   by left translation by a fixed element.", simps]
def mul_left_embedding {G : Type*} [left_cancel_semigroup G] (g : G) : G ↪ G :=
{ to_fun := λ h, g * h, inj' := mul_right_injective g }

/--
The embedding of a right cancellative semigroup into itself
by right multiplication by a fixed element.
 -/
@[to_additive
  "The embedding of a right cancellative additive semigroup into itself
   by right translation by a fixed element.", simps]
def mul_right_embedding {G : Type*} [right_cancel_semigroup G] (g : G) : G ↪ G :=
{ to_fun := λ h, h * g, inj' := mul_left_injective g }

@[to_additive]
lemma mul_left_embedding_eq_mul_right_embedding {G : Type*} [cancel_comm_monoid G] (g : G) :
  mul_left_embedding g = mul_right_embedding g :=
by { ext, exact mul_comm _ _ }

end left_or_right_cancel_semigroup


/-
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

! This file was ported from Lean 3 source module topology.order.priestley
! leanprover-community/mathlib commit 4c19a16e4b705bf135cf9a80ac18fcc99c438514
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathlib.Order.UpperLower.Basic
import Mathlib.Topology.Separation

/-!
# Priestley spaces

This file defines Priestley spaces. A Priestley space is an ordered compact topological space such
that any two distinct points can be separated by a clopen upper set.

## Main declarations

* `PriestleySpace`: Prop-valued mixin stating the Priestley separation axiom: Any two distinct
  points can be separated by a clopen upper set.

## Implementation notes

We do not include compactness in the definition, so a Priestley space is to be declared as follows:
`[Preorder α] [TopologicalSpace α] [CompactSpace α] [PriestleySpace α]`

## References

* [Wikipedia, *Priestley space*](https://en.wikipedia.org/wiki/Priestley_space)
* [Davey, Priestley *Introduction to Lattices and Order*][davey_priestley]
-/

open Set

variable {α : Type _}

/-- A Priestley space is an ordered topological space such that any two distinct points can be
separated by a clopen upper set. Compactness is often assumed, but we do not include it here. -/
class PriestleySpace (α : Type _) [Preorder α] [TopologicalSpace α] where
  priestley {x y : α} : ¬x ≤ y → ∃ U : Set α, IsClopen U ∧ IsUpperSet U ∧ x ∈ U ∧ y ∉ U
#align priestley_space PriestleySpace

variable [TopologicalSpace α]

section Preorder

variable [Preorder α] [PriestleySpace α] {x y : α}

theorem exists_clopen_upper_of_not_le :
    ¬x ≤ y → ∃ U : Set α, IsClopen U ∧ IsUpperSet U ∧ x ∈ U ∧ y ∉ U :=
  PriestleySpace.priestley
#align exists_clopen_upper_of_not_le exists_clopen_upper_of_not_le

theorem exists_clopen_lower_of_not_le (h : ¬x ≤ y) :
    ∃ U : Set α, IsClopen U ∧ IsLowerSet U ∧ x ∉ U ∧ y ∈ U :=
  let ⟨U, hU, hU', hx, hy⟩ := exists_clopen_upper_of_not_le h
  ⟨Uᶜ, hU.compl, hU'.compl, Classical.not_not.2 hx, hy⟩
#align exists_clopen_lower_of_not_le exists_clopen_lower_of_not_le

end Preorder

section PartialOrder

variable [PartialOrder α] [PriestleySpace α] {x y : α}

theorem exists_clopen_upper_or_lower_of_ne (h : x ≠ y) :
    ∃ U : Set α, IsClopen U ∧ (IsUpperSet U ∨ IsLowerSet U) ∧ x ∈ U ∧ y ∉ U := by
  obtain h | h := h.not_le_or_not_le
  · exact (exists_clopen_upper_of_not_le h).imp fun _ ↦ And.imp_right <| And.imp_left Or.inl
  · obtain ⟨U, hU, hU', hy, hx⟩ := exists_clopen_lower_of_not_le h
    exact ⟨U, hU, Or.inr hU', hx, hy⟩
#align exists_clopen_upper_or_lower_of_ne exists_clopen_upper_or_lower_of_ne

-- See note [lower instance priority]
instance (priority := 100) PriestleySpace.toT2Space : T2Space α :=
  ⟨fun _ _ h ↦
    let ⟨U, hU, _, hx, hy⟩ := exists_clopen_upper_or_lower_of_ne h
    ⟨U, Uᶜ, hU.isOpen, hU.compl.isOpen, hx, hy, disjoint_compl_right⟩⟩
#align priestley_space.to_t2_space PriestleySpace.toT2Space

end PartialOrder


/-
Copyright (c) 2021 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Scott Morrison
-/
import algebra.homology.homotopy
import algebra.category.Module.abelian
import algebra.category.Module.subobject

/-!
# Complexes of modules

We provide some additional API to work with homological complexes in `Module R`.
-/

universes v u

open_locale classical
noncomputable theory

open category_theory category_theory.limits homological_complex

variables {R : Type v} [ring R]
variables {ι : Type*} {c : complex_shape ι} {C D : homological_complex (Module.{u} R) c}

namespace Module

/--
To prove that two maps out of a homology group are equal,
it suffices to check they are equal on the images of cycles.
-/
lemma homology_ext {L M N K : Module R} {f : L ⟶ M} {g : M ⟶ N} (w : f ≫ g = 0)
  {h k : homology f g w ⟶ K}
  (w : ∀ (x : linear_map.ker g),
    h (cokernel.π (image_to_kernel _ _ w) (to_kernel_subobject x)) =
      k (cokernel.π (image_to_kernel _ _ w) (to_kernel_subobject x))) : h = k :=
begin
  refine cokernel_funext (λ n, _),
  -- Gosh it would be nice if `equiv_rw` could directly use an isomorphism, or an enriched `≃`.
  equiv_rw (kernel_subobject_iso g ≪≫ Module.kernel_iso_ker g).to_linear_equiv.to_equiv at n,
  convert w n; simp [to_kernel_subobject],
end

/-- Bundle an element `C.X i` such that `C.d_from i x = 0` as a term of `C.cycles i`. -/
abbreviation to_cycles {C : homological_complex (Module.{u} R) c}
  {i : ι} (x : linear_map.ker (C.d_from i)) : C.cycles i :=
to_kernel_subobject x

@[ext]
lemma cycles_ext {C : homological_complex (Module.{u} R) c} {i : ι}
  {x y : C.cycles i} (w : (C.cycles i).arrow x = (C.cycles i).arrow y) : x = y :=
begin
  apply_fun (C.cycles i).arrow using (Module.mono_iff_injective _).mp (cycles C i).arrow_mono,
  exact w,
end

local attribute [instance] concrete_category.has_coe_to_sort

@[simp] lemma cycles_map_to_cycles (f : C ⟶ D) {i : ι} (x : linear_map.ker (C.d_from i)) :
  (cycles_map f i) (to_cycles x) = to_cycles ⟨f.f i x.1, by simp [x.2]⟩ :=
by { ext, simp, }

/-- Build a term of `C.homology i` from an element `C.X i` such that `C.d_from i x = 0`. -/
abbreviation to_homology
  {C : homological_complex (Module.{u} R) c} {i : ι} (x : linear_map.ker (C.d_from i)) :
  C.homology i :=
homology.π (C.d_to i) (C.d_from i) _ (to_cycles x)

@[ext]
lemma homology_ext' {M : Module R} (i : ι) {h k : C.homology i ⟶ M}
  (w : ∀ (x : linear_map.ker (C.d_from i)), h (to_homology x) = k (to_homology x)) :
  h = k :=
homology_ext _ w

/-- We give an alternative proof of `homology_map_eq_of_homotopy`,
specialized to the setting of `V = Module R`,
to demonstrate the use of extensionality lemmas for homology in `Module R`. -/
example (f g : C ⟶ D) (h : homotopy f g) (i : ι) :
  (homology_functor (Module.{u} R) c i).map f = (homology_functor (Module.{u} R) c i).map g :=
begin
  -- To check that two morphisms out of a homology group agree, it suffices to check on cycles:
  ext,
  dsimp,
  simp only [homology.π_map_apply],
  -- To check that two elements are equal mod boundaries, it suffices to exhibit a boundary:
  ext1,
  swap, exact (to_prev i h.hom) x.1,
  -- Moreover, to check that two cycles are equal, it suffices to check their underlying elements:
  ext1,
  simp [h.comm i, x.2]; abel,
end

end Module


/-
Copyright (c) 2022 Sina Hazratpour. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
----------------

# A short introduction to type classes
Sina Hazratpour
Introduction to Proof
MATH 301, Johns Hopkins University, Fall 2022
-/

import ..prooflab
import .lec10_surj_inj_fact

namespace PROOFS

namespace STR

-- the bundled structure of types with a point in them
structure pointed_type :=
(type : Type)
(point : type)

#check unit
#check unit.star
#check @unit.ext

local notation `𝟙` := unit -- type as \b1
local notation `⋆` := unit.star
#check ⋆

/- 𝟙 is a pointed type but `empty` is not.-/
def unit_ptd : pointed_type  :=
{
  type := 𝟙, -- if you change 𝟙 to `empty`, you cannot provide for the second field any longer.
  point := ⋆,
}

#check unit_ptd

def bool_ptd : pointed_type :=
{
  type := bool,
  point := ff,
}

def nat_ptd : pointed_type :=
{
  type := ℕ,
  point := 0,
}

structure Q2 :=
(x : ℚ)
(y : ℚ)

def Q2_ptd : pointed_type :=
{
  type := Q2,
  point := ⟨0,0⟩,
}

def R3_ptd : pointed_type :=
{
  type := R3,
  point := ⟨0,0,0⟩,
}

namespace pointed_type
variables {A B : pointed_type}

/- The __product__ of two pointed types is a pointed type.

  The attribute `@[simps point]` in below  is a hint to `simp` that it can unfold the point of this definition. -/

@[simps point]
def product (A B : pointed_type) : pointed_type :=
{
  type := A.type × B.type,
  point := (A.point, B.point),
}

#check product

#check product nat_ptd Q2_ptd
#check (product nat_ptd Q2_ptd).point
#eval (product nat_ptd Q2_ptd).point

#eval (product nat_ptd bool_ptd).point -- type classes help with this

@[ext]
structure morphism (A B : pointed_type) :=
(to_fun : A.type → B.type)
(resp_pt : to_fun A.point = B.point)

end pointed_type

#check pointed_type.product
#print pointed_type.morphism
#check @pointed_type.morphism.to_fun

infix ` →• `:25 := pointed_type.morphism

namespace pointed_type
variables {A B C D : pointed_type}

@[simp]
def compose (g : B →• C) (f : A →• B) : A →• C :=
{
  to_fun := g.to_fun ∘ f.to_fun,
  resp_pt := by {dsimp, rw f.resp_pt, exact g.resp_pt,},
}

def id : A →• A :=
{
  to_fun := id,
  resp_pt := rfl,
}

infixr  ` ∘• ` : 90  := compose

lemma comp_assoc {g : A →• B} {k : B →• C} {l : C →• D}: l ∘• (k ∘• g) = (l ∘• k) ∘• g :=
begin
  simp,
end

end pointed_type
end STR

namespace type_classes

variables X Y Z U V W : Type

/-! ### Inhabited types -/
-- @[class] structure has_element (X : Type) : Prop := (some_el : ∃ x : X, true)

-- This is an example of an unbundle type : the structure of all elements of `X`

@[class] -- the new bit
structure has_element (X : Type) :=
(el [] : X) -- el is a generic element of X, it has no other propetry than being an element of X.

section
#check has_element -- it is a function which provides for any type `X` the type of its elements
#check has_element X -- the type of elements of X -- compare this to the example of upper bounds from HW7
#print has_element
#check has_element.el
#print has_element.el -- the [] bracket makes X  in Π (X : Type u_10) explicit.
end

@[instance] -- the new bit
def natural : has_element ℕ :=
{ el := 0 }

/-
A shorthand for `@[instance] def` is `instance`.
-/

instance integer : has_element ℤ :=
{ el := 0 }

instance boolean : has_element bool :=
{ el := ff }

instance unit : has_element unit :=
{ el := () }

instance list {X : Type} : has_element (list X):=
{ el := [] }

namespace has_element
/- The product of two types, each with an element, has an element.-/
instance product {A B : Type} [has_element A] [has_element B] :
  has_element (A × B) :=
{
  el := (has_element.el A, has_element.el B),
}

/-! ### Instance Synthesis

**Based on the type, Lean retrieves the relevant instances.**

Whenever the elaborator is looking for a value to assign to an argument `?M` of type `has_element X` for some `X`, it can check the list for a suitable instance: For example, if it looking for an instance of `has_element nat` and `has_element bool`, it will find respectively `bool.has_element` and `nat.has_element`.

Then Lean synthesizes these instances with the instance `prod.has_element` to know that the product `ℕ × bool` is nonempty.
-/

section
#check has_element (ℕ × bool)
#check has_element.el (ℕ × bool) -- how does Lean know that `ℕ × bool` has an elemnet? that is how does it know an instance of `has_element` structure for the type `ℕ × bool`? Well, `ℕ × bool` is a product type, so to have an instance `has_element` for it, Lean will look for an instance of `has_element` for product types which we defined above (see `product`). `prodcut` instance tells us that to have a  `has_element` structure for a product `A × B` it is enough to have a `has_element` structure for `A` and a `has_element` structure for `B`. But, in our situation `A` is `ℕ` and `B` is `bool`. So, Lean's task now is to find instances `has_element` structure for `nat` and for `bool` which are provided by `has_element.natural` and `has_element.boolean`. We actually do not need to provide any of these names explicitly in constructing an element of `ℕ × bool`; Lean's instance synthesis does it automatically for us.
#eval has_element.el (ℕ × bool)
end

-- we can do this by explicitly naming the instances of `has_element A` and `has_element B`, although this is against the automation spirit of using Lean.
instance product_alt {A B : Type} [hA : has_element A] [hB : has_element B] :
  has_element (A × B) :=
{ el := ⟨hA.el, hB.el⟩ }

@[instance] def fun_from_empty {Y : Type} :
  has_element (empty → Y) :=
{ el := λ a : empty, match a with end }

#reduce has_element.el (empty → empty)

class morphism (X Y : Type) [has_element X] [has_element Y] :=
(to_fun : X → Y)
(resp_el : to_fun (has_element.el X) = has_element.el Y)

instance unit_to_bool : morphism unit bool :=
{
  to_fun := λ x, ff, -- try changing `ff` to `tt`. Does it work? why not?
  resp_el := by {refl},
}

instance bool_to_nat : morphism bool nat :=
{
  to_fun := nat_of_bool,
  resp_el := by {refl},
}

#check has_element.bool_to_nat

end has_element

end type_classes

end PROOFS


import algebra.char_p.basic
import algebra.euclidean_domain.defs

import lib.wronskian
import lib.div_radical
import lib.max3

noncomputable theory
open_locale polynomial classical

open polynomial
open unique_factorization_monoid

variables {k: Type*} [field k]

@[simp]
lemma dvd_derivative_iff {a : k[X]} :
  a ∣ a.derivative ↔ a.derivative = 0 :=
begin
  split,
  intro h,
  by_cases a_nz : a = 0,
  { rw a_nz, simp only [derivative_zero], },
  by_contra deriv_nz,
  have deriv_lt := degree_derivative_lt a_nz,
  have le_deriv := polynomial.degree_le_of_dvd h deriv_nz,
  have lt_self := le_deriv.trans_lt deriv_lt,
  simp only [lt_self_iff_false] at lt_self, exact lt_self,

  intro h, rw h, simp,
end

lemma is_coprime.wronskian_eq_zero_iff
  {a b : k[X]} (hc: is_coprime a b) :
  wronskian a b = 0 ↔ (a.derivative = 0 ∧ b.derivative = 0) :=
begin
  split,

  intro hw,
  rw [wronskian, sub_eq_iff_eq_add, zero_add] at hw,
  split,
  { rw ←dvd_derivative_iff,
    apply hc.dvd_of_dvd_mul_right,
    rw ←hw, exact dvd_mul_right _ _, },
  { rw ←dvd_derivative_iff,
    apply hc.symm.dvd_of_dvd_mul_left,
    rw hw, exact dvd_mul_left _ _, },

  intro hdab,
  cases hdab with hda hdb,
  rw wronskian,
  rw [hda, hdb], simp only [mul_zero, zero_mul, sub_self],
end

/- ABC for polynomials (Mason-Stothers theorem)

For coprime polynomials a, b, c satisfying a + b + c = 0 and deg(a) ≥ deg(rad(abc)), we have a' = b' = c' = 0.

Proof is based on this online note by Franz Lemmermeyer http://www.fen.bilkent.edu.tr/~franz/ag05/ag-02.pdf, which is essentially based on Noah Snyder's proof ("An Alternative Proof of Mason's Theorem"), but slightly different.

1. Show that W(a, b) = W(b, c) = W(c, a) =: W. `wronskian_eq_of_sum_zero`
2. (a / rad(a)) | W, and same for b and c. `poly_mod_rad_div_diff`
3. a / rad(a), b / rad(b), c / rad(c) are all coprime, so their product abc / rad(abc) also divides W. `poly_coprime_div_mul_div`
4. Using the assumption on degrees, deduce that deg (abc / rad(abc)) > deg W.
5. By `polynomial.degree_le_of_dvd`, W = 0.
6. Since W(a, b) = ab' - a'b = 0 and a and b are coprime, a' = 0. Similarly we have b' = c' = 0. `coprime_wronskian_eq_zero_const`
-/

protected lemma is_coprime.div_radical {a b : k[X]}
  (h : is_coprime a b) : is_coprime a.div_radical b.div_radical :=
begin
  rw ←polynomial.mul_radical_div_radical a at h,
  rw ←polynomial.mul_radical_div_radical b at h,
  exact h.of_mul_left_right.of_mul_right_right,
end

private lemma abc_subcall {a b c w : k[X]}
  {hw : w ≠ 0} (wab : w = wronskian a b)
  (ha : a ≠ 0) (hb : b ≠ 0) (hc : c ≠ 0)
  (hab: is_coprime a b) (hbc: is_coprime b c) (hca: is_coprime c a)
  (abc_dr_dvd_w : (a*b*c).div_radical ∣ w) :
    c.nat_degree < (a*b*c).radical.nat_degree :=
begin
  have hab := mul_ne_zero ha hb,
  have habc := mul_ne_zero hab hc,

  set abc_dr_nd := (a*b*c).div_radical.nat_degree with def_abc_dr_nd,
  set abc_r_nd := (a*b*c).radical.nat_degree with def_abc_r_nd,
  have t11 : abc_dr_nd < a.nat_degree + b.nat_degree := by calc
    abc_dr_nd ≤ w.nat_degree :
        polynomial.nat_degree_le_of_dvd abc_dr_dvd_w hw
    ... < a.nat_degree + b.nat_degree :
        by rw wab at hw ⊢; exact wronskian.nat_degree_lt_add hw,
  have t4 : abc_dr_nd + abc_r_nd < a.nat_degree + b.nat_degree + abc_r_nd :=
    nat.add_lt_add_right t11 abc_r_nd,
  have t3 : abc_dr_nd + abc_r_nd = a.nat_degree + b.nat_degree + c.nat_degree := by calc
    abc_dr_nd + abc_r_nd = ((a*b*c).div_radical * (a*b*c).radical).nat_degree :
      by rw ←polynomial.nat_degree_mul
        (polynomial.div_radical_ne_zero habc)
        (a*b*c).radical_ne_zero
    ... = (a*b*c).nat_degree :
      by rw mul_comm _ (polynomial.radical _);
         rw (a * b * c).mul_radical_div_radical
    ... = a.nat_degree + b.nat_degree + c.nat_degree :
      by rw [polynomial.nat_degree_mul hab hc, polynomial.nat_degree_mul ha hb],
  rw t3 at t4,
  exact nat.lt_of_add_lt_add_left t4,
end

private lemma rot3_add {a b c : k[X]} : a + b + c = b + c + a := by ring_nf
private lemma rot3_mul {a b c : k[X]} : a * b * c = b * c * a := by ring_nf

theorem polynomial.abc {a b c : k[X]}
  (ha : a ≠ 0) (hb : b ≠ 0) (hc : c ≠ 0)
  (hab: is_coprime a b) (hbc: is_coprime b c) (hca: is_coprime c a) (hsum: a + b + c = 0) :
    (max3 a.nat_degree b.nat_degree c.nat_degree < (a*b*c).radical.nat_degree) ∨
    (a.derivative = 0 ∧ b.derivative = 0 ∧ c.derivative = 0) :=
begin
  -- Utility assertions
  have wbc := wronskian_eq_of_sum_zero hsum,
  set w := wronskian a b with wab,
  have wca : w = wronskian c a := begin
    rw rot3_add at hsum,
    have h := wronskian_eq_of_sum_zero hsum,
    rw ←wbc at h, exact h,
  end,
  have abc_dr_dvd_w : (a*b*c).div_radical ∣ w := begin
    have adr_dvd_w := a.div_radical_dvd_wronskian_left b,
    have bdr_dvd_w := a.div_radical_dvd_wronskian_right b,
    have cdr_dvd_w := b.div_radical_dvd_wronskian_right c,
    rw ←wab at adr_dvd_w bdr_dvd_w,
    rw ←wbc at cdr_dvd_w,

    have cop_ab_dr := hab.div_radical,
    have cop_bc_dr := hbc.div_radical,
    have cop_ca_dr := hca.div_radical,
    have cop_abc_dr := cop_ca_dr.symm.mul_left cop_bc_dr,
    have abdr_dvd_w := cop_ab_dr.mul_dvd adr_dvd_w bdr_dvd_w,
    have abcdr_dvd_w := cop_abc_dr.mul_dvd abdr_dvd_w cdr_dvd_w,

    convert abcdr_dvd_w,

    rw ←polynomial.div_radical_mul hab,
    rw ←polynomial.div_radical_mul _,
    exact hca.symm.mul_left hbc,
  end,

  by_cases hw : w = 0,
  { right,
    rw hw at wab wbc,
    cases hab.wronskian_eq_zero_iff.mp wab.symm with ga gb,
    cases hbc.wronskian_eq_zero_iff.mp wbc.symm with _ gc,
    refine ⟨ga, gb, gc⟩, },
  { left, rw max3_lt_iff,
    refine ⟨_, _, _⟩,
    { rw rot3_mul at ⊢ abc_dr_dvd_w,
      apply abc_subcall wbc; assumption, },
    { rw [rot3_mul, rot3_mul] at ⊢ abc_dr_dvd_w,
      apply abc_subcall wca; assumption, },
    { apply abc_subcall wab; assumption, }, },
end

lemma pow_derivative_eq_zero
  {n : ℕ} (chn : ¬(ring_char k ∣ n))
  {a : k[X]} (ha : a ≠ 0) :
  (a^n).derivative = 0 ↔ a.derivative = 0 :=
begin
  split,
  { intro apd,
    rw derivative_pow at apd,
    simp only [C_eq_nat_cast, mul_eq_zero] at apd,
    have pnz : a^(n-1) ≠ 0 := pow_ne_zero (n-1) ha,
    have cn_neq_zero : (↑(↑n : k) : k[X]) ≠ 0 := begin
      simp only [polynomial.C_eq_zero, ne.def,
        algebra_map.lift_map_eq_zero_iff],
      intro cn_eq_zero,
      exact chn (ring_char.dvd cn_eq_zero),
    end,
    tauto, },
  { intro hd, rw derivative_pow, rw hd,
    simp only [mul_zero], },
end