import .regular_open_algebra .pSet_ordinal

/-
  Defining the collapsing poset/topology/boolean algebra and proving properties about them
-/

universe variables u v

lemma poset_yoneda_iff {β : Type*} [partial_order β] {a b : β} : (∀Γ : β, Γ ≤ a → Γ ≤ b) ↔ a ≤ b :=
⟨ lattice.poset_yoneda, λ h Γ, lattice.poset_yoneda_inv Γ h⟩

lemma poset_coyoneda_iff {β : Type*} [partial_order β] {a b : β} :
  (∀Γ : β, a ≤ Γ → b ≤ Γ) ↔ b ≤ a :=
⟨λ h, h a (le_refl a), λ h Γ h', le_trans h h'⟩

namespace set

theorem subset_Inter_iff {α β} {t : set β} {s : α → set β} : t ⊆ (⋂ i, s i) ↔ ∀ i, t ⊆ s i :=
by { simp [subset_def], conv_rhs { rw [forall_swap] }, apply forall_congr, intro x, rw [forall_swap] }

end set
namespace subtype

definition val_eq_coe {α} {p : α → Prop} (x : subtype p) : x.val = x := by refl

end subtype

namespace cardinal -- todo: move
open cardinal set

theorem sum_const_lift (ι : Type u) (a : cardinal.{max u v}) :
  sum (λ _:ι, a) = lift.{_ v} (mk ι) * a :=
quotient.induction_on a $ λ α, by simp; exact
  quotient.sound ⟨(equiv.sigma_equiv_prod _ _).trans (equiv.prod_congr equiv.ulift.symm (by refl))⟩

theorem sum_le_sup_lift {ι : Type u} (f : ι → cardinal.{max u v}) :
  sum f ≤ lift.{_ v} (mk ι) * sup f :=
by rw ← sum_const_lift; exact sum_le_sum _ _ (le_sup _)

-- TODO: replace mk_Union_le_sum_mk
theorem mk_Union_le_sum_mk' {ι : Type u} {α : Type (max u v)} {f : ι → set α} :
  mk (set.Union f) ≤ sum (λ i, mk (f i)) :=
calc mk (set.Union f) ≤ mk (Σ i, f i) : mk_le_of_surjective (set.surjective_sigma_to_Union f)
  ... = sum (λ i, mk (f i)) : (sum_mk _).symm

lemma mk_Union_le_lift {ι : Type u} {α : Type (max u v)} (f : ι → set α) :
  mk (set.Union f) ≤ lift.{_ v} (mk ι) * cardinal.sup (λ i, mk (f i)) :=
le_trans mk_Union_le_sum_mk' (sum_le_sup_lift _)

end cardinal

namespace ordinal

open cardinal

theorem sup_lt_ord_lift {ι : Type u} (f : ι → ordinal.{max u v}) {c : ordinal}
  (H1 : cardinal.lift.{_ v} (mk ι) < c.cof) (H2 : ∀ i, f i < c) : sup f < c :=
begin
  apply lt_of_le_of_ne,
  { rw [sup_le], exact λ i, le_of_lt (H2 i) },
  rintro h, apply not_le_of_lt H1,
  simpa [sup_ord, H2, h] using cof_sup_le_lift.{u} f
end

theorem sup_lt_lift {ι : Type u} (f : ι → cardinal.{max u v}) {c : cardinal.{max u v}}
  (H1 : cardinal.lift.{_ v} (cardinal.mk ι) < c.ord.cof)
  (H2 : ∀ i, f i < c) : cardinal.sup f < c :=
by { rw [←ord_lt_ord, ←sup_ord], apply sup_lt_ord_lift _ H1, intro i, rw ord_lt_ord, apply H2 }

end ordinal

namespace topological_space

lemma mem_interior_of_is_topological_basis {α} [topological_space α] {B : set (set α)}
  (hB : is_topological_basis B) {s : set α} {x : α} : x ∈ interior s ↔ ∃ t ⊆ s, t ∈ B ∧ x ∈ t :=
begin
  rw [mem_interior], split,
  { rintro ⟨t, h1t, h2t, h3t⟩,
    rcases mem_basis_subset_of_mem_open hB h3t h2t with ⟨u, h1u, h2u, h3u⟩,
    exact ⟨u, set.subset.trans h3u h1t, h1u, h2u⟩ },
  { rintro ⟨t, h1t, h2t, h3t⟩, exact ⟨t, h1t, is_open_of_is_topological_basis hB h2t, h3t⟩ }
end

end topological_space

open lattice topological_space cardinal pSet

noncomputable theory

local notation `ℵ₁` := (card_ex $ aleph 1 : pSet)

local infix ` ⟹ `:65 := lattice.imp

local infix ` ⇔ `:50 := lattice.biimp

local attribute [instance, priority 0] classical.prop_decidable

local prefix `#`:max := cardinal.mk

/- to_mathlib -/
@[simp] lemma iff_or_self_left {p q : Prop} : (p ↔ p ∨ q) ↔ (q → p) :=
⟨ λ h hq, h.2 (or.inr hq), λ h, ⟨or.inl, λ h', h'.elim id h⟩⟩

@[simp] lemma iff_or_self_right {p q : Prop} : (p ↔ q ∨ p) ↔ (q → p) :=
by simp [or.comm]

@[simp] lemma and_iff_self_right {p q : Prop} : (p ∧ q ↔ p) ↔ (p → q) :=
⟨ λ h hp, (h.mpr hp).2, λ h, ⟨and.left, λ hp, ⟨hp, h hp⟩⟩⟩

@[simp] lemma and_iff_self_left {p q : Prop} : (p ∧ q ↔ q) ↔ (q → p) :=
by { rw [and.comm], exact and_iff_self_right }

lemma and_or_and_not {p q r : Prop} : p ∧ (q ∨ (r ∧ ¬ p)) ↔ p ∧ q :=
by simp [and_or_distrib_left, and.comm, and.assoc.symm]

lemma or_and_iff_or {p q r : Prop} : (p ∨ (q ∧ r) ↔ p ∨ q) ↔ (q → p ∨ r) :=
⟨ λ h hq, (h.2 (or.inr hq)).imp id and.right,
  λ h, ⟨λ h', h'.imp id and.left, λ h', h'.elim or.inl $ λ hq, (h hq).imp id $ λ hr, ⟨hq, hr⟩⟩⟩

lemma and_or_iff_and {p q r : Prop} : (p ∧ (q ∨ r) ↔ p ∧ r) ↔ (p → q → r) :=
⟨ λ h hp hq, (h.mp ⟨hp, or.inl hq⟩).2,
  λ h, ⟨λ h', ⟨h'.1, h'.2.elim (h h'.1) id⟩, and.imp id or.inr⟩⟩

lemma or_not_iff (p q : Prop) [decidable q] : (p ∨ ¬ q) ↔ (q → p) :=
by { rw [imp_iff_not_or, or_comm] }

lemma eq_iff_eq_of_eq_left {α} {x y z : α} (h : x = y) : x = z ↔ y = z :=
by rw [h]

lemma eq_iff_eq_of_eq_right {α} {x y z : α} (h : x = y) : z = x ↔ z = y :=
by rw [h]

namespace roption

variables {α : Type*} {o₁ o₂ : roption α} {x : α}
/-- The intersection of two partial functions -/
def inter (o₁ o₂ : roption α) : roption α :=
⟨ ∃(x : α), x ∈ o₁ ∧ x ∈ o₂,
  λ h, o₁.get $ dom_iff_mem.2 $ let ⟨x, h1x, h2x⟩ := h in ⟨x, h1x⟩⟩

instance : has_inter (roption α) := ⟨roption.inter⟩

