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

import category_theory.preadditive.projective
--import category_theory.limits.shapes.kernels
import algebra.homology.short_exact.preadditive
import for_mathlib.category_theory.retracts
import category_theory.abelian.projective
import category_theory.abelian.basic
import for_mathlib.category_theory.limits.kernel_functor

noncomputable theory

open category_theory category_theory.limits category_theory.category category_theory.preadditive
open_locale zero_object

namespace category_theory

variables {C : Type*} [category C]

namespace short_exact

lemma of_mono [abelian C] {X Y : C} (i : X ⟶ Y) [category_theory.mono i] :
  short_exact i (cokernel.π i) :=
{ mono := infer_instance,
  epi := infer_instance,
  exact := abelian.exact_cokernel i, }

lemma of_epi [abelian C] {X Y : C} (p : X ⟶ Y) [category_theory.epi p] :
  short_exact (kernel.ι p) p :=
{ mono := infer_instance,
  epi := infer_instance,
  exact := abelian.exact_of_is_kernel (kernel.ι p) p (kernel.condition p) (kernel_is_kernel p), }

lemma is_right_split_of_projective [abelian C] {X Y Z : C} {i : X ⟶ Y}
  {p : Y ⟶ Z} (h : short_exact i p) [projective Z] : right_split i p :=
{ right_split := begin
    haveI := h.epi,
    exact ⟨projective.factor_thru (𝟙 Z) p, projective.factor_thru_comp _ _⟩,
  end,
  mono := h.mono,
  exact := h.exact }

def lift [abelian C] {X Y Z W : C} {i : X ⟶ Y} {p : Y ⟶ Z} (h : short_exact i p) (f : W ⟶ Y)
  (hf : f ≫ p = 0) : W ⟶ X :=