lemma dom_inter : (o₁ ∩ o₂).dom ↔ ∃(x : α), x ∈ o₁ ∧ x ∈ o₂ := iff.refl _
lemma get_inter (h : ∃(x : α), x ∈ o₁ ∧ x ∈ o₂) :
  ∃(h' : o₁.dom), (o₁ ∩ o₂).get h = o₁.get h' := ⟨_, rfl⟩

@[simp] lemma mem_inter : x ∈ o₁ ∩ o₂ ↔ x ∈ o₁ ∧ x ∈ o₂ :=
begin
  split,
  { intro h, rw [mem_eq] at h, rcases h with ⟨⟨x, h1x, h2x⟩, rfl⟩,
    cases get_inter ⟨x, h1x, h2x⟩ with _h h2, rw [h2],
    split, { apply get_mem },
    rw [mem_eq] at h1x, rw [mem_eq] at h2x, cases h1x with _h2 h1x,
    cases h2x with _h3 h2x, rw [h1x, ← h2x], apply get_mem },
  { rintro ⟨h1, h2⟩, use ⟨x, h1, h2⟩,
    cases get_inter ⟨x, h1, h2⟩ with _h h3, rw [h3],
    rw [mem_eq] at h1, cases h1 with _h2 h1, exact h1 }
end

end roption

namespace pfun

variables {ι : Sort*} {α : Type*} {β : Type*} {f f₁ f₂ : α →. β}

lemma mem_dom_iff_dom (f : α →. β) (x : α) : x ∈ dom f ↔ (f x).dom :=
by simp [dom, set.mem_def]

lemma mem_dom_of_mem {f : α →. β} {x : α} {y : β} (h : y ∈ f x) : x ∈ dom f :=
(mem_dom f x).2 ⟨y, h⟩

lemma some_fn {f : α →. β} {x : α} (h : x ∈ f.dom) : roption.some (f.fn x h) = f x :=
roption.some_get h

lemma fn_mem {f : α →. β} {x : α} (h : x ∈ f.dom) : f.fn x h ∈ f x :=
roption.get_mem h

lemma mem_iff_fn_eq {x : α} {y : β} : y ∈ f x ↔ ∃ h : x ∈ f.dom, f.fn x h = y :=
by refl

lemma fn_eq_iff_mem {x : α} {y : β} (h : x ∈ f.dom) : f.fn x h = y ↔ y ∈ f x :=
by simp [mem_iff_fn_eq, h]

lemma fn_eq_of_mem {x : α} {y : β} (h1 : y ∈ f x) (h2 : x ∈ f.dom) : f.fn x h2 = y :=
(fn_eq_iff_mem h2).2 h1

/- more on lift -/

lemma mem_lift {f : α → β} {x : α} {y : β} : y ∈ (f : α →. β) x ↔ f x = y :=
by simp [eq_comm]

lemma lift_eq_some_iff {f : α → β} {x : α} {y : β} : (f : α →. β) x = roption.some y ↔ f x = y :=
by simp

@[simp] lemma fn_lift (f : α → β) (x : α) : (f : α →. β).fn x trivial = f x :=
by simp [fn_eq_iff_mem]

/-- The empty partial function -/
def empty : α →. β := λ x, roption.none

@[simp] lemma dom_empty : (empty : α →. β).dom = ∅ := rfl
@[simp] lemma empty_def (x : α) : (empty : α →. β) x = none := rfl
lemma not_mem_empty (x : α) (y : β) : y ∉ (pfun.empty : α →. β) x := roption.not_mem_none _

/- Two partial functions are equal if their graphs are equal -/
lemma ext_graph {α β : Type*} (f g : α →. β) (h_graph : f.graph = g.graph) : f = g :=
  pfun.ext $ λ _ _, iff_of_eq $ congr_fun h_graph (_,_)

lemma graph_empty_iff_dom_empty {α β : Type*} (f : α →. β) : f.graph = ∅ ↔ f.dom = ∅ :=
begin
  have := dom_iff_graph f,
  split; intro; ext; safe, exact this _ _ ‹_›
end

/-- A functional graph is a univalent graph -/
def functional {α β : Type*} (Γ : set (α × β)) : Prop :=
  ∀ a b₁ b₂, (a, b₁) ∈ Γ → (a, b₂) ∈ Γ → b₁ = b₂

lemma congr_arg {α β : Type*} (f : α →. β) : ∀ {x} {y} (h₁ : x ∈ f.dom) (h₂ : y ∈ f.dom)
  (h_eq : x = y), fn f x h₁ = fn f y h₂ :=
by intros; congr; assumption

lemma functional_subset {α β : Type*} (Γ Γ': set (α × β)) (h_Γ' : Γ' ⊆ Γ) (h_Γ : functional Γ) : functional Γ' :=
  λ _ _ _ _ _, by apply h_Γ; tidy

/-- The graph of a pfun is always functional -/
lemma graph_functional {α β : Type*} (f : α →. β) : functional f.graph := by tidy

/-- Given a partial functional relation, turn it into a pfun -/
noncomputable def of_graph {α β : Type*} (Γ : set (α × β)) (h_Γ : functional Γ) : α →. β :=
  λ a, ⟨∃ c ∈ Γ, (prod.fst c) = a, λ h, @prod.snd α β $ (classical.indefinite_description _ h).val⟩

lemma of_graph_property {α β : Type*} (Γ : set $ α × β) (h_Γ : functional Γ) (a : α) (h : ∃ c ∈ Γ, (prod.fst c) = a) : ∃ (H : Γ (classical.indefinite_description _ h)), (classical.indefinite_description _ h).val.fst = a :=
  by apply (classical.indefinite_description _ h).property

lemma of_graph_get {α β : Type*} (Γ : set $ α × β) (h_Γ : functional Γ) (a : α) : ∀ h,
(of_graph Γ h_Γ a).get h = (classical.indefinite_description _ h).val.snd :=
  by intro; refl

lemma of_graph_val {α β : Type*} (Γ : set $ α × β) (h_Γ : functional Γ) (a : α) (h : ∃ c ∈ Γ, (prod.fst c) = a) (c' ∈ Γ) (h' : c'.1 = a) :
  @prod.snd α β (classical.indefinite_description _ h).val = c'.snd :=
begin
  let c'', swap, change (prod.snd c'' = c'.snd),
  apply h_Γ a, swap, convert H, ext, rwa[h'], refl,
  have := (classical.indefinite_description _ h).property,
  cases this with this1 this2, rw [<-this2], convert this1, ext; refl
end

@[simp] lemma graph_of_graph {α β : Type*} (Γ : set $ α × β) (h_Γ : functional Γ) : (of_graph Γ h_Γ).graph = Γ :=
begin
  ext, rcases x with ⟨a,b⟩, dsimp[graph],
  split; intro H, {cases H, induction H_h, cases H_w, cases H_w_h, induction H_w_h_h,
  convert H_w_h_w, ext, refl, rw [of_graph_get], apply of_graph_val; try{assumption}; refl},
  fsplit, {tidy}, rw [of_graph_get], apply @of_graph_val _ _ Γ _ a _ (a,b) _;
  try{assumption}; refl
end

@[simp] lemma of_graph_graph {α β : Type*} {f : α →. β} : of_graph (f.graph) (graph_functional f) = f :=
  by apply ext_graph; rw [graph_of_graph]

@[simp] lemma dom_of_graph {α β : Type*} (Γ : set $ α × β) (h_Γ : functional Γ) : (of_graph Γ h_Γ).dom = (prod.fst '' Γ) :=
begin
 ext, split; intros, {tidy},
 {cases a, cases a_h, cases a_w, induction a_h_right, dsimp at *, fsplit,
 work_on_goal 0 { fsplit }, work_on_goal 2 {fsplit,
 work_on_goal 0 { assumption }, refl }}
end

@[simp] lemma dom_of_graph_union {α β : Type*} (Γ : set $ α × β) (p : α × β) (h_Γ : functional Γ) (h_Γ' : functional $ Γ ∪ {p}) : (of_graph (Γ ∪ {p}) h_Γ').dom = (of_graph Γ h_Γ).dom ∪ {p.fst} :=
  by simp[dom_of_graph, set.image_insert_eq]

lemma in_dom_of_in_graph {α β : Type*} {f : α →. β} : ∀ {a} {b}, (a,b) ∈ f.graph → a ∈ f.dom :=
  by {intros a b H, apply (pfun.dom_iff_graph _ a).mpr, exact ⟨b,H⟩}

lemma lift_graph' {α β : Type*} {f : α →. β} {a : α} {b : β} (h_a : a ∈ f.dom) : (a,b) ∈ f.graph ↔ pfun.fn f a h_a = b := by tidy

/-- The intersection of two partial functions -/
def inter (f₁ f₂ : α →. β) : α →. β :=
λ x, f₁ x ∩ f₂ x

instance : has_inter (α →. β) := ⟨pfun.inter⟩

@[simp] lemma mem_inter {x : α} {y : β} : y ∈ (f₁ ∩ f₂) x ↔ y ∈ f₁ x ∧ y ∈ f₂ x :=
roption.mem_inter

/-- f₁ is a subset, or subfunction of f₂: if `f₁ x = some y` then `f₂ x = some y` -/
def subfun (f₁ f₂ : α →. β) : Prop := ∀ x y, y ∈ f₁ x → y ∈ f₂ x

instance : partial_order (α →. β) :=
{ le := subfun,
  le_refl := λ f x y hy, hy,
  le_trans := λ f g h hfg hgh x y hy, hgh x y (hfg x y hy),
  le_antisymm := λ f g h1 h2, pfun.ext $ λ x y, ⟨h1 x y, h2 x y⟩ }

instance : semilattice_inf_bot (α →. β) :=
{ le := subfun,
  le_refl := λ f x y hy, hy,
  le_trans := λ f g h hfg hgh x y hy, hgh x y (hfg x y hy),
  le_antisymm := λ f g h1 h2, pfun.ext $ λ x y, ⟨h1 x y, h2 x y⟩,
  bot := pfun.empty,
  bot_le := λ f x y hy, false.elim $ roption.not_mem_none y hy,
  inf := pfun.inter,
  inf_le_left := λ f g x y hy, (mem_inter.1 hy).1,
  inf_le_right := λ f g x y hy, (mem_inter.1 hy).2,
  le_inf := λ f g h hfg hfh x y hf, mem_inter.2 ⟨hfg x y hf, hfh x y hf⟩ }

lemma le_def : f₁ ≤ f₂ ↔ ∀ x y, y ∈ f₁ x → y ∈ f₂ x := by refl

lemma dom_subset_dom_of_le (h : f₁ ≤ f₂) : f₁.dom ⊆ f₂.dom :=
λ x hx, mem_dom_of_mem (h x (f₁.fn x hx) (fn_mem hx))

lemma eq_some_of_subfun (h : f₁ ≤ f₂) {x : α} {y : β} (h1 : f₁ x = roption.some y) :
  f₂ x = roption.some y :=
by { rw [roption.eq_some_iff] at h1 ⊢, exact h x y h1 }

lemma fn_eq_of_subfun (h : f₁ ≤ f₂) {x : α} {y : β} (h1 : x ∈ f₁.dom)
  (h2 : f₁.fn x h1 = y) (h3 : x ∈ f₂.dom) : f₂.fn x h3 = y :=
by { apply fn_eq_of_mem, apply h, rw [mem_iff_fn_eq], exact ⟨h1, h2⟩ }

lemma le_lift {f : α →. β} {g : α → β} : f ≤ (g : α →. β) ↔ ∀ x y, y ∈ f x → g x = y :=
by simp [le_def, eq_comm]

/-- Two functions are compatible if they agree on the intersection of their domains. -/
def compatible (f₁ f₂ : α →. β) : Prop :=
∀(x : α), x ∈ f₁.dom → x ∈ f₂.dom → f₁ x = f₂ x

lemma compatible_def : compatible f₁ f₂ ↔ ∀(x : α), x ∈ f₁.dom → x ∈ f₂.dom → f₁ x = f₂ x :=
by refl

lemma mem_of_compatible (h : compatible f₁ f₂) {x : α} {y : β} (h1 : y ∈ f₁ x) (h2 : x ∈ f₂.dom) :
  y ∈ f₂ x :=
by { convert h1, symmetry, exact h x (mem_dom_of_mem h1) h2 }

@[refl] lemma compatible_refl : compatible f f := λ x h1x h2x, rfl

lemma compatible_comm : compatible f₁ f₂ ↔ compatible f₂ f₁ :=
by { simp [compatible_def, eq_comm, imp.swap] }

lemma compatible_of_le (h : f₁ ≤ f₂) : compatible f₁ f₂ :=
begin
  intros x h1x h2x, apply roption.ext, intro y, split; intro hy, exact h x y hy,
  have := h x (f₁.fn x h1x) (fn_mem h1x),
  convert fn_mem h1x,
  rw [← roption.some_inj, ← roption.eq_some_iff.2 hy, ← roption.eq_some_iff.2 this]
end

/-- The sup of two functions f₁ and f₂. Corresponds to the set-theoretic union of f₁ and f₂ as
  long as f₁ and f₂ are compatible. If they are not compatible, the values of f₁ are chosen when
  both functions are defined. We use classical logic, so that we can define a has_sup instance
  (otherwise we would need to assume that `f₁.dom` is decidable). -/
def sup (f₁ f₂ : α →. β) : α →. β :=
λ a, if a ∈ f₁.dom then f₁ a else f₂ a

instance : has_sup (α →. β) := ⟨pfun.sup⟩

@[simp] lemma sup_eq_of_mem {x : α} (h : x ∈ f₁.dom) : (f₁ ⊔ f₂) x = f₁ x :=
by { dsimp [pfun.lattice.has_sup, pfun.sup], simp [h] }

@[simp] lemma sup_eq_of_nmem {x : α} (h : x ∉ f₁.dom) : (f₁ ⊔ f₂) x = f₂ x :=
by { dsimp [pfun.lattice.has_sup, pfun.sup], simp [h] }

@[simp] lemma dom_sup (f₁ f₂ : α →. β) : (f₁ ⊔ f₂).dom = f₁.dom ∪ f₂.dom :=
by { ext x, by_cases hx : x ∈ f₁.dom; simp [mem_dom_iff_dom] at hx; simp [mem_dom_iff_dom, hx] }

lemma subset_dom_sup_left (f₁ f₂ : α →. β) : f₁.dom ⊆ (f₁ ⊔ f₂).dom := by simp
lemma subset_dom_sup_right (f₁ f₂ : α →. β) : f₂.dom ⊆ (f₁ ⊔ f₂).dom := by simp

lemma mem_sup {x : α} {y : β} : y ∈ (f₁ ⊔ f₂) x ↔ y ∈ f₁ x ∨ (y ∈ f₂ x ∧ x ∉ f₁.dom) :=
begin
  by_cases hx : x ∈ f₁.dom, { simp [hx] },
  have := hx, rw [mem_dom] at this, push_neg at this, simp [hx, this]
end

lemma mem_sup_of_compatible {x : α} {y : β} (h : compatible f₁ f₂) :
  y ∈ (f₁ ⊔ f₂) x ↔ y ∈ f₁ x ∨ y ∈ f₂ x :=
begin
  rw [mem_sup, or_and_iff_or, or_not_iff],
  intros hy hx, convert hy, exact h x hx (mem_dom_of_mem hy),
end

lemma sup_restrict_left {f₁ f₂ : α →. β} :
  (f₁ ⊔ f₂).restrict (subset_dom_sup_left f₁ f₂) = f₁ :=
begin
  apply pfun.ext, intros x y, simp [mem_sup, and_or_and_not],
  show y ∈ f₁ x → x ∈ dom f₁, rw [mem_dom], intro hy, exact ⟨y, hy⟩
end

lemma sup_restrict_right {f₁ f₂ : α →. β} (h : compatible f₁ f₂) :
  (f₁ ⊔ f₂).restrict (subset_dom_sup_right f₁ f₂) = f₂ :=
begin
  apply pfun.ext, intros x y, simp [mem_sup_of_compatible h],
  rw [and_or_iff_and.2, and_iff_self_left], apply mem_dom_of_mem,
  intros hx hy, convert hy, symmetry, exact h x (mem_dom_of_mem hy) hx
end

lemma le_sup_left (f₁ f₂ : α →. β) : f₁ ≤ f₁ ⊔ f₂ :=
by { intros x y hy, rw [mem_sup], exact or.inl hy }

lemma le_sup_right (h : compatible f₁ f₂) : f₂ ≤ f₁ ⊔ f₂ :=
by { intros x y hy, rw [mem_sup_of_compatible h], exact or.inr hy }

/-- The indexed sup of a family of partial functions. This corresponds to the set-theoretic union
  if the functions are pairwise compatible. Otherwise, the value of a function will be chosen using
  classical.some. -/
def Sup (f : ι → α →. β) : α →. β :=
λ x, if h : ∃ i, x ∈ dom (f i) then f (classical.some h) x else roption.none

-- TODO: define Sup instance

lemma Sup_helper {f : ι → α →. β} {x : α} :
  (∃i, x ∈ (f i).dom) ↔ (∃i, x ∈ (f i).dom ∧ Sup f x = f i x) :=
⟨λ h, ⟨classical.some h, classical.some_spec h, dif_pos h⟩, λ⟨i, h, _⟩, ⟨i, h⟩⟩

lemma Sup_helper2 {f : ι → α →. β} {x : α} :
  (∃i, x ∈ (f i).dom) ↔ (∃i (h : x ∈ (f i).dom), Sup f x = roption.some ((f i).fn x h)) :=
begin
  rw [Sup_helper], apply exists_congr, intro i,
  rw [← exists_prop], apply exists_congr, intro hi,
  apply eq_iff_eq_of_eq_right, rw [some_fn hi]
end

@[simp] lemma dom_Sup (f : ι → α →. β) : (Sup f).dom = set.Union (λ (i : ι), (f i).dom) :=
begin
  ext x, rw [set.mem_Union], by_cases hx : ∃i, x ∈ (f i).dom,
  { simp only [hx, iff_true], rw [Sup_helper2] at hx, rcases hx with ⟨i, hx, h⟩,
    rw [mem_dom_iff_dom, h], trivial },
  { simp only [hx, iff_false], rw [mem_dom_iff_dom], dsimp [Sup], rw [dif_neg hx], exact id }
end

lemma subset_dom_Sup (f : ι → α →. β) (i : ι) : (f i).dom ⊆ (Sup f).dom :=
by { rw [dom_Sup], apply set.subset_Union (λ i, (f i).dom) }

lemma Sup_eq_of_mem {f : ι → α →. β} {x : α} {i : ι} (hf : ∀i j, compatible (f i) (f j))
  (h : x ∈ (f i).dom) : Sup f x = f i x :=
begin
  have : ∃ i, x ∈ (f i).dom := ⟨i, h⟩, rw [Sup_helper] at this, rcases this with ⟨j, hj, h2j⟩,
  rw [h2j], exact hf j i x hj h
end

lemma Sup_eq_of_nmem {f : ι → α →. β} {x : α} (h : ∀ i, x ∉ (f i).dom) :
  Sup f x = roption.none :=
by { dsimp [pfun.Sup], simp [h] }

lemma mem_Sup {f : ι → α →. β} {x : α} {y : β} (hf : ∀i j, compatible (f i) (f j)) :
  y ∈ Sup f x ↔ ∃ i, y ∈ f i x :=
begin
  split,
  { intro hy, have := mem_dom_of_mem hy, rw [dom_Sup, set.mem_Union] at this,
    cases this with i hi, use i, rwa [Sup_eq_of_mem hf hi] at hy },
  { rintro ⟨i, hi⟩, rwa [Sup_eq_of_mem hf (mem_dom_of_mem hi)] }
end

lemma Sup_restrict {f : ι → α →. β} (hf : ∀i j, compatible (f i) (f j)) (i : ι) :
  (Sup f).restrict (subset_dom_Sup f i) = f i :=
begin
  apply pfun.ext, intros x y, simp [mem_Sup hf],
  split,
  { rintro ⟨hx, j, hj⟩, exact mem_of_compatible (hf j i) hj hx },
  { intro hy, exact ⟨mem_dom_of_mem hy, i, hy⟩ }
end

lemma le_Sup {f : ι → α →. β} (hf : ∀i j, compatible (f i) (f j)) (i : ι) : f i ≤ Sup f :=
by { intros x y hy, rw [mem_Sup hf], exact ⟨i, hy⟩ }

lemma Sup_le {f : ι → α →. β} (hf : ∀i j, compatible (f i) (f j))
  {g : α →. β} : Sup f ≤ g ↔ ∀i, f i ≤ g :=
begin
  simp only [le_def, mem_Sup hf, exists_imp_distrib],
  conv_rhs { rw [forall_swap] }, apply forall_congr, intro x, rw [forall_swap]
end

lemma fn_mem_ran {X Y} {f : X →. Y} {x : X} {Hx : x ∈ f.dom} :
  (fn f x Hx) ∈ f.ran :=
by use x; tidy

lemma mk_ran_le_mk_dom {α β : Type u} (f : α →. β) : # f.ran ≤ # f.dom :=
begin
  refine mk_le_of_surjective _,
  { exact λ ⟨x,H⟩, ⟨fn f x H, by apply fn_mem_ran⟩},
  { intros y, by_contra, push_neg at a,
  /- `tidy` says -/ cases y, cases y_property, cases y_property_h,
    induction y_property_h_h, simp at *, dsimp at *,
    specialize a ‹_› ‹_›, finish }
end

/-- A partial function with one element in its domain.
  Note, this is a component of `pequiv.single` in a newer version of mathlib
  -/
def singleton (x : α) (y : β) : α →. β :=
λ a, { dom := a = x, get := λ _, y }

@[simp] lemma fn_singleton {x x' : α} {y : β} (H_a : x' = x) :
  fn (singleton x y) x' H_a = y := by refl

@[simp] lemma mem_singleton {x x' : α} {y y' : β} :
  y' ∈ singleton x y x' ↔ x = x' ∧ y = y' :=
begin
  split,
  { intro h, rw [roption.mem_eq] at h, rcases h with ⟨h, rfl⟩, exact ⟨h.symm, rfl⟩ },
  { rintro ⟨rfl, rfl⟩, exact ⟨rfl, rfl⟩ }
end

@[simp] lemma singleton_eq_some {x : α} {y : β} : singleton x y x = roption.some y :=
by simp [roption.eq_some_iff]

@[simp] lemma dom_singleton {x : α} {y : β} : (singleton x y).dom = {x} :=
by { ext x', simp [singleton, mem_dom_iff_dom] }

lemma mk_dom_singleton {x : α} {y : β} : # (singleton x y).dom = 1 := by simp

/-- Extend `f` using `g` for all values where `f` is undefined -/
noncomputable def extend_via (f : α →. β) (g : α → β) : α → β :=
λ x, if hx : x ∈ f.dom then f.fn x hx else g x

lemma extend_via_pos {f : α →. β} {g : α → β} {x : α} (h : x ∈ f.dom) :
  extend_via f g x = f.fn x h :=
by simp [h, extend_via]

lemma extend_via_neg {f : α →. β} {g : α → β} {x : α} (h : x ∉ f.dom) :
  extend_via f g x = g x :=
by simp [h, extend_via]

lemma le_extend_via (f : α →. β) (g : α → β) : f ≤ ↑(extend_via f g) :=
λ x y hy, by { simp [mem_dom_of_mem hy, extend_via], symmetry, rwa [fn_eq_iff_mem] }

/--
Given a partial function f : X →. Y and a point y : Y, define an extension g of f to X such that g(x) = y whenever x ∉ f.dom
-/
noncomputable def trivial_extension (f : α →. β) (y : β) : α → β :=
extend_via f (λ _, y)

lemma trivial_extension_pos {f : α →. β} {y : β} {x : α} (h : x ∈ f.dom) :
  trivial_extension f y x = f.fn x h :=
extend_via_pos h

lemma trivial_extension_neg {f : α →. β} {y : β} {x : α} (h : x ∉ f.dom) :
  trivial_extension f y x = y :=
extend_via_neg h

lemma le_trivial_extension (f : α →. β) (y : β) : f ≤ ↑(trivial_extension f y) :=
le_extend_via _ _

end pfun

section collapse_poset

structure collapse_poset (X Y : Type u) (κ : cardinal.{u}) : Type u :=
(f        : X →. Y)
(Hc       : #f.dom < κ)

def collapse_poset.empty {α β : Type u} {κ : cardinal} (h : 0 < κ) : collapse_poset α β κ :=
{ f := pfun.empty,
  Hc := by simp [h] }

open pfun

variables {X Y : Type u} {κ : cardinal.{u}}

lemma collapse_poset.mk_ran_lt (p : collapse_poset X Y κ) : # p.f.ran < κ :=
lt_of_le_of_lt (mk_ran_le_mk_dom p.f) p.Hc

def collapse_poset.inter (p₁ p₂ : collapse_poset X Y κ) : collapse_poset X Y κ :=
{ f := p₁.f ⊓ p₂.f,
  Hc := lt_of_le_of_lt (mk_le_mk_of_subset $ dom_subset_dom_of_le inf_le_left) p₁.Hc }

noncomputable def collapse_poset.union (p₁ p₂ : collapse_poset X Y κ) (h : omega ≤ κ) :
  collapse_poset X Y κ :=
{ f := p₁.f ⊔ p₂.f,
  Hc := by { rw [dom_sup],
             exact lt_of_le_of_lt cardinal.mk_union_le (cardinal.add_lt_of_lt h p₁.Hc p₂.Hc) } }

lemma exists_mem_compl_dom_of_unctbl (p : collapse_poset X Y κ) (H_card : κ ≤ #X) :
  ∃ x : X, x ∉ p.f.dom :=
exists_mem_compl_of_mk_lt_mk _ $ lt_of_lt_of_le p.Hc H_card

lemma exists_mem_compl_ran_of_unctbl (p : collapse_poset X Y κ) (H_card : κ ≤ #Y) :
  ∃ y : Y, y ∉ p.f.ran :=
exists_mem_compl_of_mk_lt_mk _ $ lt_of_lt_of_le (collapse_poset.mk_ran_lt p) H_card

def collapse_poset.principal_open (p : collapse_poset X Y κ) : set (X → Y) :=
{f | p.f ≤ (f : X →. Y)}

@[simp] lemma collapse_poset.principal_open_empty (h : 0 < κ) :
  collapse_poset.principal_open (collapse_poset.empty h : collapse_poset X Y κ) = set.univ :=
begin
  ext f, split; intro H,
  { trivial },
  { tidy }
end

lemma mem_principal_open_iff {p : collapse_poset X Y κ} {f : X → Y} :
  f ∈ collapse_poset.principal_open p ↔ ∀ x y, y ∈ p.f x → f x = y :=
le_lift

lemma mem_principal_open_iff' {p : collapse_poset X Y κ} {f : X → Y} :
  f ∈ collapse_poset.principal_open p ↔ ∀ (x : X) (H_x : x ∈ p.f.dom), f x = fn p.f x H_x :=
begin
  rw [mem_principal_open_iff], apply forall_congr, intro x,
  split,
  { intros H Hx, apply H, apply fn_mem },
  { intros H y hy, rw [H $ mem_dom_of_mem hy], apply fn_eq_of_mem hy }
end

lemma mem_compl_principal_open_iff {p : collapse_poset X Y κ} {f : X → Y} :
  f ∈ - collapse_poset.principal_open p ↔ ∃x (H_x : x ∈ p.f.dom), f x ≠ fn p.f x H_x :=
by { rw [set.mem_compl_iff, mem_principal_open_iff'], push_neg }

@[simp] lemma mem_ran_of_mem_dom {p : collapse_poset X Y κ} {f : X → Y} {x : X}
  (H : f ∈ collapse_poset.principal_open p) : x ∈ p.f.dom → f x ∈ p.f.ran :=
by { intro H_mem, rw [mem_principal_open_iff] at H,
     use x, rw [H x (p.f.fn x H_mem) (fn_mem _)], exact roption.get_mem H_mem }

def collapse_poset.Sup {ι : Type u} (p : ι → collapse_poset X Y κ) (h : #ι < (ord κ).cof)
  (hκ : cardinal.omega ≤ κ) : collapse_poset X Y κ :=
⟨Sup $ λ i, (p i).f,
  begin
    rw [dom_Sup], apply lt_of_le_of_lt (mk_Union_le _) _,
    apply mul_lt_of_lt hκ (lt_of_lt_of_le h (ordinal.cof_ord_le κ)),
    exact ordinal.sup_lt _ h (λ i, collapse_poset.Hc _)
  end⟩

def collapse_poset.Sup_lift {ι : Type u} {X Y : Type (max u v)} {κ : cardinal.{max u v}}
  (p : ι → collapse_poset X Y κ)
  (h : cardinal.lift.{_ v} #ι < (ord κ).cof)
  (hκ : cardinal.omega ≤ κ) : collapse_poset X Y κ :=
⟨Sup $ λ i, (p i).f,
  begin
    rw [dom_Sup], apply lt_of_le_of_lt (mk_Union_le_lift.{u v} _) _,
    apply mul_lt_of_lt hκ (lt_of_lt_of_le h (ordinal.cof_ord_le κ)),
    refine ordinal.sup_lt_lift _ h (λ i, collapse_poset.Hc _)
  end⟩

def collapse_space : topological_space (X → Y) :=
generate_from $
  (collapse_poset.principal_open : collapse_poset X Y cardinal.omega.succ → set (X → Y)) '' set.univ

local attribute [instance, priority 9001, reducible] collapse_space

@[simp] lemma collapse_poset.principal_open_is_open {p : collapse_poset X Y cardinal.omega.succ} :
  is_open (collapse_poset.principal_open p) :=
generate_open.basic _ $ set.mem_image_of_mem _ trivial

lemma one_lt_omega_succ : 1 < cardinal.omega.succ :=
lt_trans one_lt_omega (cardinal.lt_succ_self _)

lemma zero_lt_omega_succ : 0 < cardinal.omega.succ :=
lt_trans cardinal.zero_lt_one one_lt_omega_succ

open collapse_poset

def singleton_collapse_poset (x : X) (y : Y) (hκ : 1 < κ) : collapse_poset X Y κ :=
{ f := singleton x y,
  Hc := by simp [hκ] }

@[simp] lemma singleton_collapse_poset_principal_open {x : X} {y : Y} {hκ : 1 < κ} :
  principal_open (singleton_collapse_poset x y hκ) = {g : X → Y | g x = y} :=
begin
  ext f, refine ⟨_,_⟩; intro H,
    { rw mem_principal_open_iff at H,
      apply H, finish[singleton_collapse_poset] },
    { tidy }
end

lemma collapse_poset.compl_principal_open_is_Union (hκ : 1 < κ) (p : collapse_poset X Y κ) :
  ∃ {ι : Type u} (s : ι → collapse_poset X Y κ),
    set.Union (λ i : ι, principal_open $ s i) = - principal_open p :=
begin
  use {pr : X × Y // ∃ H_mem : pr.1 ∈ p.f.dom, pr.2 ≠ fn p.f pr.1 H_mem },
  use (λ s, singleton_collapse_poset s.1.1 s.1.2 hκ),
  ext f, split; intro H,
    { intro H_mem,
      rcases H with ⟨P, ⟨⟨⟨x',y'⟩, ⟨H_mem₁, H_neq⟩⟩, rfl⟩, H_mem₂⟩,
      dsimp at H_neq H_mem₂,
      apply H_neq,
      rw [← show f x' = y', by simpa using H_mem₂],
      rw mem_principal_open_iff'.mp H_mem _ _ },
    { rw [mem_compl_principal_open_iff] at H, rcases H with ⟨x, Hx, H_neq⟩,
      suffices this : ∃ (a : X) (H_mem : (a, f a).fst ∈ dom (p.f)), ¬f a = fn (p.f) a H_mem,
      { simp [this] },
      exact ⟨_, by use ‹_›⟩ }
end

@[simp] lemma collapse_poset.principal_open_is_closed {p : collapse_poset X Y cardinal.omega.succ} :
  is_closed (collapse_poset.principal_open p) :=
by { rcases collapse_poset.compl_principal_open_is_Union one_lt_omega_succ p with ⟨ι, ⟨s, Hu⟩⟩,
     rw [is_closed, ← Hu], simp [is_open_Union] }

@[simp] lemma collapse_poset.is_regular_principal_open
  (p : collapse_poset X Y cardinal.omega.succ) : is_regular (collapse_poset.principal_open p) :=
by simp [is_clopen]

lemma inter_principal_open (hκ : omega ≤ κ) {p₁ p₂ : collapse_poset X Y κ}
  (H : compatible p₁.f p₂.f) :
  principal_open p₁ ∩ principal_open p₂ = principal_open (p₁.union p₂ hκ) :=
begin
  ext f,
  simp [mem_principal_open_iff],
  rw [← forall_and_distrib], apply forall_congr, intro x,
  rw [← forall_and_distrib], apply forall_congr, intro y,
  rw [union, mem_sup_of_compatible H, or_imp_distrib]
end

variables (X Y)
def collapse_space_basis : set $ set (X → Y) :=
insert (∅ : set (X → Y))
  (collapse_poset.principal_open '' (set.univ : set (collapse_poset X Y cardinal.omega.succ)))

variables {X Y}
def collapse_space_basis_spec : is_topological_basis (collapse_space_basis X Y) :=
begin
  refine ⟨λ P HP P' HP' f H_mem_inter, _,_,_⟩,
    { rw [collapse_space_basis] at HP HP',
      cases HP; cases HP',

      { suffices this : f ∈ (∅ : set $ X → Y),
          by {cases this}, substs HP, cases H_mem_inter, exact ‹_› },
      { suffices this : f ∈ (∅ : set $ X → Y),
          by {cases this}, substs HP, cases H_mem_inter, exact ‹_› },
      { suffices this : f ∈ (∅ : set $ X → Y),
          by {cases this}, substs HP', cases H_mem_inter, exact ‹_› },

      simp only [set.image_univ, set.mem_range] at HP HP',
      cases HP with y Hy; cases HP' with y' Hy',

      substs Hy Hy', use (principal_open y ∩ principal_open y'),
      refine ⟨_,⟨‹_›,(by refl)⟩⟩,
      { by_cases H_compat : compatible y.f y'.f,
        { right, refine ⟨_,⟨trivial, _⟩⟩, exact y.union y' (le_of_lt (lt_succ_self _)),
        rwa [inter_principal_open] },
        { suffices this : principal_open y ∩ principal_open y' = ∅,
            by {rw [this], exact or.inl rfl },
          ext g; split; intro H,
            { exfalso, cases H with H₁ H₂, rw [mem_principal_open_iff] at H₁ H₂,
              rw [compatible] at H_compat,
              push_neg at H_compat, rcases H_compat with ⟨x, Hx₁, Hx₂, Hx₃⟩,
              apply Hx₃, rw [← some_fn Hx₁, ← some_fn Hx₂],
              rw [← H₁ x _ (fn_mem Hx₁), ← H₂ x _ (fn_mem Hx₂)] },
            { cases H }}}},

    { refine le_antisymm (λ _ _, trivial) _,
      intros f _a, refine ⟨_,_⟩,
      { exact (principal_open (collapse_poset.empty zero_lt_omega_succ)) },
      { refine ⟨by {rw [collapse_space_basis], right, exact set.mem_image_univ},_⟩, simp }},
    { unfold collapse_space_basis collapse_space, refine le_antisymm _ _,
      { intros T HT, induction HT,
        { cases HT_H, subst HT_H, exact is_open_empty, constructor, exact ‹_› },
        { exact is_open_univ },
        { apply generate_open.inter, exact ‹_›, exact ‹_› },
        { apply generate_open.sUnion, intros S HS, solve_by_elim }},
      { refine generate_from_mono _, exact λ _ _, or.inr ‹_› }}
end

@[simp] lemma is_regular_singleton_regular_open {x : X} {y : Y} :
  is_regular (principal_open (singleton_collapse_poset x y one_lt_omega_succ)) :=
collapse_poset.is_regular_principal_open _

@[simp] lemma is_regular_singleton_regular_open' {x : X} {y : Y} :
  is_regular {g : X → Y | g x = y} :=
by {rw [<-singleton_collapse_poset_principal_open], exact is_regular_singleton_regular_open}

lemma trivial_extension_mem_principal_open {p : collapse_poset X Y κ} {y : Y}
  : (trivial_extension p.f y) ∈ collapse_poset.principal_open p :=
by { rw [mem_principal_open_iff],
     intros x y hy, simp [trivial_extension_pos, mem_dom_of_mem hy, fn_eq_of_mem hy] }

end collapse_poset

section omega_closed_dense_subset

variables {α : Type*} [nontrivial_complete_boolean_algebra α]

-- any ω-indexed downward chain in D has an intersection in D
def omega_closed (D : set α) : Prop :=
∀ (s : ℕ → α) (s_sub_D : ∀n, s n ∈ D) (H_nonzero : ∀ n, ⊥ < s n) (H_chain : ∀ n, s (n+1) ≤ s n), (⨅n, s n) ∈ D

def dense_subset {α : Type*} [order_bot α] (D : set α) : Prop :=
⊥ ∉ D ∧ ∀x, ⊥ < x → ∃ y ∈ D, y ≤ x

@[reducible]def dense_omega_closed_subset (D : set α) : Prop :=
dense_subset D ∧ omega_closed D

variable (α)
def has_dense_omega_closed_subset : Prop :=
∃ D : set α, dense_omega_closed_subset D

variable {α}

lemma nonzero_of_mem_dense_omega_closed_subset {x : α} {D : set α} (H : dense_omega_closed_subset D) (H_mem : x ∈ D) : ⊥ < x :=
by {have := H.left.left, by_contra H', finish [le_bot_iff_not_bot_lt]}

lemma nonzero_infi_of_mem_dense_omega_closed_subset {s : ℕ → α} {D : set α} (H : dense_omega_closed_subset D) (H_chain : ∀ n, s (n + 1) ≤ s n) (H_mem : ∀ n, s n ∈ D) : ⊥ < ⨅ n, s n :=
begin
  apply nonzero_of_mem_dense_omega_closed_subset H, refine H.right s ‹_› _ ‹_›,
  intro n, specialize H_mem n, from nonzero_of_mem_dense_omega_closed_subset H ‹_›
end

end omega_closed_dense_subset

local attribute [instance, priority 9000] collapse_space

section collapse_algebra
variables X Y : Type u

def collapse_algebra : Type* := @regular_opens (X → Y) collapse_space

variables {X Y}

@[instance, priority 9001] def collapse_algebra_boolean_algebra [nonempty (X → Y)] : nontrivial_complete_boolean_algebra (collapse_algebra X Y) :=
regular_open_algebra

end collapse_algebra

section collapse_poset_dense
variables {X Y : Type u}

def collapse_poset.inclusion (p : collapse_poset X Y cardinal.omega.succ) :
  collapse_algebra X Y :=
⟨collapse_poset.principal_open p, collapse_poset.is_regular_principal_open p⟩

local notation `ι`:65 := collapse_poset.inclusion

lemma collapse_poset_dense_basis : ∀ T ∈ collapse_space_basis X Y,
  ∀ h_nonempty : T ≠ ∅, ∃ p : collapse_poset X Y cardinal.omega.succ, (ι p).val ⊆ T :=
begin
  intros T H_mem_basis _,
  refine or.elim H_mem_basis (λ _, (false.elim (absurd ‹T = ∅› ‹_›))) (λ H, _),
  rcases H with ⟨_,⟨_,H₂⟩⟩, exact ⟨‹_›, by simp[H₂, collapse_poset.inclusion]⟩
end

lemma collapse_poset_dense [nonempty (X → Y)] {b : collapse_algebra X Y}
  (H : ⊥ < b) : ∃ p : collapse_poset X Y cardinal.omega.succ, ι p ≤ b :=
begin
  cases (classical.choice (classical.nonempty_of_not_empty _ H.right.symm)) with S_wit H_wit,
  change ∃ p, (ι p).val ⊆ b.val,
  have := mem_basis_subset_of_mem_open collapse_space_basis_spec H_wit (is_open_of_is_regular b.property),
  rcases (mem_basis_subset_of_mem_open
           collapse_space_basis_spec H_wit (is_open_of_is_regular b.property))
         with ⟨v, Hv₁, Hv₂, Hv₃⟩,
  have : v ≠ ∅, by {intro H, rw [H] at Hv₂, cases Hv₂},
  cases (collapse_poset_dense_basis ‹_› ‹_› ‹_›) with p H_p, exact ⟨p, set.subset.trans H_p ‹_›⟩
end

/- note: the hypothesis in this lemma almost always implies that q.f ≤ p.f, except when `Y` is a singleton -/
def compatible_of_inclusion_le_inclusion [nonempty $ X → Y]
  {p q : collapse_poset X Y cardinal.omega.succ} (h : ι p ≤ ι q) : p.f.compatible q.f :=
begin
  simp [collapse_poset.inclusion, le_iff_subset, collapse_poset.principal_open] at h,
  intros x px qx,
  have := h _ (pfun.le_trivial_extension p.f (p.f.fn x px)) x (q.f.fn x qx) (pfun.fn_mem _),
  simp [pfun.trivial_extension_pos px] at this,
  rw [← pfun.some_fn px, ← pfun.some_fn qx, this]
end

local postfix `ᵖ`:80 := perp

lemma principal_open_eq_infi_of_eq_inter [nonempty $ X → Y] {I : Type*} {s : I → collapse_algebra X Y}
  {s_infty : collapse_algebra X Y} (H_eq_inter: s_infty.val = ⋂n, (s n).val)
  : s_infty = ⨅ n, s n :=
begin
  rw subtype.ext, rw fst_infi',
  have s_infty_p_p : s_infty.val = s_infty.valᵖᵖ,
    by {rw is_regular_eq_p_p, exact s_infty.property},
  rw s_infty_p_p, simp*
end

lemma principal_opens_dense_omega_closed [nonempty $ X → Y] :
  dense_omega_closed_subset (set.range ι : set (collapse_algebra X Y)) :=
begin
  refine ⟨⟨_, _⟩, _⟩,
  { rintro ⟨p, hp⟩, have := congr_arg subtype.val hp,
    simp [collapse_poset.inclusion, collapse_poset.principal_open] at this,
    erw [set.eq_empty_iff_forall_not_mem] at this,
    have := _inst_1, cases this with g,
    exact this (p.f.extend_via g) (p.f.le_extend_via g) },
  { intros o ho,
    have h2o : o.1 ≠ ∅ := ho.2.symm,
    rcases nonempty_basis_subset collapse_space_basis_spec h2o (is_open_of_is_regular o.2)
      with ⟨u, hu, h2u, h3u⟩,
    rcases or.resolve_left hu h2u with ⟨u', hu', rfl⟩,
    refine ⟨ι u', set.mem_range_self u', h3u⟩ },
  { intros f hf h2f h3f, choose g hg using hf,
    simp only [(hg _).symm] at h3f h2f ⊢, clear hg f,
    let P : collapse_poset X Y _,
    { refine collapse_poset.Sup_lift g _ _,
      { simp [(succ_is_regular (by refl)).2],
        simp only [cardinal.omega, (lift_succ _).symm, lift_lt, lt_succ_self] },
      { apply le_of_lt (lt_succ_self _) } },
    refine ⟨P, _⟩,
    have : ∀ {{i j : ℕ}}, i ≤ j → ι (g j) ≤ ι (g i),
    { intros i j h, induction h, exact le_refl _, exact le_trans (h3f _) h_ih },
    have : ∀ (i j : ℕ), pfun.compatible ((g i).f) ((g j).f),
    { intros, cases le_total i j with h h, rw [pfun.compatible_comm],
      apply compatible_of_inclusion_le_inclusion (this h),
      apply compatible_of_inclusion_le_inclusion (this h) },
    simp [collapse_poset.inclusion, subtype.val_eq_coe],
    apply principal_open_eq_infi_of_eq_inter, ext f,
    refine ⟨_,_⟩; intro H,
      { rw set.mem_Inter, intro k,
        rw mem_principal_open_iff at H ⊢, intros x y Hy,
        apply H, dsimp[P, collapse_poset.Sup_lift],
        rw (pfun.mem_Sup ‹_›), use k, from ‹_›},
      { rw mem_principal_open_iff, dsimp[P, collapse_poset.Sup_lift],
        intros x y H_mem, rw set.mem_Inter at H, rw (pfun.mem_Sup ‹_›) at H_mem,
        simp only [mem_principal_open_iff] at H, finish }}
end

end collapse_poset_dense

local notation `𝔹` := collapse_algebra ((ℵ₁ : pSet).type) (powerset omega : pSet).type

instance nonempty_aleph_one_powerset_omega : nonempty $ ((ℵ₁).type) → (powerset omega).type :=
⟨λ _, by {unfold pSet.omega, exact λ _, false}⟩

def collapse_boolean_algebra : nontrivial_complete_boolean_algebra 𝔹 :=
by apply_instance


/-
Copyright (c) 2020 Johan Commelin. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Johan Commelin
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.algebraic_geometry.sheafed_space
import Mathlib.algebra.category.CommRing.limits
import Mathlib.algebra.category.CommRing.colimits
import Mathlib.algebraic_geometry.stalks
import Mathlib.ring_theory.ideal.basic
import Mathlib.PostPort

universes u_1 l u

namespace Mathlib

/-!
# The category of locally ringed spaces

We define (bundled) locally ringed spaces
(as `SheafedSpace CommRing` along with the fact that the stalks are local rings),
and morphisms between these (morphisms in `SheafedSpace` with `is_local_ring_hom` on the stalk maps).

## Future work
* Define the restriction along an open embedding
-/

namespace algebraic_geometry

/-- A `LocallyRingedSpace` is a topological space equipped with a sheaf of commutative rings
such that all the stalks are local rings.

A morphism of locally ringed spaces is a morphism of ringed spaces
such that the morphims induced on stalks are local ring homomorphisms. -/
structure LocallyRingedSpace extends SheafedSpace CommRing where
  local_ring :
    ∀ (x : ↥(PresheafedSpace.carrier (SheafedSpace.to_PresheafedSpace _to_SheafedSpace))),
      local_ring
        ↥(Top.presheaf.stalk
            (PresheafedSpace.presheaf (SheafedSpace.to_PresheafedSpace _to_SheafedSpace)) x)

namespace LocallyRingedSpace

/-- The underlying topological space of a locally ringed space. -/
def to_Top (X : LocallyRingedSpace) : Top :=
  PresheafedSpace.carrier (SheafedSpace.to_PresheafedSpace (to_SheafedSpace X))

protected instance has_coe_to_sort : has_coe_to_sort LocallyRingedSpace :=
  has_coe_to_sort.mk (Type u) fun (X : LocallyRingedSpace) => ↥(to_Top X)

-- PROJECT: how about a typeclass "has_structure_sheaf" to mediate the 𝒪 notation, rather

-- than defining it over and over for PresheafedSpace, LRS, Scheme, etc.

/-- The structure sheaf of a locally ringed space. -/
def 𝒪 (X : LocallyRingedSpace) : Top.sheaf CommRing (to_Top X) :=
  SheafedSpace.sheaf (to_SheafedSpace X)

/-- A morphism of locally ringed spaces is a morphism of ringed spaces
 such that the morphims induced on stalks are local ring homomorphisms. -/
def hom (X : LocallyRingedSpace) (Y : LocallyRingedSpace) :=
  Subtype
    fun (f : to_SheafedSpace X ⟶ to_SheafedSpace Y) =>
      ∀ (x : ↥(SheafedSpace.to_PresheafedSpace (to_SheafedSpace X))),
        is_local_ring_hom (PresheafedSpace.stalk_map f x)

protected instance category_theory.has_hom : category_theory.has_hom LocallyRingedSpace :=
  category_theory.has_hom.mk hom

theorem hom_ext {X : LocallyRingedSpace} {Y : LocallyRingedSpace} (f : hom X Y) (g : hom X Y)
    (w : subtype.val f = subtype.val g) : f = g :=
  subtype.eq w

/--
The stalk of a locally ringed space, just as a `CommRing`.
-/
-- TODO perhaps we should make a bundled `LocalRing` and return one here?

-- TODO define `sheaf.stalk` so we can write `X.𝒪.stalk` here?

def stalk (X : LocallyRingedSpace) (x : ↥X) : CommRing :=
  Top.presheaf.stalk
    (PresheafedSpace.presheaf (SheafedSpace.to_PresheafedSpace (to_SheafedSpace X))) x

/--
A morphism of locally ringed spaces `f : X ⟶ Y` induces
a local ring homomorphism from `Y.stalk (f x)` to `X.stalk x` for any `x : X`.
-/
def stalk_map {X : LocallyRingedSpace} {Y : LocallyRingedSpace} (f : X ⟶ Y) (x : ↥X) :
    stalk Y (coe_fn (PresheafedSpace.hom.base (subtype.val f)) x) ⟶ stalk X x :=
  PresheafedSpace.stalk_map (subtype.val f) x

protected instance stalk_map.is_local_ring_hom {X : LocallyRingedSpace} {Y : LocallyRingedSpace}
    (f : X ⟶ Y) (x : ↥X) : is_local_ring_hom (stalk_map f x) :=
  subtype.property f x

/-- The identity morphism on a locally ringed space. -/
def id (X : LocallyRingedSpace) : hom X X := { val := 𝟙, property := sorry }

protected instance hom.inhabited (X : LocallyRingedSpace) : Inhabited (hom X X) :=
  { default := id X }

/-- Composition of morphisms of locally ringed spaces. -/
def comp {X : LocallyRingedSpace} {Y : LocallyRingedSpace} {Z : LocallyRingedSpace} (f : hom X Y)
    (g : hom Y Z) : hom X Z :=
  { val := subtype.val f ≫ subtype.val g, property := sorry }

/-- The category of locally ringed spaces. -/
protected instance category_theory.category : category_theory.category LocallyRingedSpace :=
  category_theory.category.mk

/-- The forgetful functor from `LocallyRingedSpace` to `SheafedSpace CommRing`. -/
def forget_to_SheafedSpace : LocallyRingedSpace ⥤ SheafedSpace CommRing :=
  category_theory.functor.mk (fun (X : LocallyRingedSpace) => to_SheafedSpace X)
    fun (X Y : LocallyRingedSpace) (f : X ⟶ Y) => subtype.val f

protected instance forget_to_SheafedSpace.category_theory.faithful :
    category_theory.faithful forget_to_SheafedSpace :=
  category_theory.faithful.mk

-- PROJECT: once we have `PresheafedSpace.restrict_stalk_iso`

-- (that restriction doesn't change stalks) we can uncomment this.

/-
def restrict {U : Top} (X : LocallyRingedSpace)
  (f : U ⟶ X.to_Top) (h : open_embedding f) : LocallyRingedSpace :=
{ local_ring :=
  begin
    intro x,
    dsimp at *,
    -- We show that the stalk of the restriction is isomorphic to the original stalk,
    have := X.to_SheafedSpace.to_PresheafedSpace.restrict_stalk_iso f h x,
    -- and then transfer `local_ring` across the ring equivalence.
    apply (this.CommRing_iso_to_ring_equiv).local_ring, -- import data.equiv.transfer_instance
    apply X.local_ring,
  end,
  .. X.to_SheafedSpace.restrict _ f h }
-/

/--
The global sections, notated Gamma.
-/
def Γ : LocallyRingedSpaceᵒᵖ ⥤ CommRing :=
  category_theory.functor.op forget_to_SheafedSpace ⋙ SheafedSpace.Γ

theorem Γ_def : Γ = category_theory.functor.op forget_to_SheafedSpace ⋙ SheafedSpace.Γ := rfl

@[simp] theorem Γ_obj (X : LocallyRingedSpaceᵒᵖ) :
    category_theory.functor.obj Γ X =
        category_theory.functor.obj
          (PresheafedSpace.presheaf
            (SheafedSpace.to_PresheafedSpace (to_SheafedSpace (opposite.unop X))))
          (opposite.op ⊤) :=
  rfl

theorem Γ_obj_op (X : LocallyRingedSpace) :
    category_theory.functor.obj Γ (opposite.op X) =
        category_theory.functor.obj
          (PresheafedSpace.presheaf (SheafedSpace.to_PresheafedSpace (to_SheafedSpace X)))
          (opposite.op ⊤) :=
  rfl

@[simp] theorem Γ_map {X : LocallyRingedSpaceᵒᵖ} {Y : LocallyRingedSpaceᵒᵖ} (f : X ⟶ Y) :
    category_theory.functor.map Γ f =
        category_theory.nat_trans.app
            (PresheafedSpace.hom.c (subtype.val (category_theory.has_hom.hom.unop f)))
            (opposite.op ⊤) ≫
          category_theory.functor.map
            (PresheafedSpace.presheaf
              (SheafedSpace.to_PresheafedSpace (to_SheafedSpace (opposite.unop Y))))
            (category_theory.has_hom.hom.op
              (topological_space.opens.le_map_top
                (PresheafedSpace.hom.base (subtype.val (category_theory.has_hom.hom.unop f))) ⊤)) :=
  rfl

theorem Γ_map_op {X : LocallyRingedSpace} {Y : LocallyRingedSpace} (f : X ⟶ Y) :
    category_theory.functor.map Γ (category_theory.has_hom.hom.op f) =
        category_theory.nat_trans.app (PresheafedSpace.hom.c (subtype.val f)) (opposite.op ⊤) ≫
          category_theory.functor.map
            (PresheafedSpace.presheaf (SheafedSpace.to_PresheafedSpace (to_SheafedSpace X)))
            (category_theory.has_hom.hom.op
              (topological_space.opens.le_map_top (PresheafedSpace.hom.base (subtype.val f)) ⊤)) :=
  rfl

end Mathlib


/-
Copyright (c) 2021 Andrew Yang. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Andrew Yang
-/
import category_theory.sites.sheaf
import category_theory.limits.kan_extension
import category_theory.sites.cover_preserving

/-!
# Cover-lifting functors between sites.

We define cover-lifting functors between sites as functors that pull covering sieves back to
covering sieves. This concept is also known as *cocontinuous functors* or
*cover-reflecting functors*, but we have chosen this name following [MM92] in order to avoid
potential naming collision or confusion with the general definition of cocontinuous functors
between categories as functors preserving small colimits.

The definition given here seems stronger than the definition found elsewhere,
but they are actually equivalent via `category_theory.grothendieck_topology.superset_covering`.
(The precise statement is not formalized, but follows from it quite trivially).

## Main definitions

* `category_theory.sites.cover_lifting`: a functor between sites is cover-lifting if it
  pulls back covering sieves to covering sieves
* `category_theory.sites.copullback`: A cover-lifting functor `G : (C, J) ⥤ (D, K)` induces a
  morphism of sites in the same direction as the functor.

## Main results
* `category_theory.sites.Ran_is_sheaf_of_cover_lifting`: If `G : C ⥤ D` is cover_lifting, then
  `Ran G.op` (`ₚu`) as a functor `(Cᵒᵖ ⥤ A) ⥤ (Dᵒᵖ ⥤ A)` of presheaves maps sheaves to sheaves.
* `category_theory.pullback_copullback_adjunction`: If `G : (C, J) ⥤ (D, K)` is cover-lifting,
  cover-preserving, and compatible-preserving, then `pullback G` and `copullback G` are adjoint.

## References

* [Elephant]: *Sketches of an Elephant*, P. T. Johnstone: C2.3.
* [S. MacLane, I. Moerdijk, *Sheaves in Geometry and Logic*][MM92]
* https://stacks.math.columbia.edu/tag/00XI

-/

universes w v v₁ v₂ v₃ u u₁ u₂ u₃
noncomputable theory

open category_theory
open opposite
open category_theory.presieve.family_of_elements
open category_theory.presieve
open category_theory.limits

namespace category_theory
section cover_lifting
variables {C : Type*} [category C] {D : Type*} [category D] {E : Type*} [category E]
variables (J : grothendieck_topology C) (K : grothendieck_topology D)
variables {L : grothendieck_topology E}

/--
A functor `G : (C, J) ⥤ (D, K)` between sites is called to have the cover-lifting property
if for all covering sieves `R` in `D`, `R.pullback G` is a covering sieve in `C`.
-/
@[nolint has_nonempty_instance]
structure cover_lifting (G : C ⥤ D) : Prop :=
(cover_lift : ∀ {U : C} {S : sieve (G.obj U)} (hS : S ∈ K (G.obj U)), S.functor_pullback G ∈ J U)

/-- The identity functor on a site is cover-lifting. -/
lemma id_cover_lifting : cover_lifting J J (𝟭 _) := ⟨λ _ _ h, by simpa using h⟩

variables {J K}

/-- The composition of two cover-lifting functors are cover-lifting -/
lemma comp_cover_lifting {F : C ⥤ D} (hu : cover_lifting J K F) {G : D ⥤ E}
  (hv : cover_lifting K L G) : cover_lifting J L (F ⋙ G) :=
⟨λ _ S h, hu.cover_lift (hv.cover_lift h)⟩

end cover_lifting

/-!
We will now prove that `Ran G.op` (`ₚu`) maps sheaves to sheaves if `G` is cover-lifting. This can
be found in <https://stacks.math.columbia.edu/tag/00XK>. However, the proof given here uses the
amalgamation definition of sheaves, and thus does not require that `C` or `D` has categorical
pullbacks.

For the following proof sketch, `⊆` denotes the homs on `C` and `D` as in the topological analogy.
By definition, the presheaf `𝒢 : Dᵒᵖ ⥤ A` is a sheaf if for every sieve `S` of `U : D`, and every
compatible family of morphisms `X ⟶ 𝒢(V)` for each `V ⊆ U : S` with a fixed source `X`,
we can glue them into a morphism `X ⟶ 𝒢(U)`.

Since the presheaf `𝒢 := (Ran G.op).obj ℱ.val` is defined via `𝒢(U) = lim_{G(V) ⊆ U} ℱ(V)`, for
gluing the family `x` into a `X ⟶ 𝒢(U)`, it suffices to provide a `X ⟶ ℱ(Y)` for each
`G(Y) ⊆ U`. This can be done since `{ Y' ⊆ Y : G(Y') ⊆ U ∈ S}` is a covering sieve for `Y` on
`C` (by the cover-lifting property of `G`). Thus the morphisms `X ⟶ 𝒢(G(Y')) ⟶ ℱ(Y')` can be
glued into a morphism `X ⟶ ℱ(Y)`. This is done in `get_sections`.

In `glued_limit_cone`, we verify these obtained sections are indeed compatible, and thus we obtain
A `X ⟶ 𝒢(U)`. The remaining work is to verify that this is indeed the amalgamation and is unique.
-/
variables {C D : Type u} [category.{v} C] [category.{v} D]
variables {A : Type w} [category.{max u v} A] [has_limits A]
variables {J : grothendieck_topology C} {K : grothendieck_topology D}

namespace Ran_is_sheaf_of_cover_lifting
variables {G : C ⥤ D} (hu : cover_lifting J K G) (ℱ : Sheaf J A)
variables {X : A} {U : D} (S : sieve U) (hS : S ∈ K U)

instance (X : Dᵒᵖ) : has_limits_of_shape (structured_arrow X G.op) A :=
begin
  haveI := limits.has_limits_of_size_shrink.{v (max u v) (max u v) (max u v)} A,
  exact has_limits_of_size.has_limits_of_shape _
end

variables (x : S.arrows.family_of_elements ((Ran G.op).obj ℱ.val ⋙ coyoneda.obj (op X)))
variables (hx : x.compatible)

/-- The family of morphisms `X ⟶ 𝒢(G(Y')) ⟶ ℱ(Y')` defined on `{ Y' ⊆ Y : G(Y') ⊆ U ∈ S}`. -/
def pulledback_family (Y : structured_arrow (op U) G.op) :=
(((x.pullback Y.hom.unop).functor_pullback G).comp_presheaf_map
  (show _ ⟶ _, from whisker_right ((Ran.adjunction A G.op).counit.app ℱ.val)
    (coyoneda.obj (op X))))

@[simp] lemma pulledback_family_apply (Y : structured_arrow (op U) G.op) {W} {f : W ⟶ _} (Hf) :
  pulledback_family ℱ S x Y f Hf =
    x (G.map f ≫ Y.hom.unop) Hf ≫ ((Ran.adjunction A G.op).counit.app ℱ.val).app (op W) := rfl

variables {x} {S}
include hu hS hx

/-- Given a `G(Y) ⊆ U`, we can find a unique section `X ⟶ ℱ(Y)` that agrees with `x`. -/
def get_section (Y : structured_arrow (op U) G.op) : X ⟶ ℱ.val.obj Y.right :=
begin
  let hom_sh := whisker_right ((Ran.adjunction A G.op).counit.app ℱ.val) (coyoneda.obj (op X)),
  have S' := (K.pullback_stable Y.hom.unop hS),
  have hs' := ((hx.pullback Y.3.unop).functor_pullback G).comp_presheaf_map hom_sh,
  exact (ℱ.2 X _ (hu.cover_lift S')).amalgamate _ hs'
end

lemma get_section_is_amalgamation (Y : structured_arrow (op U) G.op) :
  (pulledback_family ℱ S x Y).is_amalgamation (get_section hu ℱ hS hx Y) :=
is_sheaf_for.is_amalgamation _ _

lemma get_section_is_unique (Y : structured_arrow (op U) G.op)
  {y} (H : (pulledback_family ℱ S x Y).is_amalgamation y) : y = get_section hu ℱ hS hx Y :=
begin
  apply is_sheaf_for.is_separated_for _ (pulledback_family ℱ S x Y),
  { exact H },
  { apply get_section_is_amalgamation },
  { exact ℱ.2 X _ (hu.cover_lift (K.pullback_stable Y.hom.unop hS)) }
end

@[simp] lemma get_section_commute {Y Z : structured_arrow (op U) G.op} (f : Y ⟶ Z) :
  get_section hu ℱ hS hx Y ≫ ℱ.val.map f.right = get_section hu ℱ hS hx Z :=
begin
  apply get_section_is_unique,
  intros V' fV' hV',
  have eq : Z.hom = Y.hom ≫ (G.map f.right.unop).op,
  { convert f.w, erw category.id_comp },
  rw eq at hV',
  convert get_section_is_amalgamation hu ℱ hS hx Y (fV' ≫ f.right.unop) _ using 1,
  { tidy },
  { simp only [eq, quiver.hom.unop_op, pulledback_family_apply,
    functor.map_comp, unop_comp, category.assoc] },
  { change S (G.map _ ≫ Y.hom.unop),
    simpa only [functor.map_comp, category.assoc] using hV' }
end

/-- The limit cone in order to glue the sections obtained via `get_section`. -/
def glued_limit_cone : limits.cone (Ran.diagram G.op ℱ.val (op U)) :=
{ X := X, π := { app := λ Y, get_section hu ℱ hS hx Y, naturality' := λ Y Z f, by tidy } }

@[simp] lemma glued_limit_cone_π_app (W) : (glued_limit_cone hu ℱ hS hx).π.app W =
  get_section hu ℱ hS hx W := rfl

/-- The section obtained by passing `glued_limit_cone` into `category_theory.limits.limit.lift`. -/
def glued_section : X ⟶ ((Ran G.op).obj ℱ.val).obj (op U) :=
limit.lift _ (glued_limit_cone hu ℱ hS hx)

/--
A helper lemma for the following two lemmas. Basically stating that if the section `y : X ⟶ 𝒢(V)`
coincides with `x` on `G(V')` for all `G(V') ⊆ V ∈ S`, then `X ⟶ 𝒢(V) ⟶ ℱ(W)` is indeed the
section obtained in `get_sections`. That said, this is littered with some more categorical jargon
in order to be applied in the following lemmas easier.
-/
lemma helper {V} (f : V ⟶ U) (y : X ⟶ ((Ran G.op).obj ℱ.val).obj (op V)) (W)
  (H : ∀ {V'} {fV : G.obj V' ⟶ V} (hV), y ≫ ((Ran G.op).obj ℱ.val).map fV.op = x (fV ≫ f) hV) :
  y ≫ limit.π (Ran.diagram G.op ℱ.val (op V)) W =
    (glued_limit_cone hu ℱ hS hx).π.app ((structured_arrow.map f.op).obj W) :=
begin
  dsimp only [glued_limit_cone_π_app],
  apply get_section_is_unique hu ℱ hS hx ((structured_arrow.map f.op).obj W),
  intros V' fV' hV',
  dsimp only [Ran.adjunction, Ran.equiv, pulledback_family_apply],
  erw [adjunction.adjunction_of_equiv_right_counit_app],
  have : y ≫ ((Ran G.op).obj ℱ.val).map (G.map fV' ≫ W.hom.unop).op =
    x (G.map fV' ≫ W.hom.unop ≫ f) (by simpa only using hV'),
  { convert H (show S ((G.map fV' ≫ W.hom.unop) ≫ f),
      by simpa only [category.assoc] using hV') using 2,
    simp only [category.assoc] },
  simp only [quiver.hom.unop_op, equiv.symm_symm, structured_arrow.map_obj_hom, unop_comp,
    equiv.coe_fn_mk, functor.comp_map, coyoneda_obj_map, category.assoc, ← this, op_comp,
    Ran_obj_map, nat_trans.id_app],
  erw [category.id_comp, limit.pre_π],
  congr,
  convert limit.w (Ran.diagram G.op ℱ.val (op V)) (structured_arrow.hom_mk' W fV'.op),
  rw structured_arrow.map_mk,
  erw category.comp_id,
  simp only [quiver.hom.unop_op, functor.op_map, quiver.hom.op_unop]
end

/-- Verify that the `glued_section` is an amalgamation of `x`. -/
lemma glued_section_is_amalgamation : x.is_amalgamation (glued_section hu ℱ hS hx) :=
begin
  intros V fV hV,
  ext W,
  simp only [functor.comp_map, limit.lift_pre, coyoneda_obj_map, Ran_obj_map, glued_section],
  erw limit.lift_π,
  symmetry,
  convert helper hu ℱ hS hx _ (x fV hV) _ _ using 1,
  intros V' fV' hV',
  convert hx (fV') (𝟙 _) hV hV' (by rw category.id_comp),
  simp only [op_id, functor_to_types.map_id_apply]
end

/-- Verify that the amalgamation is indeed unique. -/
lemma glued_section_is_unique (y) (hy: x.is_amalgamation y) : y = glued_section hu ℱ hS hx :=
begin
  unfold glued_section limit.lift,
  ext W,
  erw limit.lift_π,
  convert helper hu ℱ hS hx (𝟙 _) y W _,
  { simp only [op_id, structured_arrow.map_id] },
  { intros V' fV' hV',
    convert hy fV' (by simpa only [category.comp_id] using hV'),
    erw category.comp_id }
end

end Ran_is_sheaf_of_cover_lifting

/--
If `G` is cover_lifting, then `Ran G.op` pushes sheaves to sheaves.

This result is basically https://stacks.math.columbia.edu/tag/00XK,
but without the condition that `C` or `D` has pullbacks.
-/
theorem Ran_is_sheaf_of_cover_lifting {G : C ⥤ D} (hG : cover_lifting J K G) (ℱ : Sheaf J A) :
  presheaf.is_sheaf K ((Ran G.op).obj ℱ.val) :=
begin
  intros X U S hS x hx,
  split, swap,
  { apply Ran_is_sheaf_of_cover_lifting.glued_section hG ℱ hS hx },
  split,
  { apply Ran_is_sheaf_of_cover_lifting.glued_section_is_amalgamation },
  { apply Ran_is_sheaf_of_cover_lifting.glued_section_is_unique }
end

variable (A)

/-- A cover-lifting functor induces a morphism of sites in the same direction as the functor. -/
def sites.copullback {G : C ⥤ D} (hG : cover_lifting J K G) :
  Sheaf J A ⥤ Sheaf K A :=
{ obj := λ ℱ, ⟨(Ran G.op).obj ℱ.val, Ran_is_sheaf_of_cover_lifting hG ℱ⟩,
  map := λ _ _ f, ⟨(Ran G.op).map f.val⟩,
  map_id' := λ ℱ, Sheaf.hom.ext _ _ $ (Ran G.op).map_id ℱ.val,
  map_comp' := λ _ _ _ f g, Sheaf.hom.ext _ _ $ (Ran G.op).map_comp f.val g.val }

/--
Given a functor between sites that is cover-preserving, cover-lifting, and compatible-preserving,
the pullback and copullback along `G` are adjoint to each other
-/
@[simps unit_app_val counit_app_val] noncomputable
def sites.pullback_copullback_adjunction {G : C ⥤ D} (Hp : cover_preserving J K G)
  (Hl : cover_lifting J K G) (Hc : compatible_preserving K G) :
  sites.pullback A Hc Hp ⊣ sites.copullback A Hl :=
{ hom_equiv := λ X Y,
  { to_fun := λ f, ⟨(Ran.adjunction A G.op).hom_equiv X.val Y.val f.val⟩,
    inv_fun := λ f, ⟨((Ran.adjunction A G.op).hom_equiv X.val Y.val).symm f.val⟩,
    left_inv := λ f, by { ext1, dsimp, rw [equiv.symm_apply_apply] },
    right_inv := λ f, by { ext1, dsimp, rw [equiv.apply_symm_apply] } },
  unit := { app := λ X, ⟨(Ran.adjunction A G.op).unit.app X.val⟩,
    naturality' := λ _ _ f, Sheaf.hom.ext _ _ $ (Ran.adjunction A G.op).unit.naturality f.val },
  counit := { app := λ X, ⟨(Ran.adjunction A G.op).counit.app X.val⟩,
    naturality' := λ _ _ f, Sheaf.hom.ext _ _ $ (Ran.adjunction A G.op).counit.naturality f.val },
  hom_equiv_unit' := λ X Y f, by { ext1, apply (Ran.adjunction A G.op).hom_equiv_unit },
  hom_equiv_counit' := λ X Y f, by { ext1, apply (Ran.adjunction A G.op).hom_equiv_counit } }

end category_theory


import data.real.basic
import tactic

private meta def finish_proof_about_abs : tactic unit := `[
  unfold abs,
  simp,
  exact le_of_lt h,
  rw undo_abs at *,
  split;
  linarith
]

lemma eq_of_abs_sub_le_all_pos (x y : ℝ) : (∀ ε > 0, |x - y| ≤ ε) → x = y :=
begin
  contrapose!,
  intro ass,
  use |x - y| / 2,
  cases ne.lt_or_lt ass,
  {
    have undo_abs : |x - y| = y - x,
    finish_proof_about_abs,
  },
  {
    have undo_abs : |x - y| = x - y,
    finish_proof_about_abs,
  },
end


import Smt.Tactic.Concretize

def BitVec (w : Nat) := Fin (2^w)

protected def BitVec.zero (w : Nat) : BitVec w :=
  ⟨0, Nat.pos_pow_of_pos _ <| by decide⟩

instance : Inhabited (BitVec w) := ⟨BitVec.zero w⟩

opaque BitVec.xor {w : Nat} : BitVec w → BitVec w → BitVec w

def polyAdd {w : Nat} : BitVec w → BitVec w → BitVec w :=
  BitVec.xor
def polyDouble {w : Nat} (x : BitVec w) : BitVec w :=
  polyAdd x x

example (x y : BitVec 2) : polyDouble (polyAdd x y) = polyDouble (polyAdd y x) := by
  concretize [polyDouble, polyAdd]
  trace_state
  sorry


@[simp] axiom divSelf (x : Nat) : x ≠ 0 → x/x = 1

theorem ex (x : Nat) (h : x ≠ 0) : (if x/x = 1 then 0 else 1) = 0 := by
  simp [h]


import mynat.definition

lemma example3 (a b : mynat) (h : succ a = b) : succ(succ(a)) = succ(b) :=
begin
rw ← h,
refl,
end


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

! This file was ported from Lean 3 source module category_theory.bicategory.functor
! leanprover-community/mathlib commit 369525b73f229ccd76a6ec0e0e0bf2be57599768
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathlib.CategoryTheory.Bicategory.Basic

/-!
# Oplax functors and pseudofunctors

An oplax functor `F` between bicategories `B` and `C` consists of
* a function between objects `F.obj : B ⟶ C`,
* a family of functions between 1-morphisms `F.map : (a ⟶ b) → (F.obj a ⟶ F.obj b)`,
* a family of functions between 2-morphisms `F.map₂ : (f ⟶ g) → (F.map f ⟶ F.map g)`,
* a family of 2-morphisms `F.mapId a : F.map (𝟙 a) ⟶ 𝟙 (F.obj a)`,
* a family of 2-morphisms `F.mapComp f g : F.map (f ≫ g) ⟶ F.map f ≫ F.map g`, and
* certain consistency conditions on them.

A pseudofunctor is an oplax functor whose `mapId` and `mapComp` are isomorphisms. We provide
several constructors for pseudofunctors:
* `Pseudofunctor.mk` : the default constructor, which requires `map₂_whiskerLeft` and
  `map₂_whiskerRight` instead of naturality of `mapComp`.
* `Pseudofunctor.mkOfOplax` : construct a pseudofunctor from an oplax functor whose
  `mapId` and `mapComp` are isomorphisms. This constructor uses `Iso` to describe isomorphisms.
* `pseudofunctor.mkOfOplax'` : similar to `mkOfOplax`, but uses `IsIso` to describe
  isomorphisms.

The additional constructors are useful when constructing a pseudofunctor where the construction
of the oplax functor associated with it is already done. For example, the composition of
pseudofunctors can be defined by using the composition of oplax functors as follows:
```lean
def comp (F : Pseudofunctor B C) (G : Pseudofunctor C D) : Pseudofunctor B D :=
mkOfOplax ((F : OplaxFunctor B C).comp G)
{ mapIdIso := λ a => (G.mapFunctor _ _).mapIso (F.mapId a) ≪≫ G.mapId (F.obj a),
  mapCompIso := λ f g =>
    (G.mapFunctor _ _).mapIso (F.mapComp f g) ≪≫ G.mapComp (F.map f) (F.map g) }
```
although the composition of pseudofunctors in this file is defined by using the default constructor
because `obviously` wasn't smart enough in mathlib3 and the porter of this file was too lazy
to investigage this issue further in mathlib4. Similarly, the composition is also defined by using
`mkOfOplax'` after giving appropriate instances for `IsIso`. The former constructor
`mkOfOplax` requires isomorphisms as data type `Iso`, and so it is useful if you don't want
to forget the definitions of the inverses. On the other hand, the latter constructor
`mkOfOplax'` is useful if you want to use propositional type class `IsIso`.

## Main definitions

* `CategoryTheory.OplaxFunctor B C` : an oplax functor between bicategories `B` and `C`
* `CategoryTheory.OplaxFunctor.comp F G` : the composition of oplax functors
* `CategoryTheory.Pseudofunctor B C` : a pseudofunctor between bicategories `B` and `C`
* `CategoryTheory.Pseudofunctor.comp F G` : the composition of pseudofunctors

## Future work

There are two types of functors between bicategories, called lax and oplax functors, depending on
the directions of `mapId` and `mapComp`. We may need both in mathlib in the future, but for
now we only define oplax functors.
-/

namespace CategoryTheory

open Category Bicategory

open Bicategory

universe w₁ w₂ w₃ v₁ v₂ v₃ u₁ u₂ u₃

section

variable {B : Type u₁} [Quiver.{v₁ + 1} B] [∀ a b : B, Quiver.{w₁ + 1} (a ⟶ b)]

variable {C : Type u₂} [Quiver.{v₂ + 1} C] [∀ a b : C, Quiver.{w₂ + 1} (a ⟶ b)]

variable {D : Type u₃} [Quiver.{v₃ + 1} D] [∀ a b : D, Quiver.{w₃ + 1} (a ⟶ b)]

/-- A prelax functor between bicategories consists of functions between objects,
1-morphisms, and 2-morphisms. This structure will be extended to define `OplaxFunctor`.
-/
structure PrelaxFunctor (B : Type u₁) [Quiver.{v₁ + 1} B] [∀ a b : B, Quiver.{w₁ + 1} (a ⟶ b)]
  (C : Type u₂) [Quiver.{v₂ + 1} C] [∀ a b : C, Quiver.{w₂ + 1} (a ⟶ b)] extends
  Prefunctor B C where
  map₂ {a b : B} {f g : a ⟶ b} : (f ⟶ g) → (map f ⟶ map g)
#align category_theory.prelax_functor CategoryTheory.PrelaxFunctor

initialize_simps_projections PrelaxFunctor (+toPrefunctor, -obj, -map)

attribute [nolint docBlame] CategoryTheory.PrelaxFunctor.map₂

/-- The prefunctor between the underlying quivers. -/
add_decl_doc PrelaxFunctor.toPrefunctor

namespace PrelaxFunctor

attribute [coe] CategoryTheory.PrelaxFunctor.toPrefunctor

instance hasCoeToPrefunctor : Coe (PrelaxFunctor B C) (Prefunctor B C) :=
  ⟨toPrefunctor⟩
#align category_theory.prelax_functor.has_coe_to_prefunctor
  CategoryTheory.PrelaxFunctor.hasCoeToPrefunctor

variable (F : PrelaxFunctor B C)

-- porting note: deleted syntactic tautologies `toPrefunctor_eq_coe : F.toPrefunctor = F`
-- and `to_prefunctor_obj : (F : Prefunctor B C).obj = F.obj`
-- and `to_prefunctor_map`
#noalign category_theory.prelax_functor.to_prefunctor_eq_coe
#noalign category_theory.prelax_functor.to_prefunctor_obj
#noalign category_theory.prelax_functor.to_prefunctor_map

/-- The identity prelax functor. -/
@[simps]
def id (B : Type u₁) [Quiver.{v₁ + 1} B] [∀ a b : B, Quiver.{w₁ + 1} (a ⟶ b)] : PrelaxFunctor B B :=
  { Prefunctor.id B with map₂ := fun η => η }
#align category_theory.prelax_functor.id CategoryTheory.PrelaxFunctor.id

instance : Inhabited (PrelaxFunctor B B) :=
  ⟨PrelaxFunctor.id B⟩

-- porting note: `by exact` was not necessary in mathlib3
/-- Composition of prelax functors. -/
@[simps]
def comp (F : PrelaxFunctor B C) (G : PrelaxFunctor C D) : PrelaxFunctor B D :=
  { (F : Prefunctor B C).comp ↑G with map₂ := fun η => by exact G.map₂ (F.map₂ η) }
#align category_theory.prelax_functor.comp CategoryTheory.PrelaxFunctor.comp

end PrelaxFunctor

end

section

variable {B : Type u₁} [Bicategory.{w₁, v₁} B] {C : Type u₂} [Bicategory.{w₂, v₂} C]

variable {D : Type u₃} [Bicategory.{w₃, v₃} D]

-- porting note: in Lean 3 the below auxiliary definition was only used once, in the definition
-- of oplax functor, with a comment that it had to be used to fix a timeout. The timeout is
-- not present in Lean 4, however Lean 4 is not as good at seeing through the definition,
-- meaning that `simp` wasn't functioning as well as it should. I have hence removed
-- the auxiliary definition.
--@[simp]
--def OplaxFunctor.Map₂AssociatorAux (obj : B → C) (map : ∀ {X Y : B}, (X ⟶ Y) → (obj X ⟶ obj Y))
--    (map₂ : ∀ {a b : B} {f g : a ⟶ b}, (f ⟶ g) → (map f ⟶ map g))
--    (map_comp : ∀ {a b c : B} (f : a ⟶ b) (g : b ⟶ c), map (f ≫ g) ⟶ map f ≫ map g) {a b c d : B}
--    (f : a ⟶ b) (g : b ⟶ c) (h : c ⟶ d) : Prop := ...

#noalign category_theory.oplax_functor.map₂_associator_aux

/-- An oplax functor `F` between bicategories `B` and `C` consists of a function between objects
`F.obj`, a function between 1-morphisms `F.map`, and a function between 2-morphisms `F.map₂`.

Unlike functors between categories, `F.map` do not need to strictly commute with the composition,
and do not need to strictly preserve the identity. Instead, there are specified 2-morphisms
`F.map (𝟙 a) ⟶ 𝟙 (F.obj a)` and `F.map (f ≫ g) ⟶ F.map f ≫ F.map g`.

`F.map₂` strictly commute with compositions and preserve the identity. They also preserve the
associator, the left unitor, and the right unitor modulo some adjustments of domains and codomains
of 2-morphisms.
-/
structure OplaxFunctor (B : Type u₁) [Bicategory.{w₁, v₁} B] (C : Type u₂)
  [Bicategory.{w₂, v₂} C] extends PrelaxFunctor B C where
  mapId (a : B) : map (𝟙 a) ⟶ 𝟙 (obj a)
  mapComp {a b c : B} (f : a ⟶ b) (g : b ⟶ c) : map (f ≫ g) ⟶ map f ≫ map g
  mapComp_naturality_left :
    ∀ {a b c : B} {f f' : a ⟶ b} (η : f ⟶ f') (g : b ⟶ c),
      map₂ (η ▷ g) ≫ mapComp f' g = mapComp f g ≫ map₂ η ▷ map g := by
    aesop_cat
  mapComp_naturality_right :
    ∀ {a b c : B} (f : a ⟶ b) {g g' : b ⟶ c} (η : g ⟶ g'),
      map₂ (f ◁ η) ≫ mapComp f g' = mapComp f g ≫ map f ◁ map₂ η := by
    aesop_cat
  map₂_id : ∀ {a b : B} (f : a ⟶ b), map₂ (𝟙 f) = 𝟙 (map f) := by aesop
  map₂_comp :
    ∀ {a b : B} {f g h : a ⟶ b} (η : f ⟶ g) (θ : g ⟶ h), map₂ (η ≫ θ) = map₂ η ≫ map₂ θ := by
    aesop_cat
  -- porting note: `map₂_associator_aux` was used here in lean 3, but this was a hack
  -- to avoid a timeout; we revert this hack here (because it was causing other problems
  -- and was not necessary in lean 4)
  map₂_associator :
    ∀ {a b c d : B} (f : a ⟶ b) (g : b ⟶ c) (h : c ⟶ d),
      map₂ (α_ f g h).hom ≫ mapComp f (g ≫ h) ≫ map f ◁ mapComp g h =
    mapComp (f ≫ g) h ≫ mapComp f g ▷ map h ≫ (α_ (map f) (map g) (map h)).hom := by
    aesop_cat
  map₂_leftUnitor :
    ∀ {a b : B} (f : a ⟶ b),
      map₂ (λ_ f).hom = mapComp (𝟙 a) f ≫ mapId a ▷ map f ≫ (λ_ (map f)).hom := by
    aesop_cat
  map₂_rightUnitor :
    ∀ {a b : B} (f : a ⟶ b),
      map₂ (ρ_ f).hom = mapComp f (𝟙 b) ≫ map f ◁ mapId b ≫ (ρ_ (map f)).hom := by
    aesop_cat
#align category_theory.oplax_functor CategoryTheory.OplaxFunctor
#align category_theory.oplax_functor.map_id CategoryTheory.OplaxFunctor.mapId
#align category_theory.oplax_functor.map_comp CategoryTheory.OplaxFunctor.mapComp
#align category_theory.oplax_functor.map_comp_naturality_left' CategoryTheory.OplaxFunctor.mapComp_naturality_left
#align category_theory.oplax_functor.map_comp_naturality_left CategoryTheory.OplaxFunctor.mapComp_naturality_left
#align category_theory.oplax_functor.map_comp_naturality_right' CategoryTheory.OplaxFunctor.mapComp_naturality_right
#align category_theory.oplax_functor.map_comp_naturality_right CategoryTheory.OplaxFunctor.mapComp_naturality_right
#align category_theory.oplax_functor.map₂_id' CategoryTheory.OplaxFunctor.map₂_id
#align category_theory.oplax_functor.map₂_comp' CategoryTheory.OplaxFunctor.map₂_comp
#align category_theory.oplax_functor.map₂_associator' CategoryTheory.OplaxFunctor.map₂_associator
#align category_theory.oplax_functor.map₂_left_unitor CategoryTheory.OplaxFunctor.map₂_leftUnitor
#align category_theory.oplax_functor.map₂_left_unitor' CategoryTheory.OplaxFunctor.map₂_leftUnitor
#align category_theory.oplax_functor.map₂_right_unitor CategoryTheory.OplaxFunctor.map₂_rightUnitor
#align category_theory.oplax_functor.map₂_right_unitor' CategoryTheory.OplaxFunctor.map₂_rightUnitor

initialize_simps_projections OplaxFunctor (+toPrelaxFunctor, -obj, -map, -map₂)

namespace OplaxFunctor

/- Porting note: removed primes from field names and remove `restate_axiom` since
that is no longer needed in Lean 4 -/

-- porting note: more stuff was tagged `simp` here in lean 3 but `reassoc (attr := simp)`
-- is doing this job a couple of lines below this.
attribute [simp] map₂_id

-- porting note: was auto-ported as `attribute [reassoc.1]` for some reason
attribute [reassoc (attr := simp)]
  mapComp_naturality_left mapComp_naturality_right map₂_associator

-- the simpNF linter complains that `map₂_leftUnitor_assoc` etc can be
-- proved with `simp` so I move them here
attribute [reassoc] map₂_leftUnitor map₂_comp map₂_rightUnitor
attribute [simp] map₂_leftUnitor map₂_comp map₂_rightUnitor
section

/-- The prelax functor between the underlying quivers. -/
add_decl_doc OplaxFunctor.toPrelaxFunctor

attribute [nolint docBlame] CategoryTheory.OplaxFunctor.mapId
  CategoryTheory.OplaxFunctor.mapComp
  CategoryTheory.OplaxFunctor.mapComp_naturality_left
  CategoryTheory.OplaxFunctor.mapComp_naturality_right
  CategoryTheory.OplaxFunctor.map₂_id
  CategoryTheory.OplaxFunctor.map₂_comp
  CategoryTheory.OplaxFunctor.map₂_associator
  CategoryTheory.OplaxFunctor.map₂_leftUnitor
  CategoryTheory.OplaxFunctor.map₂_rightUnitor

instance hasCoeToPrelax : Coe (OplaxFunctor B C) (PrelaxFunctor B C) :=
  ⟨toPrelaxFunctor⟩
#align category_theory.oplax_functor.has_coe_to_prelax CategoryTheory.OplaxFunctor.hasCoeToPrelax

variable (F : OplaxFunctor B C)

-- porting note: `to_prelax_eq_coe` and `to_prelaxFunctor_obj` are
-- syntactic tautologies in lean 4
#noalign category_theory.oplax_functor.to_prelax_eq_coe
#noalign category_theory.oplax_functor.to_prelax_functor_obj

--porting note: removed lemma `to_prelaxFunctor_map` relating the now
-- nonexistent `PrelaxFunctor.map` and `OplaxFunctor.map`
#noalign CategoryTheory.OplaxFunctor.to_prelaxFunctor_map

--porting note: removed lemma `to_prelaxFunctor_map₂` relating
-- `PrelaxFunctor.map₂` to nonexistent `OplaxFunctor.map₂`
#noalign category_theory.oplax_functor.to_prelax_functor_map₂

/-- Function between 1-morphisms as a functor. -/
@[simps]
def mapFunctor (a b : B) : (a ⟶ b) ⥤ (F.obj a ⟶ F.obj b)
    where
  obj f := F.map f
  map η := F.map₂ η
#align category_theory.oplax_functor.map_functor CategoryTheory.OplaxFunctor.mapFunctor

/-- The identity oplax functor. -/
@[simps]
def id (B : Type u₁) [Bicategory.{w₁, v₁} B] : OplaxFunctor B B :=
  { PrelaxFunctor.id B with
    mapId := fun a => 𝟙 (𝟙 a)
    mapComp := fun f g => 𝟙 (f ≫ g)
  }
#align category_theory.oplax_functor.id CategoryTheory.OplaxFunctor.id

instance : Inhabited (OplaxFunctor B B) :=
  ⟨id B⟩

/-- Composition of oplax functors. -/
--@[simps]
def comp (F : OplaxFunctor B C) (G : OplaxFunctor C D) : OplaxFunctor B D :=
  {
    (F : PrelaxFunctor B C).comp G with
    mapId := fun a => by exact (G.mapFunctor _ _).map (F.mapId a) ≫ G.mapId (F.obj a)
    mapComp := fun f g => by
      exact (G.mapFunctor _ _).map (F.mapComp f g) ≫ G.mapComp (F.map f) (F.map g)
    mapComp_naturality_left := fun η g =>
      by
      dsimp
      rw [← map₂_comp_assoc, mapComp_naturality_left, map₂_comp_assoc, mapComp_naturality_left,
        assoc]
    mapComp_naturality_right := fun η =>
      by
      dsimp
      intros
      rw [← map₂_comp_assoc, mapComp_naturality_right, map₂_comp_assoc, mapComp_naturality_right,
        assoc]
    map₂_associator := fun f g h => by
      dsimp
      -- porting note: if you use the `map₂_associator_aux` hack in the definition of
      -- `map₂_associator` then the `simp only` call below does not seem to apply `map₂_associator`
      simp only [map₂_associator, ← map₂_comp_assoc, ← mapComp_naturality_right_assoc,
        whiskerLeft_comp, assoc]
      simp only [map₂_associator, map₂_comp, mapComp_naturality_left_assoc, comp_whiskerRight,
        assoc]
    map₂_leftUnitor := fun f => by
      dsimp
      simp only [map₂_leftUnitor, map₂_comp, mapComp_naturality_left_assoc, comp_whiskerRight,
        assoc]
    map₂_rightUnitor := fun f => by
      dsimp
      simp only [map₂_rightUnitor, map₂_comp, mapComp_naturality_right_assoc, whiskerLeft_comp,
        assoc] }
#align category_theory.oplax_functor.comp CategoryTheory.OplaxFunctor.comp

/-- A structure on an oplax functor that promotes an oplax functor to a pseudofunctor.
See `Pseudofunctor.mkOfOplax`.
-/
-- porting note: removing no lint for nonempty_instance
--@[nolint has_nonempty_instance]
-- porting note: removing primes in structure name because
-- my understanding is that they're no longer needed
structure PseudoCore (F : OplaxFunctor B C) where
  mapIdIso (a : B) : F.map (𝟙 a) ≅ 𝟙 (F.obj a)
  mapCompIso {a b c : B} (f : a ⟶ b) (g : b ⟶ c) : F.map (f ≫ g) ≅ F.map f ≫ F.map g
  mapIdIso_hom : ∀ {a : B}, (mapIdIso a).hom = F.mapId a := by aesop_cat
  mapCompIso_hom :
    ∀ {a b c : B} (f : a ⟶ b) (g : b ⟶ c), (mapCompIso f g).hom = F.mapComp f g := by aesop_cat
#align category_theory.oplax_functor.pseudo_core CategoryTheory.OplaxFunctor.PseudoCore

attribute [nolint docBlame] CategoryTheory.OplaxFunctor.PseudoCore.mapIdIso
  CategoryTheory.OplaxFunctor.PseudoCore.mapCompIso
  CategoryTheory.OplaxFunctor.PseudoCore.mapIdIso_hom
  CategoryTheory.OplaxFunctor.PseudoCore.mapCompIso_hom

attribute [simp] PseudoCore.mapIdIso_hom PseudoCore.mapCompIso_hom

end

end OplaxFunctor

-- porting note: this auxiliary def was introduced in Lean 3 and only used once, in this file,
-- to avoid a timeout. In Lean 4 the timeout isn't present and the definition causes other
-- things to break (simp proofs) so I removed it.
-- def Pseudofunctor.Map₂AssociatorAux (obj : B → C) (map : ∀ {X Y : B}, (X ⟶ Y) → (obj X ⟶ obj Y))
--     (map₂ : ∀ {a b : B} {f g : a ⟶ b}, (f ⟶ g) → (map f ⟶ map g))
--    (map_comp : ∀ {a b c : B} (f : a ⟶ b) (g : b ⟶ c), map (f ≫ g) ≅ map f ≫ map g) {a b c d : B}
--     (f : a ⟶ b) (g : b ⟶ c) (h : c ⟶ d) : Prop :=
--   map₂ (α_ f g h).hom =
--     (map_comp (f ≫ g) h).hom ≫
--       (map_comp f g).hom ▷ map h ≫
--        (α_ (map f) (map g) (map h)).hom ≫ map f ◁ (map_comp g h).inv ≫ (map_comp f (g ≫ h)).inv
#noalign category_theory.pseudofunctor.map₂_associator_aux

/-- A pseudofunctor `F` between bicategories `B` and `C` consists of a function between objects
`F.obj`, a function between 1-morphisms `F.map`, and a function between 2-morphisms `F.map₂`.

Unlike functors between categories, `F.map` do not need to strictly commute with the compositions,
and do not need to strictly preserve the identity. Instead, there are specified 2-isomorphisms
`F.map (𝟙 a) ≅ 𝟙 (F.obj a)` and `F.map (f ≫ g) ≅ F.map f ≫ F.map g`.

`F.map₂` strictly commute with compositions and preserve the identity. They also preserve the
associator, the left unitor, and the right unitor modulo some adjustments of domains and codomains
of 2-morphisms.
-/
structure Pseudofunctor (B : Type u₁) [Bicategory.{w₁, v₁} B] (C : Type u₂)
  [Bicategory.{w₂, v₂} C] extends PrelaxFunctor B C where
  mapId (a : B) : map (𝟙 a) ≅ 𝟙 (obj a)
  mapComp {a b c : B} (f : a ⟶ b) (g : b ⟶ c) : map (f ≫ g) ≅ map f ≫ map g
  map₂_id : ∀ {a b : B} (f : a ⟶ b), map₂ (𝟙 f) = 𝟙 (map f) := by aesop_cat
  map₂_comp :
    ∀ {a b : B} {f g h : a ⟶ b} (η : f ⟶ g) (θ : g ⟶ h), map₂ (η ≫ θ) = map₂ η ≫ map₂ θ := by
    aesop_cat
  map₂_whisker_left :
    ∀ {a b c : B} (f : a ⟶ b) {g h : b ⟶ c} (η : g ⟶ h),
      map₂ (f ◁ η) = (mapComp f g).hom ≫ map f ◁ map₂ η ≫ (mapComp f h).inv := by
    aesop_cat
  map₂_whisker_right :
    ∀ {a b c : B} {f g : a ⟶ b} (η : f ⟶ g) (h : b ⟶ c),
      map₂ (η ▷ h) = (mapComp f h).hom ≫ map₂ η ▷ map h ≫ (mapComp g h).inv := by
    aesop_cat
  map₂_associator :
    ∀ {a b c d : B} (f : a ⟶ b) (g : b ⟶ c) (h : c ⟶ d),
      map₂ (α_ f g h).hom = (mapComp (f ≫ g) h).hom ≫ (mapComp f g).hom ▷ map h ≫
      (α_ (map f) (map g) (map h)).hom ≫ map f ◁ (mapComp g h).inv ≫
      (mapComp f (g ≫ h)).inv := by
    aesop_cat
  map₂_left_unitor :
    ∀ {a b : B} (f : a ⟶ b),
      map₂ (λ_ f).hom = (mapComp (𝟙 a) f).hom ≫ (mapId a).hom ▷ map f ≫ (λ_ (map f)).hom := by
    aesop_cat
  map₂_right_unitor :
    ∀ {a b : B} (f : a ⟶ b),
      map₂ (ρ_ f).hom = (mapComp f (𝟙 b)).hom ≫ map f ◁ (mapId b).hom ≫ (ρ_ (map f)).hom := by
    aesop_cat
#align category_theory.pseudofunctor CategoryTheory.Pseudofunctor

initialize_simps_projections Pseudofunctor (+toPrelaxFunctor, -obj, -map, -map₂)

namespace Pseudofunctor

-- porting note: was `[reassoc.1]` for some reason?
attribute [reassoc]
  map₂_comp map₂_whisker_left map₂_whisker_right map₂_associator map₂_left_unitor map₂_right_unitor

attribute [simp]
  map₂_id map₂_comp map₂_whisker_left map₂_whisker_right map₂_associator map₂_left_unitor
  map₂_right_unitor

section

open Iso

/-- The prelax functor between the underlying quivers. -/
add_decl_doc Pseudofunctor.toPrelaxFunctor

attribute [nolint docBlame] CategoryTheory.Pseudofunctor.mapId
  CategoryTheory.Pseudofunctor.mapComp
  CategoryTheory.Pseudofunctor.map₂_id
  CategoryTheory.Pseudofunctor.map₂_comp
  CategoryTheory.Pseudofunctor.map₂_whisker_left
  CategoryTheory.Pseudofunctor.map₂_whisker_right
  CategoryTheory.Pseudofunctor.map₂_associator
  CategoryTheory.Pseudofunctor.map₂_left_unitor
  CategoryTheory.Pseudofunctor.map₂_right_unitor

instance hasCoeToPrelaxFunctor : Coe (Pseudofunctor B C) (PrelaxFunctor B C) :=
  ⟨toPrelaxFunctor⟩
#align category_theory.pseudofunctor.has_coe_to_prelax_functor CategoryTheory.Pseudofunctor.hasCoeToPrelaxFunctor

variable (F : Pseudofunctor B C)

-- porting note: `toPrelaxFunctor_eq_coe` and `to_prelaxFunctor_obj`
-- are syntactic tautologies in lean 4
#noalign category_theory.pseudofunctor.to_prelax_functor_eq_coe
#noalign category_theory.pseudofunctor.to_prelax_functor_obj

--porting note: removed lemma `to_prelaxFunctor_map` relating the now
-- nonexistent `PrelaxFunctor.map` and the now nonexistent `Pseudofunctor.map`
#noalign category_theory.pseudofunctor.to_prelax_functor_map

--porting note: removed lemma `to_prelaxFunctor_map₂` relating
-- `PrelaxFunctor.map₂` to nonexistent `Pseudofunctor.map₂`
#noalign category_theory.pseudofunctor.to_prelax_functor_map₂

/-- The oplax functor associated with a pseudofunctor. -/
def toOplax : OplaxFunctor B C :=
  { (F : PrelaxFunctor B C) with
    mapId := fun a => (F.mapId a).hom
    mapComp := fun f g => (F.mapComp f g).hom }
#align category_theory.pseudofunctor.to_oplax CategoryTheory.Pseudofunctor.toOplax

instance hasCoeToOplax : Coe (Pseudofunctor B C) (OplaxFunctor B C) :=
  ⟨toOplax⟩
#align category_theory.pseudofunctor.has_coe_to_oplax CategoryTheory.Pseudofunctor.hasCoeToOplax

-- porting note: `toOplax_eq_coe` is a syntactic tautology in lean 4
#noalign category_theory.pseudofunctor.to_oplax_eq_coe

@[simp]
theorem to_oplax_obj : (F : OplaxFunctor B C).obj = F.obj :=
  rfl
#align category_theory.pseudofunctor.to_oplax_obj CategoryTheory.Pseudofunctor.to_oplax_obj

-- porting note: to_oplax_map related `OplaxFunctor.map` to `Pseudofunctor.map` but neither
-- of these exist
#noalign category_theory.pseudofunctor.to_oplax_map

-- porting note: to_oplax_map₂ related `OplaxFunctor.map₂` to `Pseudofunctor.map₂` but neither
-- of these exist
#noalign category_theory.pseudofunctor.to_oplax_map₂

@[simp]
theorem to_oplax_mapId (a : B) : (F : OplaxFunctor B C).mapId a = (F.mapId a).hom :=
  rfl
#align category_theory.pseudofunctor.to_oplax_map_id CategoryTheory.Pseudofunctor.to_oplax_mapId

@[simp]
theorem to_oplax_mapComp {a b c : B} (f : a ⟶ b) (g : b ⟶ c) :
    (F : OplaxFunctor B C).mapComp f g = (F.mapComp f g).hom :=
  rfl
#align category_theory.pseudofunctor.to_oplax_map_comp CategoryTheory.Pseudofunctor.to_oplax_mapComp

-- porting note: I changed `simps` to `simps!` without understanding what I was doing
-- (lean 4 told me to do this)
/-- Function on 1-morphisms as a functor. -/
@[simps!]
def mapFunctor (a b : B) : (a ⟶ b) ⥤ (F.obj a ⟶ F.obj b) :=
  (F : OplaxFunctor B C).mapFunctor a b
#align category_theory.pseudofunctor.map_functor CategoryTheory.Pseudofunctor.mapFunctor

/-- The identity pseudofunctor. -/
@[simps]
def id (B : Type u₁) [Bicategory.{w₁, v₁} B] : Pseudofunctor B B :=
  { PrelaxFunctor.id B with
    mapId := fun a => Iso.refl (𝟙 a)
    mapComp := fun f g => Iso.refl (f ≫ g) }
#align category_theory.pseudofunctor.id CategoryTheory.Pseudofunctor.id

instance : Inhabited (Pseudofunctor B B) :=
  ⟨id B⟩

-- porting note: this is aesop_cat taking a long time auto-filling in fields
set_option maxHeartbeats 500000 in
/-- Composition of pseudofunctors. -/
@[simps]
def comp (F : Pseudofunctor B C) (G : Pseudofunctor C D) : Pseudofunctor B D :=
  {
    (F : PrelaxFunctor B C).comp
      (G : PrelaxFunctor C D) with
    mapId := fun a => (G.mapFunctor _ _).mapIso (F.mapId a) ≪≫ G.mapId (F.obj a)
    mapComp := fun f g =>
      (G.mapFunctor _ _).mapIso (F.mapComp f g) ≪≫ G.mapComp (F.map f) (F.map g) }
#align category_theory.pseudofunctor.comp CategoryTheory.Pseudofunctor.comp

/-- Construct a pseudofunctor from an oplax functor whose `mapId` and `mapComp` are isomorphisms.
-/
@[simps]
def mkOfOplax (F : OplaxFunctor B C) (F' : F.PseudoCore) : Pseudofunctor B C :=
  { (F : PrelaxFunctor B C) with
    mapId := F'.mapIdIso
    mapComp := F'.mapCompIso
    map₂_whisker_left := fun f g h η => by
      dsimp
      rw [F'.mapCompIso_hom f g, ← F.mapComp_naturality_right_assoc, ← F'.mapCompIso_hom f h,
        hom_inv_id, comp_id]
    map₂_whisker_right := fun η h => by
      dsimp
      rw [F'.mapCompIso_hom _ h, ← F.mapComp_naturality_left_assoc, ← F'.mapCompIso_hom _ h,
        hom_inv_id, comp_id]
    map₂_associator := fun f g h => by
      dsimp
      rw [F'.mapCompIso_hom (f ≫ g) h, F'.mapCompIso_hom f g, ← F.map₂_associator_assoc, ←
        F'.mapCompIso_hom f (g ≫ h), ← F'.mapCompIso_hom g h, hom_inv_whiskerLeft_assoc,
        hom_inv_id, comp_id] }
#align category_theory.pseudofunctor.mk_of_oplax CategoryTheory.Pseudofunctor.mkOfOplax

/-- Construct a pseudofunctor from an oplax functor whose `mapId` and `mapComp` are isomorphisms.
-/
@[simps]
noncomputable def mkOfOplax' (F : OplaxFunctor B C) [∀ a, IsIso (F.mapId a)]
    [∀ {a b c} (f : a ⟶ b) (g : b ⟶ c), IsIso (F.mapComp f g)] : Pseudofunctor B C :=
  { (F : PrelaxFunctor B C) with
    mapId := fun a => asIso (F.mapId a)
    mapComp := fun f g => asIso (F.mapComp f g)
    map₂_whisker_left := fun f g h η => by
      dsimp
      rw [← assoc, IsIso.eq_comp_inv, F.mapComp_naturality_right]
    map₂_whisker_right := fun η h => by
      dsimp
      rw [← assoc, IsIso.eq_comp_inv, F.mapComp_naturality_left]
    map₂_associator := fun f g h => by
      dsimp
      simp only [← assoc]
      rw [IsIso.eq_comp_inv, ← inv_whiskerLeft, IsIso.eq_comp_inv]
      simp only [assoc, F.map₂_associator] }
#align category_theory.pseudofunctor.mk_of_oplax' CategoryTheory.Pseudofunctor.mkOfOplax'

end

end Pseudofunctor

end

end CategoryTheory