begin
  haveI := h.mono,
  exact (kernel_fork.is_limit.lift' ((abelian.is_limit_of_exact_of_mono i p (h.exact))) f hf).1,
end

@[simp, reassoc]
lemma lift_comp [abelian C] {X Y Z W : C} {i : X ⟶ Y} {p : Y ⟶ Z} (h : short_exact i p) (f : W ⟶ Y)
  (hf : f ≫ p = 0) : h.lift f hf ≫ i = f :=
begin
  haveI := h.mono,
  exact (kernel_fork.is_limit.lift' ((abelian.is_limit_of_exact_of_mono i p (h.exact))) f hf).2,
end

end short_exact

namespace right_split

def split [abelian C] {X Y Z : C} {i : X ⟶ Y} {p : Y ⟶ Z} (h : category_theory.right_split i p) :
  split i p  :=
begin
  haveI := h.mono,
  cases h.right_split with s hs,
  refine ⟨⟨h.short_exact.lift (𝟙 Y - p ≫ s) _, s, _, hs, h.exact.w, _, _⟩⟩,
  { simp only [hs, sub_comp, id_comp, assoc, comp_id, sub_self], },
  { simp only [← cancel_mono i, h.exact.w_assoc, id_comp, assoc, comp_id, short_exact.lift_comp,
      comp_sub, zero_comp, sub_zero], },
  { rw [← cancel_mono i, assoc, short_exact.lift_comp, comp_sub, comp_id,
      ← assoc, hs, id_comp, sub_self, zero_comp], },
  { simp only [short_exact.lift_comp, sub_add_cancel], },
end

end right_split

namespace preadditive

variable (C)

def mono_with_projective_coker [preadditive C] : morphism_property C :=
  λ X Y φ, ∃ (Z : C) (hZ : projective Z) (p : Y ⟶ Z), category_theory.split φ p

namespace mono_with_projective_coker

lemma mem_iff [abelian C] {X Y : C} (φ : X ⟶ Y) :
  mono_with_projective_coker C φ ↔ (mono φ ∧ projective (cokernel φ)) :=
begin
  split,
  { rintro ⟨Z, hZ, p, hp⟩,
    haveI := hp.short_exact.epi,
    refine ⟨hp.short_exact.mono, _⟩,
    have e : Z ≅ cokernel φ := is_colimit.cocone_point_unique_up_to_iso
      (abelian.is_colimit_of_exact_of_epi φ p hp.exact) (limits.colimit.is_colimit _),
    rw ← projective.iso_iff e,
    exact hZ, },
  { intro h,
    haveI := h.1,
    haveI := h.2,
    refine ⟨cokernel φ, h.2, cokernel.π _, _⟩,
    exact (short_exact.of_mono φ).is_right_split_of_projective.split, }
end

lemma of_biprod_inl [preadditive C] (X Y : C) [hY : projective Y] [has_binary_biproduct X Y] :
  mono_with_projective_coker C (biprod.inl : X ⟶ X ⊞ Y) :=
⟨Y, hY, biprod.snd, ⟨⟨biprod.fst, biprod.inr, by tidy⟩⟩⟩

variable {C}

lemma id_mem [preadditive C] [has_zero_object C] (X : C) :
  mono_with_projective_coker C (𝟙 X) :=
⟨0, projective.zero_projective, 0, split.mk ⟨𝟙 X, 0, by simp⟩⟩

lemma of_is_iso [preadditive C] [has_zero_object C] {X Y : C} (f : X ⟶ Y) [is_iso f] :
  mono_with_projective_coker C f :=
⟨0, projective.zero_projective, 0, split.mk ⟨inv f, 0, by simp⟩⟩

variable (C)

lemma is_stable_by_composition [preadditive C] [has_binary_biproducts C]:
  (mono_with_projective_coker C).stable_under_composition :=
begin
  intros X Y Z f g hf hg,
  rcases hf with ⟨A, hA, p, hp⟩,
  rcases hg with ⟨B, hB, q, hq⟩,
  haveI := hA,
  haveI := hB,
  rcases hp with ⟨rf, i, hfr, hip, hfp, hir, hY⟩,
  rcases hq with ⟨rg, j, hgr, hjq, hgq, hjr, hZ⟩,
  refine ⟨A ⊞ B, infer_instance, biprod.lift (rg ≫ p) q,
    ⟨⟨rg ≫ rf, biprod.desc (i ≫ g) j, _, _, _, _, _⟩⟩⟩,
  { slice_lhs 2 3 { rw hgr, },
    rw [id_comp, hfr], },
  { ext,
    { simp only [biprod.inl_desc_assoc, assoc, biprod.lift_fst, comp_id, biprod.inl_fst],
      slice_lhs 2 3 { rw hgr, },
      rw [id_comp, hip], },
    { simp only [biprod.inl_desc_assoc, assoc, biprod.lift_snd, comp_id, biprod.inl_snd,
        hgq, comp_zero], },
    { simp only [biprod.inr_desc_assoc, assoc, biprod.lift_fst, comp_id, biprod.inr_fst],
      rw [← assoc, hjr, zero_comp], },
    { simp only [biprod.inr_desc_assoc, assoc, biprod.lift_snd, comp_id, biprod.inr_snd,
        hjq], }, },
  { ext,
    { simp only [assoc, biprod.lift_fst, zero_comp],
      slice_lhs 2 3 { rw hgr },
      rw [id_comp, hfp], },
    { simp only [assoc, biprod.lift_snd, zero_comp, hgq, comp_zero], }, },
  { ext,
    { simp only [biprod.inl_desc_assoc, assoc, comp_zero],
      slice_lhs 2 3 { rw hgr, },
      rw [id_comp, hir], },
    { simp only [biprod.inr_desc_assoc, comp_zero],
      slice_lhs 1 2 { rw hjr, },
      rw zero_comp, }, },
  { simp only [assoc, biprod.lift_desc],
    rw [← hZ, ← add_assoc, ← comp_add, ← assoc, ← assoc, ← add_comp, hY, id_comp], },
end

lemma is_stable_by_retract [abelian C] :
  (mono_with_projective_coker C).is_stable_by_retract :=
begin
  intros X₁ X₂ Y₁ Y₂ x y hxy hy,
  rw mem_iff at ⊢ hy,
  exact ⟨morphism_property.is_stable_by_retract.for_monomorphisms x y hxy hy.1,
    projective.of_retract (is_retract.imp_of_functor (limits.cokernel_functor C) _ _ hxy) hy.2⟩,
end

end mono_with_projective_coker

end preadditive

end category_theory


/-
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 Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.data.nat.enat
import Mathlib.data.set.intervals.ord_connected
import Mathlib.PostPort

universes u_1 u_4 l u_3 u_2

namespace Mathlib

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

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

protected instance with_top.has_Sup {α : Type u_1} [preorder α] [has_Sup α] : has_Sup (with_top α) :=
  has_Sup.mk fun (S : set (with_top α)) => ite (⊤ ∈ S) ⊤ (ite (bdd_above (coe ⁻¹' S)) ↑(Sup (coe ⁻¹' S)) ⊤)

protected instance with_top.has_Inf {α : Type u_1} [has_Inf α] : has_Inf (with_top α) :=
  has_Inf.mk fun (S : set (with_top α)) => ite (S ⊆ singleton ⊤) ⊤ ↑(Inf (coe ⁻¹' S))

protected instance with_bot.has_Sup {α : Type u_1} [has_Sup α] : has_Sup (with_bot α) :=
  has_Sup.mk Inf

protected instance with_bot.has_Inf {α : Type u_1} [preorder α] [has_Inf α] : has_Inf (with_bot α) :=
  has_Inf.mk Sup

/-- 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 u_4)
extends lattice α, has_Sup α, has_Inf α
where
  le_cSup : ∀ (s : set α) (a : α), bdd_above s → a ∈ s → a ≤ Sup s
  cSup_le : ∀ (s : set α) (a : α), set.nonempty s → a ∈ upper_bounds s → Sup s ≤ a
  cInf_le : ∀ (s : set α) (a : α), bdd_below s → a ∈ s → Inf s ≤ a
  le_cInf : ∀ (s : set α) (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 u_4)
extends linear_order α, conditionally_complete_lattice α
where

/-- 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.-/
class conditionally_complete_linear_order_bot (α : Type u_4)
extends order_bot α, conditionally_complete_linear_order α
where
  cSup_empty : Sup ∅ = ⊥

/- A complete lattice is a conditionally complete lattice, as there are no restrictions
on the properties of Inf and Sup in a complete lattice.-/

protected instance conditionally_complete_lattice_of_complete_lattice {α : Type u_1} [complete_lattice α] : conditionally_complete_lattice α :=
  conditionally_complete_lattice.mk complete_lattice.sup complete_lattice.le complete_lattice.lt complete_lattice.le_refl
    complete_lattice.le_trans complete_lattice.le_antisymm complete_lattice.le_sup_left complete_lattice.le_sup_right
    complete_lattice.sup_le complete_lattice.inf complete_lattice.inf_le_left complete_lattice.inf_le_right
    complete_lattice.le_inf complete_lattice.Sup complete_lattice.Inf sorry sorry sorry sorry

protected instance conditionally_complete_linear_order_of_complete_linear_order {α : Type u_1} [complete_linear_order α] : conditionally_complete_linear_order α :=
  conditionally_complete_linear_order.mk conditionally_complete_lattice.sup conditionally_complete_lattice.le
    conditionally_complete_lattice.lt sorry sorry sorry sorry sorry sorry conditionally_complete_lattice.inf sorry sorry
    sorry conditionally_complete_lattice.Sup conditionally_complete_lattice.Inf sorry sorry sorry sorry
    complete_linear_order.le_total complete_linear_order.decidable_le complete_linear_order.decidable_eq
    complete_linear_order.decidable_lt

theorem le_cSup {α : Type u_1} [conditionally_complete_lattice α] {s : set α} {a : α} (h₁ : bdd_above s) (h₂ : a ∈ s) : a ≤ Sup s :=
  conditionally_complete_lattice.le_cSup s a h₁ h₂

theorem cSup_le {α : Type u_1} [conditionally_complete_lattice α] {s : set α} {a : α} (h₁ : set.nonempty s) (h₂ : ∀ (b : α), b ∈ s → b ≤ a) : Sup s ≤ a :=
  conditionally_complete_lattice.cSup_le s a h₁ h₂

theorem cInf_le {α : Type u_1} [conditionally_complete_lattice α] {s : set α} {a : α} (h₁ : bdd_below s) (h₂ : a ∈ s) : Inf s ≤ a :=
  conditionally_complete_lattice.cInf_le s a h₁ h₂

theorem le_cInf {α : Type u_1} [conditionally_complete_lattice α] {s : set α} {a : α} (h₁ : set.nonempty s) (h₂ : ∀ (b : α), b ∈ s → a ≤ b) : a ≤ Inf s :=
  conditionally_complete_lattice.le_cInf s a h₁ h₂

theorem le_cSup_of_le {α : Type u_1} [conditionally_complete_lattice α] {s : set α} {a : α} {b : α} (_x : bdd_above s) (hb : b ∈ s) (h : a ≤ b) : a ≤ Sup s :=
  le_trans h (le_cSup _x hb)

theorem cInf_le_of_le {α : Type u_1} [conditionally_complete_lattice α] {s : set α} {a : α} {b : α} (_x : bdd_below s) (hb : b ∈ s) (h : b ≤ a) : Inf s ≤ a :=
  le_trans (cInf_le _x hb) h

theorem cSup_le_cSup {α : Type u_1} [conditionally_complete_lattice α] {s : set α} {t : set α} (_x : bdd_above t) : set.nonempty s → s ⊆ t → Sup s ≤ Sup t :=
  fun (_x_1 : set.nonempty s) (h : s ⊆ t) => cSup_le _x_1 fun (a : α) (ha : a ∈ s) => le_cSup _x (h ha)

theorem cInf_le_cInf {α : Type u_1} [conditionally_complete_lattice α] {s : set α} {t : set α} (_x : bdd_below t) : set.nonempty s → s ⊆ t → Inf t ≤ Inf s :=
  fun (_x_1 : set.nonempty s) (h : s ⊆ t) => le_cInf _x_1 fun (a : α) (ha : a ∈ s) => cInf_le _x (h ha)

theorem is_lub_cSup {α : Type u_1} [conditionally_complete_lattice α] {s : set α} (ne : set.nonempty s) (H : bdd_above s) : is_lub s (Sup s) :=
  { left := fun (x : α) => le_cSup H, right := fun (x : α) => cSup_le ne }

theorem is_glb_cInf {α : Type u_1} [conditionally_complete_lattice α] {s : set α} (ne : set.nonempty s) (H : bdd_below s) : is_glb s (Inf s) :=
  { left := fun (x : α) => cInf_le H, right := fun (x : α) => le_cInf ne }

theorem is_lub.cSup_eq {α : Type u_1} [conditionally_complete_lattice α] {s : set α} {a : α} (H : is_lub s a) (ne : set.nonempty s) : Sup s = a :=
  is_lub.unique (is_lub_cSup ne (Exists.intro a (and.left H))) H

/-- A greatest element of a set is the supremum of this set. -/
theorem is_greatest.cSup_eq {α : Type u_1} [conditionally_complete_lattice α] {s : set α} {a : α} (H : is_greatest s a) : Sup s = a :=
  is_lub.cSup_eq (is_greatest.is_lub H) (is_greatest.nonempty H)

theorem is_glb.cInf_eq {α : Type u_1} [conditionally_complete_lattice α] {s : set α} {a : α} (H : is_glb s a) (ne : set.nonempty s) : Inf s = a :=
  is_glb.unique (is_glb_cInf ne (Exists.intro a (and.left H))) H

/-- A least element of a set is the infimum of this set. -/
theorem is_least.cInf_eq {α : Type u_1} [conditionally_complete_lattice α] {s : set α} {a : α} (H : is_least s a) : Inf s = a :=
  is_glb.cInf_eq (is_least.is_glb H) (is_least.nonempty H)

theorem subset_Icc_cInf_cSup {α : Type u_1} [conditionally_complete_lattice α] {s : set α} (hb : bdd_below s) (ha : bdd_above s) : s ⊆ set.Icc (Inf s) (Sup s) :=
  fun (x : α) (hx : x ∈ s) => { left := cInf_le hb hx, right := le_cSup ha hx }

theorem cSup_le_iff {α : Type u_1} [conditionally_complete_lattice α] {s : set α} {a : α} (hb : bdd_above s) (ne : set.nonempty s) : Sup s ≤ a ↔ ∀ (b : α), b ∈ s → b ≤ a :=
  is_lub_le_iff (is_lub_cSup ne hb)

theorem le_cInf_iff {α : Type u_1} [conditionally_complete_lattice α] {s : set α} {a : α} (hb : bdd_below s) (ne : set.nonempty s) : a ≤ Inf s ↔ ∀ (b : α), b ∈ s → a ≤ b :=
  le_is_glb_iff (is_glb_cInf ne hb)

theorem cSup_lower_bounds_eq_cInf {α : Type u_1} [conditionally_complete_lattice α] {s : set α} (h : bdd_below s) (hs : set.nonempty s) : Sup (lower_bounds s) = Inf s :=
  is_lub.unique
    (is_lub_cSup h (set.nonempty.mono (fun (x : α) (hx : x ∈ s) (y : α) (hy : y ∈ lower_bounds s) => hy hx) hs))
    (is_greatest.is_lub (is_glb_cInf hs h))

theorem cInf_upper_bounds_eq_cSup {α : Type u_1} [conditionally_complete_lattice α] {s : set α} (h : bdd_above s) (hs : set.nonempty s) : Inf (upper_bounds s) = Sup s :=
  is_glb.unique
    (is_glb_cInf h (set.nonempty.mono (fun (x : α) (hx : x ∈ s) (y : α) (hy : y ∈ upper_bounds s) => hy hx) hs))
    (is_least.is_glb (is_lub_cSup hs h))

/--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`.-/
theorem cSup_intro {α : Type u_1} [conditionally_complete_lattice α] {s : set α} {b : α} (_x : set.nonempty s) : (∀ (a : α), a ∈ s → a ≤ b) → (∀ (w : α), w < b → ∃ (a : α), ∃ (H : a ∈ s), w < a) → Sup s = b := sorry

/--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`.-/
theorem cInf_intro {α : Type u_1} [conditionally_complete_lattice α] {s : set α} {b : α} (_x : set.nonempty s) : (∀ (a : α), a ∈ s → b ≤ a) → (∀ (w : α), b < w → ∃ (a : α), ∃ (H : a ∈ s), a < w) → Inf s = b := sorry

/--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.-/
theorem lt_cSup_of_lt {α : Type u_1} [conditionally_complete_lattice α] {s : set α} {a : α} {b : α} (_x : bdd_above s) : a ∈ s → b < a → b < Sup s :=
  fun (_x_1 : a ∈ s) (_x_2 : b < a) => lt_of_lt_of_le _x_2 (le_cSup _x _x_1)

/--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.-/
theorem cInf_lt_of_lt {α : Type u_1} [conditionally_complete_lattice α] {s : set α} {a : α} {b : α} (_x : bdd_below s) : a ∈ s → a < b → Inf s < b :=
  fun (_x_1 : a ∈ s) (_x_2 : a < b) => lt_of_le_of_lt (cInf_le _x _x_1) _x_2

/-- 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. -/
theorem exists_between_of_forall_le {α : Type u_1} [conditionally_complete_lattice α] {s : set α} {t : set α} (sne : set.nonempty s) (tne : set.nonempty t) (hst : ∀ (x : α), x ∈ s → ∀ (y : α), y ∈ t → x ≤ y) : set.nonempty (upper_bounds s ∩ lower_bounds t) :=
  Exists.intro (Inf t)
    { left := fun (x : α) (hx : x ∈ s) => le_cInf tne (hst x hx),
      right := fun (y : α) (hy : y ∈ t) => cInf_le (set.nonempty.mono hst sne) hy }

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

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

/--If a set is bounded below and above, and nonempty, its infimum is less than or equal to
its supremum.-/
theorem cInf_le_cSup {α : Type u_1} [conditionally_complete_lattice α] {s : set α} (hb : bdd_below s) (ha : bdd_above s) (ne : set.nonempty s) : 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 {α : Type u_1} [conditionally_complete_lattice α] {s : set α} {t : set α} (hs : bdd_above s) (sne : set.nonempty s) (ht : bdd_above t) (tne : set.nonempty t) : Sup (s ∪ t) = Sup s ⊔ Sup t :=
  is_lub.cSup_eq (is_lub.union (is_lub_cSup sne hs) (is_lub_cSup tne ht)) (set.nonempty.inl sne)

/--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 {α : Type u_1} [conditionally_complete_lattice α] {s : set α} {t : set α} (hs : bdd_below s) (sne : set.nonempty s) (ht : bdd_below t) (tne : set.nonempty t) : Inf (s ∪ t) = Inf s ⊓ Inf t :=
  is_glb.cInf_eq (is_glb.union (is_glb_cInf sne hs) (is_glb_cInf tne ht)) (set.nonempty.inl sne)

/--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 {α : Type u_1} [conditionally_complete_lattice α] {s : set α} {t : set α} (_x : bdd_above s) : bdd_above t → set.nonempty (s ∩ t) → Sup (s ∩ t) ≤ Sup s ⊓ Sup t := sorry

/--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 {α : Type u_1} [conditionally_complete_lattice α] {s : set α} {t : set α} (_x : bdd_below s) : bdd_below t → set.nonempty (s ∩ t) → Inf s ⊔ Inf t ≤ Inf (s ∩ t) := sorry

/-- 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 {α : Type u_1} [conditionally_complete_lattice α] {s : set α} {a : α} (hs : bdd_above s) (sne : set.nonempty s) : Sup (insert a s) = a ⊔ Sup s :=
  is_lub.cSup_eq (is_lub.insert a (is_lub_cSup sne hs)) (set.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 {α : Type u_1} [conditionally_complete_lattice α] {s : set α} {a : α} (hs : bdd_below s) (sne : set.nonempty s) : Inf (insert a s) = a ⊓ Inf s :=
  is_glb.cInf_eq (is_glb.insert a (is_glb_cInf sne hs)) (set.insert_nonempty a s)

@[simp] theorem cInf_Ici {α : Type u_1} [conditionally_complete_lattice α] {a : α} : Inf (set.Ici a) = a :=
  is_least.cInf_eq is_least_Ici

@[simp] theorem cSup_Iic {α : Type u_1} [conditionally_complete_lattice α] {a : α} : Sup (set.Iic a) = a :=
  is_greatest.cSup_eq is_greatest_Iic

/--The indexed supremum of two functions are comparable if the functions are pointwise comparable-/
theorem csupr_le_csupr {α : Type u_1} {ι : Sort u_3} [conditionally_complete_lattice α] {f : ι → α} {g : ι → α} (B : bdd_above (set.range g)) (H : ∀ (x : ι), f x ≤ g x) : supr f ≤ supr g := sorry

/--The indexed supremum of a function is bounded above by a uniform bound-/
theorem csupr_le {α : Type u_1} {ι : Sort u_3} [conditionally_complete_lattice α] [Nonempty ι] {f : ι → α} {c : α} (H : ∀ (x : ι), f x ≤ c) : supr f ≤ c :=
  cSup_le (set.range_nonempty f)
    (eq.mpr (id (Eq._oldrec (Eq.refl (∀ (b : α), b ∈ set.range f → b ≤ c)) (propext set.forall_range_iff))) H)

/--The indexed supremum of a function is bounded below by the value taken at one point-/
theorem le_csupr {α : Type u_1} {ι : Sort u_3} [conditionally_complete_lattice α] {f : ι → α} (H : bdd_above (set.range f)) (c : ι) : f c ≤ supr f :=
  le_cSup H (set.mem_range_self c)

/--The indexed infimum of two functions are comparable if the functions are pointwise comparable-/
theorem cinfi_le_cinfi {α : Type u_1} {ι : Sort u_3} [conditionally_complete_lattice α] {f : ι → α} {g : ι → α} (B : bdd_below (set.range f)) (H : ∀ (x : ι), f x ≤ g x) : infi f ≤ infi g := sorry

/--The indexed minimum of a function is bounded below by a uniform lower bound-/
theorem le_cinfi {α : Type u_1} {ι : Sort u_3} [conditionally_complete_lattice α] [Nonempty ι] {f : ι → α} {c : α} (H : ∀ (x : ι), c ≤ f x) : c ≤ infi f :=
  le_cInf (set.range_nonempty f)
    (eq.mpr (id (Eq._oldrec (Eq.refl (∀ (b : α), b ∈ set.range f → c ≤ b)) (propext set.forall_range_iff))) H)

/--The indexed infimum of a function is bounded above by the value taken at one point-/
theorem cinfi_le {α : Type u_1} {ι : Sort u_3} [conditionally_complete_lattice α] {f : ι → α} (H : bdd_below (set.range f)) (c : ι) : infi f ≤ f c :=
  cInf_le H (set.mem_range_self c)

@[simp] theorem cinfi_const {α : Type u_1} {ι : Sort u_3} [conditionally_complete_lattice α] [hι : Nonempty ι] {a : α} : (infi fun (b : ι) => a) = a :=
  eq.mpr (id (Eq._oldrec (Eq.refl ((infi fun (b : ι) => a) = a)) (infi.equations._eqn_1 fun (b : ι) => a)))
    (eq.mpr (id (Eq._oldrec (Eq.refl (Inf (set.range fun (b : ι) => a) = a)) set.range_const))
      (eq.mpr (id (Eq._oldrec (Eq.refl (Inf (singleton a) = a)) (cInf_singleton a))) (Eq.refl a)))

@[simp] theorem csupr_const {α : Type u_1} {ι : Sort u_3} [conditionally_complete_lattice α] [hι : Nonempty ι] {a : α} : (supr fun (b : ι) => a) = a :=
  eq.mpr (id (Eq._oldrec (Eq.refl ((supr fun (b : ι) => a) = a)) (supr.equations._eqn_1 fun (b : ι) => a)))
    (eq.mpr (id (Eq._oldrec (Eq.refl (Sup (set.range fun (b : ι) => a) = a)) set.range_const))
      (eq.mpr (id (Eq._oldrec (Eq.refl (Sup (singleton a) = a)) (cSup_singleton a))) (Eq.refl a)))

theorem infi_unique {α : Type u_1} {ι : Sort u_3} [conditionally_complete_lattice α] [unique ι] {s : ι → α} : (infi fun (i : ι) => s i) = s Inhabited.default := sorry

theorem supr_unique {α : Type u_1} {ι : Sort u_3} [conditionally_complete_lattice α] [unique ι] {s : ι → α} : (supr fun (i : ι) => s i) = s Inhabited.default := sorry

@[simp] theorem infi_unit {α : Type u_1} [conditionally_complete_lattice α] {f : Unit → α} : (infi fun (x : Unit) => f x) = f Unit.unit := sorry

@[simp] theorem supr_unit {α : Type u_1} [conditionally_complete_lattice α] {f : Unit → α} : (supr fun (x : Unit) => f x) = f Unit.unit := sorry

/-- Nested intervals lemma: if `f` is a monotonically increasing sequence, `g` is a monotonically
decreasing sequence, and `f n ≤ g n` for all `n`, then `⨆ n, f n` belongs to all the intervals
`[f n, g n]`. -/
theorem csupr_mem_Inter_Icc_of_mono_incr_of_mono_decr {α : Type u_1} {β : Type u_2} [conditionally_complete_lattice α] [Nonempty β] [semilattice_sup β] {f : β → α} {g : β → α} (hf : monotone f) (hg : ∀ {m n : β}, m ≤ n → g n ≤ g m) (h : ∀ (n : β), f n ≤ g n) : (supr fun (n : β) => f n) ∈ set.Inter fun (n : β) => set.Icc (f n) (g n) := sorry

/-- Nested intervals lemma: if `[f n, g n]` is a monotonically decreasing sequence of nonempty
closed intervals, then `⨆ n, f n` belongs to all the intervals `[f n, g n]`. -/
theorem csupr_mem_Inter_Icc_of_mono_decr_Icc {α : Type u_1} {β : Type u_2} [conditionally_complete_lattice α] [Nonempty β] [semilattice_sup β] {f : β → α} {g : β → α} (h : ∀ {m n : β}, m ≤ n → set.Icc (f n) (g n) ⊆ set.Icc (f m) (g m)) (h' : ∀ (n : β), f n ≤ g n) : (supr fun (n : β) => f n) ∈ set.Inter fun (n : β) => set.Icc (f n) (g n) :=
  csupr_mem_Inter_Icc_of_mono_incr_of_mono_decr
    (fun (m n : β) (hmn : m ≤ n) => and.left (iff.mp (set.Icc_subset_Icc_iff (h' n)) (h hmn)))
    (fun (m n : β) (hmn : m ≤ n) => and.right (iff.mp (set.Icc_subset_Icc_iff (h' n)) (h hmn))) h'

/-- Nested intervals lemma: if `[f n, g n]` is a monotonically decreasing sequence of nonempty
closed intervals, then `⨆ n, f n` belongs to all the intervals `[f n, g n]`. -/
theorem csupr_mem_Inter_Icc_of_mono_decr_Icc_nat {α : Type u_1} [conditionally_complete_lattice α] {f : ℕ → α} {g : ℕ → α} (h : ∀ (n : ℕ), set.Icc (f (n + 1)) (g (n + 1)) ⊆ set.Icc (f n) (g n)) (h' : ∀ (n : ℕ), f n ≤ g n) : (supr fun (n : ℕ) => f n) ∈ set.Inter fun (n : ℕ) => set.Icc (f n) (g n) :=
  csupr_mem_Inter_Icc_of_mono_decr_Icc (monotone_of_monotone_nat h) h'

protected instance pi.conditionally_complete_lattice {ι : Type u_1} {α : ι → Type u_2} [(i : ι) → conditionally_complete_lattice (α i)] : conditionally_complete_lattice ((i : ι) → α i) :=
  conditionally_complete_lattice.mk lattice.sup lattice.le lattice.lt sorry sorry sorry sorry sorry sorry lattice.inf
    sorry sorry sorry Sup Inf sorry sorry sorry sorry

/-- 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. -/
theorem exists_lt_of_lt_cSup {α : Type u_1} [conditionally_complete_linear_order α] {s : set α} {b : α} (hs : set.nonempty s) (hb : b < Sup s) : ∃ (a : α), ∃ (H : a ∈ s), b < a := sorry

/--
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`.
-/
theorem exists_lt_of_lt_csupr {α : Type u_1} {ι : Sort u_3} [conditionally_complete_linear_order α] {b : α} [Nonempty ι] {f : ι → α} (h : b < supr f) : ∃ (i : ι), b < f i := sorry

/--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.-/
theorem exists_lt_of_cInf_lt {α : Type u_1} [conditionally_complete_linear_order α] {s : set α} {b : α} (hs : set.nonempty s) (hb : Inf s < b) : ∃ (a : α), ∃ (H : a ∈ s), a < b := sorry

/--
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`.
-/
theorem exists_lt_of_cinfi_lt {α : Type u_1} {ι : Sort u_3} [conditionally_complete_linear_order α] {a : α} [Nonempty ι] {f : ι → α} (h : infi f < a) : ∃ (i : ι), f i < a := sorry

/--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_intro' {α : Type u_1} [conditionally_complete_linear_order α] {s : set α} {b : α} (_x : set.nonempty s) (h_is_ub : ∀ (a : α), a ∈ s → a ≤ b) (h_b_le_ub : ∀ (ub : α), (∀ (a : α), a ∈ s → a ≤ ub) → b ≤ ub) : Sup s = b :=
  le_antisymm ((fun (this : Sup s ≤ b) => this) (cSup_le _x h_is_ub))
    ((fun (this : b ≤ Sup s) => this) (h_b_le_ub (Sup s) fun (a : α) => le_cSup (Exists.intro b h_is_ub)))

theorem cSup_empty {α : Type u_1} [conditionally_complete_linear_order_bot α] : Sup ∅ = ⊥ :=
  conditionally_complete_linear_order_bot.cSup_empty

namespace nat

protected instance has_Inf : has_Inf ℕ :=
  has_Inf.mk
    fun (s : set ℕ) => dite (∃ (n : ℕ), n ∈ s) (fun (h : ∃ (n : ℕ), n ∈ s) => nat.find h) fun (h : ¬∃ (n : ℕ), n ∈ s) => 0

protected instance has_Sup : has_Sup ℕ :=
  has_Sup.mk
    fun (s : set ℕ) =>
      dite (∃ (n : ℕ), ∀ (a : ℕ), a ∈ s → a ≤ n) (fun (h : ∃ (n : ℕ), ∀ (a : ℕ), a ∈ s → a ≤ n) => nat.find h)
        fun (h : ¬∃ (n : ℕ), ∀ (a : ℕ), a ∈ s → a ≤ n) => 0

theorem Inf_def {s : set ℕ} (h : set.nonempty s) : Inf s = nat.find h :=
  dif_pos h

theorem Sup_def {s : set ℕ} (h : ∃ (n : ℕ), ∀ (a : ℕ), a ∈ s → a ≤ n) : Sup s = nat.find h :=
  dif_pos h

@[simp] theorem Inf_eq_zero {s : set ℕ} : Inf s = 0 ↔ 0 ∈ s ∨ s = ∅ := sorry

theorem Inf_mem {s : set ℕ} (h : set.nonempty s) : Inf s ∈ s :=
  eq.mpr (id (Eq._oldrec (Eq.refl (Inf s ∈ s)) (Inf_def h))) (nat.find_spec h)

theorem not_mem_of_lt_Inf {s : set ℕ} {m : ℕ} (hm : m < Inf s) : ¬m ∈ s :=
  or.dcases_on (set.eq_empty_or_nonempty s)
    (fun (h : s = ∅) => Eq._oldrec (fun (hm : m < Inf ∅) => set.not_mem_empty m) (Eq.symm h) hm)
    fun (h : set.nonempty s) => nat.find_min h (eq.mp (Eq._oldrec (Eq.refl (m < Inf s)) (Inf_def h)) hm)

protected theorem Inf_le {s : set ℕ} {m : ℕ} (hm : m ∈ s) : Inf s ≤ m :=
  eq.mpr (id (Eq._oldrec (Eq.refl (Inf s ≤ m)) (Inf_def (Exists.intro m hm)))) (nat.find_min' (Exists.intro m hm) hm)

/-- This instance is necessary, otherwise the lattice operations would be derived via
conditionally_complete_linear_order_bot and marked as noncomputable. -/
protected instance lattice : lattice ℕ :=
  Mathlib.lattice_of_linear_order

protected instance conditionally_complete_linear_order_bot : conditionally_complete_linear_order_bot ℕ :=
  conditionally_complete_linear_order_bot.mk lattice.sup order_bot.le order_bot.lt sorry sorry sorry sorry sorry sorry
    lattice.inf sorry sorry sorry Sup Inf sorry sorry sorry sorry sorry linear_order.decidable_le
    linear_order.decidable_eq linear_order.decidable_lt order_bot.bot sorry sorry

end nat

namespace with_top

/-- The Sup of a non-empty set is its least upper bound for a conditionally
complete lattice with a top. -/
theorem is_lub_Sup' {β : Type u_1} [conditionally_complete_lattice β] {s : set (with_top β)} (hs : set.nonempty s) : is_lub s (Sup s) := sorry

theorem is_lub_Sup {α : Type u_1} [conditionally_complete_linear_order_bot α] (s : set (with_top α)) : is_lub s (Sup s) := sorry

/-- The Inf of a bounded-below set is its greatest lower bound for a conditionally
complete lattice with a top. -/
theorem is_glb_Inf' {β : Type u_1} [conditionally_complete_lattice β] {s : set (with_top β)} (hs : bdd_below s) : is_glb s (Inf s) := sorry

theorem is_glb_Inf {α : Type u_1} [conditionally_complete_linear_order_bot α] (s : set (with_top α)) : is_glb s (Inf s) :=
  dite (bdd_below s) (fun (hs : bdd_below s) => is_glb_Inf' hs)
    fun (hs : ¬bdd_below s) => False._oldrec (hs (Exists.intro ⊥ (id (id fun (a : with_top α) (ᾰ : a ∈ s) => bot_le))))

protected instance complete_linear_order {α : Type u_1} [conditionally_complete_linear_order_bot α] : complete_linear_order (with_top α) :=
  complete_linear_order.mk lattice.sup linear_order.le linear_order.lt sorry sorry sorry sorry sorry sorry lattice.inf
    sorry sorry sorry order_top.top sorry order_bot.bot sorry Sup Inf sorry sorry sorry sorry sorry
    (classical.dec_rel LessEq) linear_order.decidable_eq linear_order.decidable_lt

theorem coe_Sup {α : Type u_1} [conditionally_complete_linear_order_bot α] {s : set α} (hb : bdd_above s) : ↑(Sup s) = supr fun (a : α) => supr fun (H : a ∈ s) => ↑a := sorry

theorem coe_Inf {α : Type u_1} [conditionally_complete_linear_order_bot α] {s : set α} (hs : set.nonempty s) : ↑(Inf s) = infi fun (a : α) => infi fun (H : a ∈ s) => ↑a := sorry

end with_top

namespace enat

protected instance complete_linear_order : complete_linear_order enat :=
  complete_linear_order.mk bounded_lattice.sup linear_order.le linear_order.lt linear_order.le_refl linear_order.le_trans
    linear_order.le_antisymm bounded_lattice.le_sup_left bounded_lattice.le_sup_right bounded_lattice.sup_le
    bounded_lattice.inf bounded_lattice.inf_le_left bounded_lattice.inf_le_right bounded_lattice.le_inf
    bounded_lattice.top bounded_lattice.le_top bounded_lattice.bot bounded_lattice.bot_le
    (fun (s : set enat) => coe_fn (equiv.symm with_top_equiv) (Sup (⇑with_top_equiv '' s)))
    (fun (s : set enat) => coe_fn (equiv.symm with_top_equiv) (Inf (⇑with_top_equiv '' s))) sorry sorry sorry sorry
    linear_order.le_total linear_order.decidable_le linear_order.decidable_eq linear_order.decidable_lt

end enat

protected instance order_dual.conditionally_complete_lattice (α : Type u_1) [conditionally_complete_lattice α] : conditionally_complete_lattice (order_dual α) :=
  conditionally_complete_lattice.mk lattice.sup lattice.le lattice.lt sorry sorry sorry sorry sorry sorry lattice.inf
    sorry sorry sorry Sup Inf cInf_le le_cInf le_cSup cSup_le

protected instance order_dual.conditionally_complete_linear_order (α : Type u_1) [conditionally_complete_linear_order α] : conditionally_complete_linear_order (order_dual α) :=
  conditionally_complete_linear_order.mk conditionally_complete_lattice.sup conditionally_complete_lattice.le
    conditionally_complete_lattice.lt sorry sorry sorry sorry sorry sorry conditionally_complete_lattice.inf sorry sorry
    sorry conditionally_complete_lattice.Sup conditionally_complete_lattice.Inf sorry sorry sorry sorry sorry
    linear_order.decidable_le linear_order.decidable_eq linear_order.decidable_lt

namespace monotone

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

theorem le_cSup_image {α : Type u_1} {β : Type u_2} [preorder α] [conditionally_complete_lattice β] {f : α → β} (h_mono : monotone f) {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) (set.mem_image_of_mem f hcs)

theorem cSup_image_le {α : Type u_1} {β : Type u_2} [preorder α] [conditionally_complete_lattice β] {f : α → β} (h_mono : monotone f) {s : set α} (hs : set.nonempty s) {B : α} (hB : B ∈ upper_bounds s) : Sup (f '' s) ≤ f B :=
  cSup_le (set.nonempty.image f hs) (mem_upper_bounds_image h_mono hB)

theorem cInf_image_le {α : Type u_1} {β : Type u_2} [preorder α] [conditionally_complete_lattice β] {f : α → β} (h_mono : monotone f) {s : set α} {c : α} (hcs : c ∈ s) (h_bdd : bdd_below s) : Inf (f '' s) ≤ f c :=
  le_cSup_image (fun (x y : order_dual α) (hxy : x ≤ y) => h_mono hxy) hcs h_bdd

theorem le_cInf_image {α : Type u_1} {β : Type u_2} [preorder α] [conditionally_complete_lattice β] {f : α → β} (h_mono : monotone f) {s : set α} (hs : set.nonempty s) {B : α} (hB : B ∈ lower_bounds s) : f B ≤ Inf (f '' s) :=
  cSup_image_le (fun (x y : order_dual α) (hxy : x ≤ y) => h_mono hxy) hs hB

end monotone

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

/-- Adding a top element to a conditionally complete lattice gives a conditionally complete lattice -/
protected instance with_top.conditionally_complete_lattice {α : Type u_1} [conditionally_complete_lattice α] : conditionally_complete_lattice (with_top α) :=
  conditionally_complete_lattice.mk lattice.sup lattice.le lattice.lt sorry sorry sorry sorry sorry sorry lattice.inf
    sorry sorry sorry Sup Inf sorry sorry sorry sorry

/-- Adding a bottom element to a conditionally complete lattice gives a conditionally complete lattice -/
protected instance with_bot.conditionally_complete_lattice {α : Type u_1} [conditionally_complete_lattice α] : conditionally_complete_lattice (with_bot α) :=
  conditionally_complete_lattice.mk lattice.sup lattice.le lattice.lt sorry sorry sorry sorry sorry sorry lattice.inf
    sorry sorry sorry Sup Inf sorry sorry sorry sorry

/-- Adding a bottom and a top to a conditionally complete lattice gives a bounded lattice-/
protected instance with_top.with_bot.bounded_lattice {α : Type u_1} [conditionally_complete_lattice α] : bounded_lattice (with_top (with_bot α)) :=
  bounded_lattice.mk lattice.sup order_bot.le order_bot.lt sorry sorry sorry sorry sorry sorry lattice.inf sorry sorry
    sorry order_top.top sorry order_bot.bot sorry

theorem with_bot.cSup_empty {α : Type u_1} [conditionally_complete_lattice α] : Sup ∅ = ⊥ := sorry

protected instance with_top.with_bot.complete_lattice {α : Type u_1} [conditionally_complete_lattice α] : complete_lattice (with_top (with_bot α)) :=
  complete_lattice.mk bounded_lattice.sup bounded_lattice.le bounded_lattice.lt sorry sorry sorry sorry sorry sorry
    bounded_lattice.inf sorry sorry sorry bounded_lattice.top sorry bounded_lattice.bot sorry Sup Inf sorry sorry sorry
    sorry

/-! ### Subtypes of conditionally complete linear orders

In this section we give conditions on a subset of a conditionally complete linear order, to ensure
that the subtype is itself conditionally complete.

We check that an `ord_connected` set satisfies these conditions.

TODO There are several possible variants; the `conditionally_complete_linear_order` could be changed
to `conditionally_complete_linear_order_bot` or `complete_linear_order`.
-/

/-- `has_Sup` structure on a nonempty subset `s` of an object with `has_Sup`. This definition is
non-canonical (it uses `default s`); it should be used only as here, as an auxiliary instance in the
construction of the `conditionally_complete_linear_order` structure. -/
def subset_has_Sup {α : Type u_1} (s : set α) [has_Sup α] [Inhabited ↥s] : has_Sup ↥s :=
  has_Sup.mk
    fun (t : set ↥s) =>
      dite (Sup (coe '' t) ∈ s) (fun (ht : Sup (coe '' t) ∈ s) => { val := Sup (coe '' t), property := ht })
        fun (ht : ¬Sup (coe '' t) ∈ s) => Inhabited.default

@[simp] theorem subset_Sup_def {α : Type u_1} (s : set α) [has_Sup α] [Inhabited ↥s] : Sup =
  fun (t : set ↥s) =>
    dite (Sup (coe '' t) ∈ s) (fun (ht : Sup (coe '' t) ∈ s) => { val := Sup (coe '' t), property := ht })
      fun (ht : ¬Sup (coe '' t) ∈ s) => Inhabited.default :=
  rfl

theorem subset_Sup_of_within {α : Type u_1} (s : set α) [has_Sup α] [Inhabited ↥s] {t : set ↥s} (h : Sup (coe '' t) ∈ s) : Sup (coe '' t) = ↑(Sup t) := sorry

/-- `has_Inf` structure on a nonempty subset `s` of an object with `has_Inf`. This definition is
non-canonical (it uses `default s`); it should be used only as here, as an auxiliary instance in the
construction of the `conditionally_complete_linear_order` structure. -/
def subset_has_Inf {α : Type u_1} (s : set α) [has_Inf α] [Inhabited ↥s] : has_Inf ↥s :=
  has_Inf.mk
    fun (t : set ↥s) =>
      dite (Inf (coe '' t) ∈ s) (fun (ht : Inf (coe '' t) ∈ s) => { val := Inf (coe '' t), property := ht })
        fun (ht : ¬Inf (coe '' t) ∈ s) => Inhabited.default

@[simp] theorem subset_Inf_def {α : Type u_1} (s : set α) [has_Inf α] [Inhabited ↥s] : Inf =
  fun (t : set ↥s) =>
    dite (Inf (coe '' t) ∈ s) (fun (ht : Inf (coe '' t) ∈ s) => { val := Inf (coe '' t), property := ht })
      fun (ht : ¬Inf (coe '' t) ∈ s) => Inhabited.default :=
  rfl

theorem subset_Inf_of_within {α : Type u_1} (s : set α) [has_Inf α] [Inhabited ↥s] {t : set ↥s} (h : Inf (coe '' t) ∈ s) : Inf (coe '' t) = ↑(Inf t) := sorry

/-- For a nonempty subset of a conditionally complete linear order to be a conditionally complete
linear order, it suffices that it contain the `Sup` of all its nonempty bounded-above subsets, and
the `Inf` of all its nonempty bounded-below subsets. -/
def subset_conditionally_complete_linear_order {α : Type u_1} (s : set α) [conditionally_complete_linear_order α] [Inhabited ↥s] (h_Sup : ∀ {t : set ↥s}, set.nonempty t → bdd_above t → Sup (coe '' t) ∈ s) (h_Inf : ∀ {t : set ↥s}, set.nonempty t → bdd_below t → Inf (coe '' t) ∈ s) : conditionally_complete_linear_order ↥s :=
  conditionally_complete_linear_order.mk lattice.sup lattice.le lattice.lt sorry sorry sorry sorry sorry sorry lattice.inf
    sorry sorry sorry Sup Inf sorry sorry sorry sorry sorry linear_order.decidable_le linear_order.decidable_eq
    linear_order.decidable_lt

/-- The `Sup` function on a nonempty `ord_connected` set `s` in a conditionally complete linear
order takes values within `s`, for all nonempty bounded-above subsets of `s`. -/
theorem Sup_within_of_ord_connected {α : Type u_1} [conditionally_complete_linear_order α] {s : set α} [hs : set.ord_connected s] {t : set ↥s} (ht : set.nonempty t) (h_bdd : bdd_above t) : Sup (coe '' t) ∈ s := sorry

/-- The `Inf` function on a nonempty `ord_connected` set `s` in a conditionally complete linear
order takes values within `s`, for all nonempty bounded-below subsets of `s`. -/
theorem Inf_within_of_ord_connected {α : Type u_1} [conditionally_complete_linear_order α] {s : set α} [hs : set.ord_connected s] {t : set ↥s} (ht : set.nonempty t) (h_bdd : bdd_below t) : Inf (coe '' t) ∈ s := sorry

/-- A nonempty `ord_connected` set in a conditionally complete linear order is naturally a
conditionally complete linear order. -/
protected instance ord_connected_subset_conditionally_complete_linear_order {α : Type u_1} (s : set α) [conditionally_complete_linear_order α] [Inhabited ↥s] [set.ord_connected s] : conditionally_complete_linear_order ↥s :=
  subset_conditionally_complete_linear_order s Sup_within_of_ord_connected Inf_within_of_ord_connected


/-
Copyright (c) 2020 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Lucas Allen, Scott Morrison
-/
import tactic.interactive
import tactic.converter.interactive

/-!
## Introduce the `apply_congr` conv mode tactic.

`apply_congr` will apply congruence lemmas inside `conv` mode.
It is particularly useful when the automatically generated congruence lemmas
are not of the optimal shape. An example, described in the doc-string is
rewriting inside the operand of a `finset.sum`.
-/

open tactic

namespace conv.interactive
open interactive interactive.types lean.parser

local postfix `?`:9001 := optional

/--
Apply a congruence lemma inside `conv` mode.

When called without an argument `apply_congr` will try applying all lemmas marked with `@[congr]`.
Otherwise `apply_congr e` will apply the lemma `e`.

Recall that a goal that appears as `∣ X` in `conv` mode
represents a goal of `⊢ X = ?m`,
i.e. an equation with a metavariable for the right hand side.

To successfully use `apply_congr e`, `e` will need to be an equation
(possibly after function arguments),
which can be unified with a goal of the form `X = ?m`.
The right hand side of `e` will then determine the metavariable,
and `conv` will subsequently replace `X` with that right hand side.

As usual, `apply_congr` can create new goals;
any of these which are _not_ equations with a metavariable on the right hand side
will be hard to deal with in `conv` mode.
Thus `apply_congr` automatically calls `intros` on any new goals,
and fails if they are not then equations.

In particular it is useful for rewriting inside the operand of a `finset.sum`,
as it provides an extra hypothesis asserting we are inside the domain.

For example:

```lean
example (f g : ℤ → ℤ) (S : finset ℤ) (h : ∀ m ∈ S, f m = g m) :
  finset.sum S f = finset.sum S g :=
begin
  conv_lhs
  { -- If we just call `congr` here, in the second goal we're helpless,
    -- because we are only given the opportunity to rewrite `f`.
    -- However `apply_congr` uses the appropriate `@[congr]` lemma,
    -- so we get to rewrite `f x`, in the presence of the crucial `H : x ∈ S` hypothesis.
    apply_congr,
    skip,
    simp [h, H], }
end
```

In the above example, when the `apply_congr` tactic is called it gives the hypothesis `H : x ∈ S`
which is then used to rewrite the `f x` to `g x`.
-/
meta def apply_congr (q : parse texpr?) : conv unit :=
do
  congr_lemmas ← match q with
  -- If the user specified a lemma, use that one,
  | some e := do
    gs ← get_goals,
    e ← to_expr e, -- to_expr messes with the goals? (see tests)
    set_goals gs,
    return [e]
  -- otherwise, look up everything tagged `@[congr]`
  | none := do
    congr_lemma_names ← attribute.get_instances `congr,
    congr_lemma_names.mmap mk_const
  end,
  -- For every lemma:
  congr_lemmas.any_of (λ n,
    -- Call tactic.eapply
    seq' (tactic.eapply n >> tactic.skip)
    -- and then call `intros` on each resulting goal, and require that afterwards it's an equation.
        (tactic.intros >> (do `(_ = _) ← target, tactic.skip)))

add_tactic_doc
{ name := "apply_congr",
  category := doc_category.tactic,
  decl_names := [`conv.interactive.apply_congr],
  tags := ["conv", "congruence", "rewriting"] }

end conv.interactive


/-
Copyright (c) 2021 Eric Wieser. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Eric Wieser
-/
import data.dfinsupp.basic
import data.equiv.module
import data.finsupp.basic

/-!
# Conversion between `finsupp` and homogenous `dfinsupp`

This module provides conversions between `finsupp` and `dfinsupp`.
It is in its own file since neither `finsupp` or `dfinsupp` depend on each other.

## Main definitions

* "identity" maps between `finsupp` and `dfinsupp`:
  * `finsupp.to_dfinsupp : (ι →₀ M) → (Π₀ i : ι, M)`
  * `dfinsupp.to_finsupp : (Π₀ i : ι, M) → (ι →₀ M)`
  * Bundled equiv versions of the above:
    * `finsupp_equiv_dfinsupp : (ι →₀ M) ≃ (Π₀ i : ι, M)`
    * `finsupp_add_equiv_dfinsupp : (ι →₀ M) ≃+ (Π₀ i : ι, M)`
    * `finsupp_lequiv_dfinsupp R : (ι →₀ M) ≃ₗ[R] (Π₀ i : ι, M)`
* stronger versions of `finsupp.split`:
  * `sigma_finsupp_equiv_dfinsupp : ((Σ i, η i) →₀ N) ≃ (Π₀ i, (η i →₀ N))`
  * `sigma_finsupp_add_equiv_dfinsupp : ((Σ i, η i) →₀ N) ≃+ (Π₀ i, (η i →₀ N))`
  * `sigma_finsupp_lequiv_dfinsupp : ((Σ i, η i) →₀ N) ≃ₗ[R] (Π₀ i, (η i →₀ N))`

## Theorems

The defining features of these operations is that they preserve the function and support:

* `finsupp.to_dfinsupp_coe`
* `finsupp.to_dfinsupp_support`
* `dfinsupp.to_finsupp_coe`
* `dfinsupp.to_finsupp_support`

and therefore map `finsupp.single` to `dfinsupp.single` and vice versa:

* `finsupp.to_dfinsupp_single`
* `dfinsupp.to_finsupp_single`

as well as preserving arithmetic operations.

For the bundled equivalences, we provide lemmas that they reduce to `finsupp.to_dfinsupp`:

* `finsupp_add_equiv_dfinsupp_apply`
* `finsupp_lequiv_dfinsupp_apply`
* `finsupp_add_equiv_dfinsupp_symm_apply`
* `finsupp_lequiv_dfinsupp_symm_apply`

## Implementation notes

We provide `dfinsupp.to_finsupp` and `finsupp_equiv_dfinsupp` computably by adding
`[decidable_eq ι]` and `[Π m : M, decidable (m ≠ 0)]` arguments. To aid with definitional unfolding,
these arguments are also present on the `noncomputable` equivs.
-/

variables {ι : Type*} {R : Type*} {M : Type*}

/-! ### Basic definitions and lemmas -/
section defs

/-- Interpret a `finsupp` as a homogenous `dfinsupp`. -/
def finsupp.to_dfinsupp [has_zero M] (f : ι →₀ M) : Π₀ i : ι, M :=
⟦⟨f, f.support.1, λ i, (classical.em (f i = 0)).symm.imp_left (finsupp.mem_support_iff.mpr)⟩⟧

@[simp] lemma finsupp.to_dfinsupp_coe [has_zero M] (f : ι →₀ M) : ⇑f.to_dfinsupp = f := rfl

section
variables [decidable_eq ι] [has_zero M]

@[simp] lemma finsupp.to_dfinsupp_single (i : ι) (m : M) :
  (finsupp.single i m).to_dfinsupp = dfinsupp.single i m :=
by { ext, simp [finsupp.single_apply, dfinsupp.single_apply] }

variables [Π m : M, decidable (m ≠ 0)]

@[simp] lemma to_dfinsupp_support (f : ι →₀ M) : f.to_dfinsupp.support = f.support :=
by { ext, simp, }

/-- Interpret a homogenous `dfinsupp` as a `finsupp`.

Note that the elaborator has a lot of trouble with this definition - it is often necessary to
write `(dfinsupp.to_finsupp f : ι →₀ M)` instead of `f.to_finsupp`, as for some unknown reason
using dot notation or omitting the type ascription prevents the type being resolved correctly. -/
def dfinsupp.to_finsupp (f : Π₀ i : ι, M) : ι →₀ M :=
⟨f.support, f, λ i, by simp only [dfinsupp.mem_support_iff]⟩

@[simp] lemma dfinsupp.to_finsupp_coe (f : Π₀ i : ι, M) : ⇑f.to_finsupp = f := rfl
@[simp] lemma dfinsupp.to_finsupp_support (f : Π₀ i : ι, M) : f.to_finsupp.support = f.support :=
by { ext, simp, }

@[simp] lemma dfinsupp.to_finsupp_single (i : ι) (m : M) :
  (dfinsupp.single i m : Π₀ i : ι, M).to_finsupp = finsupp.single i m :=
by { ext, simp [finsupp.single_apply, dfinsupp.single_apply] }

@[simp] lemma finsupp.to_dfinsupp_to_finsupp (f : ι →₀ M) : f.to_dfinsupp.to_finsupp = f :=
finsupp.coe_fn_injective rfl

@[simp] lemma dfinsupp.to_finsupp_to_dfinsupp (f : Π₀ i : ι, M) : f.to_finsupp.to_dfinsupp = f :=
dfinsupp.coe_fn_injective rfl

end

end defs

/-! ### Lemmas about arithmetic operations -/
section lemmas

namespace finsupp

@[simp] lemma to_dfinsupp_zero [has_zero M] :
  (0 : ι →₀ M).to_dfinsupp = 0 := dfinsupp.coe_fn_injective rfl

@[simp] lemma to_dfinsupp_add [add_zero_class M] (f g : ι →₀ M) :
  (f + g).to_dfinsupp = f.to_dfinsupp + g.to_dfinsupp := dfinsupp.coe_fn_injective rfl

@[simp] lemma to_dfinsupp_neg [add_group M] (f : ι →₀ M) :
  (-f).to_dfinsupp = -f.to_dfinsupp := dfinsupp.coe_fn_injective rfl

@[simp] lemma to_dfinsupp_sub [add_group M] (f g : ι →₀ M) :
  (f - g).to_dfinsupp = f.to_dfinsupp - g.to_dfinsupp :=
dfinsupp.coe_fn_injective rfl

@[simp] lemma to_dfinsupp_smul [monoid R] [add_monoid M] [distrib_mul_action R M]
  (r : R) (f : ι →₀ M) : (r • f).to_dfinsupp = r • f.to_dfinsupp :=
dfinsupp.coe_fn_injective rfl

end finsupp

namespace dfinsupp
variables [decidable_eq ι]

@[simp] lemma to_finsupp_zero [has_zero M] [Π m : M, decidable (m ≠ 0)] :
  to_finsupp 0 = (0 : ι →₀ M) := finsupp.coe_fn_injective rfl

@[simp] lemma to_finsupp_add [add_zero_class M] [Π m : M, decidable (m ≠ 0)] (f g : Π₀ i : ι, M) :
  (to_finsupp (f + g) : ι →₀ M) = (to_finsupp f + to_finsupp g) :=
finsupp.coe_fn_injective $ dfinsupp.coe_add _ _

@[simp] lemma to_finsupp_neg [add_group M] [Π m : M, decidable (m ≠ 0)] (f : Π₀ i : ι, M) :
  (to_finsupp (-f) : ι →₀ M) = -to_finsupp f :=
finsupp.coe_fn_injective $ dfinsupp.coe_neg _

@[simp] lemma to_finsupp_sub [add_group M] [Π m : M, decidable (m ≠ 0)] (f g : Π₀ i : ι, M) :
  (to_finsupp (f - g) : ι →₀ M) = to_finsupp f - to_finsupp g :=
finsupp.coe_fn_injective $ dfinsupp.coe_sub _ _

@[simp] lemma to_finsupp_smul [monoid R] [add_monoid M] [distrib_mul_action R M]
  [Π m : M, decidable (m ≠ 0)]
  (r : R) (f : Π₀ i : ι, M) : (to_finsupp (r • f) : ι →₀ M) = r • to_finsupp f :=
finsupp.coe_fn_injective $ dfinsupp.coe_smul _ _

end dfinsupp

end lemmas

/-! ### Bundled `equiv`s -/

section equivs

/-- `finsupp.to_dfinsupp` and `dfinsupp.to_finsupp` together form an equiv. -/
@[simps {fully_applied := ff}]
def finsupp_equiv_dfinsupp [decidable_eq ι] [has_zero M] [Π m : M, decidable (m ≠ 0)] :
  (ι →₀ M) ≃ (Π₀ i : ι, M) :=
{ to_fun := finsupp.to_dfinsupp, inv_fun := dfinsupp.to_finsupp,
  left_inv := finsupp.to_dfinsupp_to_finsupp, right_inv := dfinsupp.to_finsupp_to_dfinsupp }

/-- The additive version of `finsupp.to_finsupp`. Note that this is `noncomputable` because
`finsupp.has_add` is noncomputable. -/
@[simps {fully_applied := ff}]
noncomputable def finsupp_add_equiv_dfinsupp
  [decidable_eq ι] [add_zero_class M] [Π m : M, decidable (m ≠ 0)] :
  (ι →₀ M) ≃+ (Π₀ i : ι, M) :=
{ to_fun := finsupp.to_dfinsupp, inv_fun := dfinsupp.to_finsupp,
  map_add' := finsupp.to_dfinsupp_add,
  .. finsupp_equiv_dfinsupp}

variables (R)

/-- The additive version of `finsupp.to_finsupp`. Note that this is `noncomputable` because
`finsupp.has_add` is noncomputable. -/
@[simps {fully_applied := ff}]
noncomputable def finsupp_lequiv_dfinsupp
  [decidable_eq ι] [semiring R] [add_comm_monoid M] [Π m : M, decidable (m ≠ 0)] [module R M] :
  (ι →₀ M) ≃ₗ[R] (Π₀ i : ι, M) :=
{ to_fun := finsupp.to_dfinsupp, inv_fun := dfinsupp.to_finsupp,
  map_smul' := finsupp.to_dfinsupp_smul,
  map_add' := finsupp.to_dfinsupp_add,
  .. finsupp_equiv_dfinsupp}

section sigma
/-- ### Stronger versions of `finsupp.split` -/

noncomputable theory
open_locale classical

variables {η : ι → Type*} {N : Type*} [semiring R]

open finsupp

/-- `finsupp.split` is an equivalence between `(Σ i, η i) →₀ N` and `Π₀ i, (η i →₀ N)`. -/
def sigma_finsupp_equiv_dfinsupp [has_zero N] : ((Σ i, η i) →₀ N) ≃ (Π₀ i, (η i →₀ N)) :=
{ to_fun := λ f, ⟦⟨split f, (split_support f : finset ι).val, λ i,
    begin
    rw [← finset.mem_def, mem_split_support_iff_nonzero],
    exact (decidable.em _).symm
    end⟩⟧,
  inv_fun := λ f,
  begin
    refine on_finset (finset.sigma f.support (λ j, (f j).support)) (λ ji, f ji.1 ji.2)
      (λ g hg, finset.mem_sigma.mpr ⟨_, mem_support_iff.mpr hg⟩),
    simp only [ne.def, dfinsupp.mem_support_to_fun],
    intro h,
    rw h at hg,
    simpa using hg
  end,
  left_inv := λ f, by { ext, simp [split] },
  right_inv := λ f, by { ext, simp [split] } }

@[simp]
lemma sigma_finsupp_equiv_dfinsupp_apply [has_zero N] (f : (Σ i, η i) →₀ N) :
  (sigma_finsupp_equiv_dfinsupp f : Π i, (η i →₀ N)) = finsupp.split f := rfl

@[simp]
lemma sigma_finsupp_equiv_dfinsupp_symm_apply [has_zero N] (f : Π₀ i, (η i →₀ N)) (s : Σ i, η i) :
  (sigma_finsupp_equiv_dfinsupp.symm f : (Σ i, η i) →₀ N) s = f s.1 s.2 := rfl

@[simp]
lemma sigma_finsupp_equiv_dfinsupp_support [has_zero N] (f : (Σ i, η i) →₀ N) :
  (sigma_finsupp_equiv_dfinsupp f).support = finsupp.split_support f :=
begin
  ext,
  rw dfinsupp.mem_support_to_fun,
  exact (finsupp.mem_split_support_iff_nonzero _ _).symm,
end

@[simp] lemma sigma_finsupp_equiv_dfinsupp_single [has_zero N] (a : Σ i, η i) (n : N) :
  sigma_finsupp_equiv_dfinsupp (finsupp.single a n)
    = @dfinsupp.single _ (λ i, η i →₀ N) _ _ a.1 (finsupp.single a.2 n) :=
begin
  obtain ⟨i, a⟩ := a,
  ext j b,
  by_cases h : i = j,
  { subst h,
    simp [split_apply, finsupp.single_apply] },
  suffices : finsupp.single (⟨i, a⟩ : Σ i, η i) n ⟨j, b⟩ = 0,
  { simp [split_apply, dif_neg h, this] },
  have H : (⟨i, a⟩ : Σ i, η i) ≠ ⟨j, b⟩ := by simp [h],
  rw [finsupp.single_apply, if_neg H]
end

-- Without this Lean fails to find the `add_zero_class` instance on `Π₀ i, (η i →₀ N)`.
local attribute [-instance] finsupp.has_zero

@[simp]
lemma sigma_finsupp_equiv_dfinsupp_add [add_zero_class N] (f g : (Σ i, η i) →₀ N) :
  sigma_finsupp_equiv_dfinsupp (f + g) =
  (sigma_finsupp_equiv_dfinsupp f + (sigma_finsupp_equiv_dfinsupp g) : (Π₀ (i : ι), η i →₀ N)) :=
by {ext, refl}

/-- `finsupp.split` is an additive equivalence between `(Σ i, η i) →₀ N` and `Π₀ i, (η i →₀ N)`. -/
@[simps]
def sigma_finsupp_add_equiv_dfinsupp [add_zero_class N] : ((Σ i, η i) →₀ N) ≃+ (Π₀ i, (η i →₀ N)) :=
{ to_fun := sigma_finsupp_equiv_dfinsupp,
  inv_fun := sigma_finsupp_equiv_dfinsupp.symm,
  map_add' := sigma_finsupp_equiv_dfinsupp_add,
  .. sigma_finsupp_equiv_dfinsupp }

local attribute [-instance] finsupp.add_zero_class

--tofix: r • (sigma_finsupp_equiv_dfinsupp f) doesn't work.
@[simp]
lemma sigma_finsupp_equiv_dfinsupp_smul {R} [monoid R] [add_monoid N] [distrib_mul_action R N]
  (r : R) (f : (Σ i, η i) →₀ N) : sigma_finsupp_equiv_dfinsupp (r • f) =
  @has_scalar.smul R (Π₀ i, η i →₀ N) mul_action.to_has_scalar r (sigma_finsupp_equiv_dfinsupp f) :=
by { ext, refl }

local attribute [-instance] finsupp.add_monoid

/-- `finsupp.split` is a linear equivalence between `(Σ i, η i) →₀ N` and `Π₀ i, (η i →₀ N)`. -/
@[simps]
def sigma_finsupp_lequiv_dfinsupp [add_comm_monoid N] [module R N] :
  ((Σ i, η i) →₀ N) ≃ₗ[R] (Π₀ i, (η i →₀ N)) :=
{ map_smul' := sigma_finsupp_equiv_dfinsupp_smul,
  .. sigma_finsupp_add_equiv_dfinsupp }

end sigma

end equivs


/-
Copyright (c) 2020 Bhavik Mehta. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Bhavik Mehta, Jakob von Raumer
-/
import data.list.chain
import category_theory.punit
import category_theory.groupoid
import category_theory.category.ulift

/-!
# Connected category

Define a connected category as a _nonempty_ category for which every functor
to a discrete category is isomorphic to the constant functor.

NB. Some authors include the empty category as connected, we do not.
We instead are interested in categories with exactly one 'connected
component'.

We give some equivalent definitions:
- A nonempty category for which every functor to a discrete category is
  constant on objects.
  See `any_functor_const_on_obj` and `connected.of_any_functor_const_on_obj`.
- A nonempty category for which every function `F` for which the presence of a
  morphism `f : j₁ ⟶ j₂` implies `F j₁ = F j₂` must be constant everywhere.
  See `constant_of_preserves_morphisms` and `connected.of_constant_of_preserves_morphisms`.
- A nonempty category for which any subset of its elements containing the
  default and closed under morphisms is everything.
  See `induct_on_objects` and `connected.of_induct`.
- A nonempty category for which every object is related under the reflexive
  transitive closure of the relation "there is a morphism in some direction
  from `j₁` to `j₂`".
  See `connected_zigzag` and `zigzag_connected`.
- A nonempty category for which for any two objects there is a sequence of
  morphisms (some reversed) from one to the other.
  See `exists_zigzag'` and `connected_of_zigzag`.

We also prove the result that the functor given by `(X × -)` preserves any
connected limit. That is, any limit of shape `J` where `J` is a connected
category is preserved by the functor `(X × -)`. This appears in `category_theory.limits.connected`.
-/

universes v₁ v₂ u₁ u₂

noncomputable theory

open category_theory.category
open opposite

namespace category_theory

/--
A possibly empty category for which every functor to a discrete category is constant.
-/
class is_preconnected (J : Type u₁) [category.{v₁} J] : Prop :=
(iso_constant : Π {α : Type u₁} (F : J ⥤ discrete α) (j : J),
  nonempty (F ≅ (functor.const J).obj (F.obj j)))

/--
We define a connected category as a _nonempty_ category for which every
functor to a discrete category is constant.

NB. Some authors include the empty category as connected, we do not.
We instead are interested in categories with exactly one 'connected
component'.

This allows us to show that the functor X ⨯ - preserves connected limits.

See <https://stacks.math.columbia.edu/tag/002S>
-/
class is_connected (J : Type u₁) [category.{v₁} J] extends is_preconnected J : Prop :=
[is_nonempty : nonempty J]

attribute [instance, priority 100] is_connected.is_nonempty

variables {J : Type u₁} [category.{v₁} J]
variables {K : Type u₂} [category.{v₂} K]

/--
If `J` is connected, any functor `F : J ⥤ discrete α` is isomorphic to
the constant functor with value `F.obj j` (for any choice of `j`).
-/
def iso_constant [is_preconnected J] {α : Type u₁} (F : J ⥤ discrete α) (j : J) :
  F ≅ (functor.const J).obj (F.obj j) :=
  (is_preconnected.iso_constant F j).some

/--
If J is connected, any functor to a discrete category is constant on objects.
The converse is given in `is_connected.of_any_functor_const_on_obj`.
-/
lemma any_functor_const_on_obj [is_preconnected J]
  {α : Type u₁} (F : J ⥤ discrete α) (j j' : J) :
  F.obj j = F.obj j' :=
by { ext, exact ((iso_constant F j').hom.app j).down.1 }

/--
If any functor to a discrete category is constant on objects, J is connected.
The converse of `any_functor_const_on_obj`.
-/
lemma is_connected.of_any_functor_const_on_obj [nonempty J]
  (h : ∀ {α : Type u₁} (F : J ⥤ discrete α), ∀ (j j' : J), F.obj j = F.obj j') :
  is_connected J :=
{ iso_constant := λ α F j',
  ⟨nat_iso.of_components (λ j, eq_to_iso (h F j j')) (λ _ _ _, subsingleton.elim _ _)⟩ }

/--
If `J` is connected, then given any function `F` such that the presence of a
morphism `j₁ ⟶ j₂` implies `F j₁ = F j₂`, we have that `F` is constant.
This can be thought of as a local-to-global property.

The converse is shown in `is_connected.of_constant_of_preserves_morphisms`
-/
lemma constant_of_preserves_morphisms [is_preconnected J] {α : Type u₁} (F : J → α)
  (h : ∀ (j₁ j₂ : J) (f : j₁ ⟶ j₂), F j₁ = F j₂) (j j' : J) :
  F j = F j' :=
by simpa using any_functor_const_on_obj
  { obj := discrete.mk ∘ F,
    map := λ _ _ f, eq_to_hom (by { ext, exact (h _ _ f), }) } j j'

/--
`J` is connected if: given any function `F : J → α` which is constant for any
`j₁, j₂` for which there is a morphism `j₁ ⟶ j₂`, then `F` is constant.
This can be thought of as a local-to-global property.

The converse of `constant_of_preserves_morphisms`.
-/
lemma is_connected.of_constant_of_preserves_morphisms [nonempty J]
  (h : ∀ {α : Type u₁} (F : J → α), (∀ {j₁ j₂ : J} (f : j₁ ⟶ j₂), F j₁ = F j₂) →
    (∀ j j' : J, F j = F j')) :
  is_connected J :=
is_connected.of_any_functor_const_on_obj
  (λ _ F, h F.obj (λ _ _ f, by { ext, exact discrete.eq_of_hom (F.map f) }))

/--
An inductive-like property for the objects of a connected category.
If the set `p` is nonempty, and `p` is closed under morphisms of `J`,
then `p` contains all of `J`.

The converse is given in `is_connected.of_induct`.
-/
lemma induct_on_objects [is_preconnected J] (p : set J) {j₀ : J} (h0 : j₀ ∈ p)
  (h1 : ∀ {j₁ j₂ : J} (f : j₁ ⟶ j₂), j₁ ∈ p ↔ j₂ ∈ p) (j : J) :
  j ∈ p :=
begin
  injection (constant_of_preserves_morphisms (λ k, ulift.up (k ∈ p)) (λ j₁ j₂ f, _) j j₀) with i,
  rwa i,
  dsimp,
  exact congr_arg ulift.up (propext (h1 f)),
end

/--
If any maximal connected component containing some element j₀ of J is all of J, then J is connected.

The converse of `induct_on_objects`.
-/
lemma is_connected.of_induct [nonempty J] {j₀ : J}
  (h : ∀ (p : set J), j₀ ∈ p → (∀ {j₁ j₂ : J} (f : j₁ ⟶ j₂), j₁ ∈ p ↔ j₂ ∈ p) → ∀ (j : J), j ∈ p) :
  is_connected J :=
is_connected.of_constant_of_preserves_morphisms (λ α F a,
begin
  have w := h {j | F j = F j₀} rfl (λ _ _ f, by simp [a f]),
  dsimp at w,
  intros j j',
  rw [w j, w j'],
end)

/-- Lifting the universe level of morphisms and objects preserves connectedness. -/
instance [hc : is_connected J] : is_connected (ulift_hom.{v₂} (ulift.{u₂} J)) :=
begin
  haveI : nonempty (ulift_hom.{v₂} (ulift.{u₂} J)), { simp [ulift_hom, hc.is_nonempty] },
  apply is_connected.of_induct,
  rintros p hj₀ h ⟨j⟩,
  let p' : set J := ((λ (j : J), p {down := j}) : set J),
  have hj₀' : (classical.choice hc.is_nonempty) ∈ p', { simp only [p'], exact hj₀ },
  apply induct_on_objects (λ (j : J), p {down := j}) hj₀'
    (λ _ _ f, h ((ulift_hom_ulift_category.equiv J).functor.map f))
end

/--
Another induction principle for `is_preconnected J`:
given a type family `Z : J → Sort*` and
a rule for transporting in *both* directions along a morphism in `J`,
we can transport an `x : Z j₀` to a point in `Z j` for any `j`.
-/
lemma is_preconnected_induction [is_preconnected J] (Z : J → Sort*)
  (h₁ : Π {j₁ j₂ : J} (f : j₁ ⟶ j₂), Z j₁ → Z j₂)
  (h₂ : Π {j₁ j₂ : J} (f : j₁ ⟶ j₂), Z j₂ → Z j₁)
  {j₀ : J} (x : Z j₀) (j : J) : nonempty (Z j) :=
(induct_on_objects {j | nonempty (Z j)} ⟨x⟩
  (λ j₁ j₂ f, ⟨by { rintro ⟨y⟩, exact ⟨h₁ f y⟩, }, by { rintro ⟨y⟩, exact ⟨h₂ f y⟩, }⟩) j : _)

/-- If `J` and `K` are equivalent, then if `J` is preconnected then `K` is as well. -/
lemma is_preconnected_of_equivalent {K : Type u₁} [category.{v₂} K] [is_preconnected J]
  (e : J ≌ K) :
  is_preconnected K :=
{ iso_constant := λ α F k, ⟨
  calc F ≅ e.inverse ⋙ e.functor ⋙ F : (e.inv_fun_id_assoc F).symm
     ... ≅ e.inverse ⋙ (functor.const J).obj ((e.functor ⋙ F).obj (e.inverse.obj k)) :
                       iso_whisker_left e.inverse (iso_constant (e.functor ⋙ F) (e.inverse.obj k))

     ... ≅ e.inverse ⋙ (functor.const J).obj (F.obj k) :
          iso_whisker_left _ ((F ⋙ functor.const J).map_iso (e.counit_iso.app k))
     ... ≅ (functor.const K).obj (F.obj k) : nat_iso.of_components (λ X, iso.refl _) (by simp),
  ⟩ }

/-- If `J` and `K` are equivalent, then if `J` is connected then `K` is as well. -/
lemma is_connected_of_equivalent {K : Type u₁} [category.{v₂} K]
  (e : J ≌ K) [is_connected J] :
  is_connected K :=
{ is_nonempty := nonempty.map e.functor.obj (by apply_instance),
  to_is_preconnected := is_preconnected_of_equivalent e }

/-- If `J` is preconnected, then `Jᵒᵖ` is preconnected as well. -/
instance is_preconnected_op [is_preconnected J] : is_preconnected Jᵒᵖ :=
{ iso_constant := λ α F X, ⟨nat_iso.of_components
      (λ Y, eq_to_iso (discrete.ext _ _ (discrete.eq_of_hom ((nonempty.some
        (is_preconnected.iso_constant (F.right_op ⋙ (discrete.opposite α).functor) (unop X))).app
          (unop Y)).hom)))
      (λ Y Z f, subsingleton.elim _ _)⟩ }

/-- If `J` is connected, then `Jᵒᵖ` is connected as well. -/
instance is_connected_op [is_connected J] : is_connected Jᵒᵖ :=
{ is_nonempty := nonempty.intro (op (classical.arbitrary J)) }

lemma is_preconnected_of_is_preconnected_op [is_preconnected Jᵒᵖ] : is_preconnected J :=
is_preconnected_of_equivalent (op_op_equivalence J)

lemma is_connected_of_is_connected_op [is_connected Jᵒᵖ] : is_connected J :=
is_connected_of_equivalent (op_op_equivalence J)

/-- j₁ and j₂ are related by `zag` if there is a morphism between them. -/
@[reducible]
def zag (j₁ j₂ : J) : Prop := nonempty (j₁ ⟶ j₂) ∨ nonempty (j₂ ⟶ j₁)

lemma zag_symmetric : symmetric (@zag J _) :=
λ j₂ j₁ h, h.swap

/--
`j₁` and `j₂` are related by `zigzag` if there is a chain of
morphisms from `j₁` to `j₂`, with backward morphisms allowed.
-/
@[reducible]
def zigzag : J → J → Prop := relation.refl_trans_gen zag

lemma zigzag_symmetric : symmetric (@zigzag J _) :=
relation.refl_trans_gen.symmetric zag_symmetric

lemma zigzag_equivalence : _root_.equivalence (@zigzag J _) :=
mk_equivalence _
    relation.reflexive_refl_trans_gen
    zigzag_symmetric
    relation.transitive_refl_trans_gen

/--
The setoid given by the equivalence relation `zigzag`. A quotient for this
setoid is a connected component of the category.
-/
def zigzag.setoid (J : Type u₂) [category.{v₁} J] : setoid J :=
{ r := zigzag,
  iseqv := zigzag_equivalence }

/--
If there is a zigzag from `j₁` to `j₂`, then there is a zigzag from `F j₁` to
`F j₂` as long as `F` is a functor.
-/
lemma zigzag_obj_of_zigzag (F : J ⥤ K) {j₁ j₂ : J} (h : zigzag j₁ j₂) :
  zigzag (F.obj j₁) (F.obj j₂) :=
h.lift _ $ λ j k, or.imp (nonempty.map (λ f, F.map f)) (nonempty.map (λ f, F.map f))

-- TODO: figure out the right way to generalise this to `zigzag`.
lemma zag_of_zag_obj (F : J ⥤ K) [full F] {j₁ j₂ : J} (h : zag (F.obj j₁) (F.obj j₂)) :
  zag j₁ j₂ :=
or.imp (nonempty.map F.preimage) (nonempty.map F.preimage) h

/-- Any equivalence relation containing (⟶) holds for all pairs of a connected category. -/
lemma equiv_relation [is_connected J] (r : J → J → Prop) (hr : _root_.equivalence r)
  (h : ∀ {j₁ j₂ : J} (f : j₁ ⟶ j₂), r j₁ j₂) :
  ∀ (j₁ j₂ : J), r j₁ j₂ :=
begin
  have z : ∀ (j : J), r (classical.arbitrary J) j :=
    induct_on_objects (λ k, r (classical.arbitrary J) k)
      (hr.1 (classical.arbitrary J)) (λ _ _ f, ⟨λ t, hr.2.2 t (h f), λ t, hr.2.2 t (hr.2.1 (h f))⟩),
  intros, apply hr.2.2 (hr.2.1 (z _)) (z _)
end

/-- In a connected category, any two objects are related by `zigzag`. -/
lemma is_connected_zigzag [is_connected J] (j₁ j₂ : J) : zigzag j₁ j₂ :=
equiv_relation _ zigzag_equivalence
  (λ _ _ f, relation.refl_trans_gen.single (or.inl (nonempty.intro f))) _ _

/--
If any two objects in an nonempty category are related by `zigzag`, the category is connected.
-/
lemma zigzag_is_connected [nonempty J] (h : ∀ (j₁ j₂ : J), zigzag j₁ j₂) : is_connected J :=
begin
  apply is_connected.of_induct,
  intros p hp hjp j,
  have: ∀ (j₁ j₂ : J), zigzag j₁ j₂ → (j₁ ∈ p ↔ j₂ ∈ p),
  { introv k,
    induction k with _ _ rt_zag zag,
    { refl },
    { rw k_ih,
      rcases zag with ⟨⟨_⟩⟩ | ⟨⟨_⟩⟩,
      apply hjp zag,
      apply (hjp zag).symm } },
  rwa this j (classical.arbitrary J) (h _ _)
end

lemma exists_zigzag' [is_connected J] (j₁ j₂ : J) :
  ∃ l, list.chain zag j₁ l ∧ list.last (j₁ :: l) (list.cons_ne_nil _ _) = j₂ :=
list.exists_chain_of_relation_refl_trans_gen (is_connected_zigzag _ _)

/--
If any two objects in an nonempty category are linked by a sequence of (potentially reversed)
morphisms, then J is connected.

The converse of `exists_zigzag'`.
-/
lemma is_connected_of_zigzag [nonempty J]
  (h : ∀ (j₁ j₂ : J), ∃ l, list.chain zag j₁ l ∧ list.last (j₁ :: l) (list.cons_ne_nil _ _) = j₂) :
  is_connected J :=
begin
  apply zigzag_is_connected,
  intros j₁ j₂,
  rcases h j₁ j₂ with ⟨l, hl₁, hl₂⟩,
  apply list.relation_refl_trans_gen_of_exists_chain l hl₁ hl₂,
end

/-- If `discrete α` is connected, then `α` is (type-)equivalent to `punit`. -/
def discrete_is_connected_equiv_punit {α : Type u₁} [is_connected (discrete α)] : α ≃ punit :=
discrete.equiv_of_equivalence.{u₁ u₁}
  { functor := functor.star (discrete α),
    inverse := discrete.functor (λ _, classical.arbitrary _),
    unit_iso := by { exact (iso_constant _ (classical.arbitrary _)), },
    counit_iso := functor.punit_ext _ _ }

variables {C : Type u₂} [category.{u₁} C]

/--
For objects `X Y : C`, any natural transformation `α : const X ⟶ const Y` from a connected
category must be constant.
This is the key property of connected categories which we use to establish properties about limits.
-/
lemma nat_trans_from_is_connected [is_preconnected J] {X Y : C}
  (α : (functor.const J).obj X ⟶ (functor.const J).obj Y) :
  ∀ (j j' : J), α.app j = (α.app j' : X ⟶ Y) :=
@constant_of_preserves_morphisms _ _ _
  (X ⟶ Y)
  (λ j, α.app j)
  (λ _ _ f, (by { have := α.naturality f, erw [id_comp, comp_id] at this, exact this.symm }))

instance [is_connected J] : full (functor.const J : C ⥤ J ⥤ C) :=
{ preimage := λ X Y f, f.app (classical.arbitrary J),
  witness' := λ X Y f,
  begin
    ext j,
    apply nat_trans_from_is_connected f (classical.arbitrary J) j,
  end }

instance nonempty_hom_of_connected_groupoid {G} [groupoid G] [is_connected G] :
  ∀ (x y : G), nonempty (x ⟶ y) :=
begin
  refine equiv_relation _ _ (λ j₁ j₂, nonempty.intro),
  exact ⟨λ j, ⟨𝟙 _⟩, λ j₁ j₂, nonempty.map (λ f, inv f), λ _ _ _, nonempty.map2 (≫)⟩,
end

end category_theory