/-
Copyright (c) 2017 Johannes Hölzl. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Author: Johannes Hölzl
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.order.complete_lattice
import Mathlib.order.rel_iso
import Mathlib.PostPort

universes u v x w u_1 u_2 l

namespace Mathlib

/-!
# Galois connections, insertions and coinsertions

Galois connections are order theoretic adjoints, i.e. a pair of functions `u` and `l`,
  such that `∀a b, l a ≤ b ↔ a ≤ u b`.

## Main definitions

* `galois_connection`: A Galois connection is a pair of functions `l` and `u` satisfying
  `l a ≤ b ↔ a ≤ u b`. They are special cases of  adjoint functors in category theory,
  but do not depend on the category theory library in mathlib.
* `galois_insertion`: A Galois insertion is a Galois connection where `l ∘ u = id`
* `galois_coinsertion`: A Galois coinsertion is a Galois connection where `u ∘ l = id`

## Implementation details

Galois insertions can be used to lift order structures from one type to another.
For example if `α` is a complete lattice, and `l : α → β`, and `u : β → α` form
a Galois insertion, then `β` is also a complete lattice. `l` is the lower adjoint and
`u` is the upper adjoint.

An example of this is the Galois insertion is in group thery. If `G` is a topological space,
then there is a Galois insertion between the set of subsets of `G`, `set G`, and the
set of subgroups of `G`, `subgroup G`. The left adjoint is `subgroup.closure`,
taking the `subgroup` generated by a `set`, The right adjoint is the coercion from `subgroup G` to
`set G`, taking the underlying set of an subgroup.

Naively lifting a lattice structure along this Galois insertion would mean that the definition
of `inf` on subgroups would be `subgroup.closure (↑S ∩ ↑T)`. This is an undesirable definition
because the intersection of subgroups is already a subgroup, so there is no need to take the
closure. For this reason a `choice` function is added as a field to the `galois_insertion`
structure. It has type `Π S : set G, ↑(closure S) ≤ S → subgroup G`. When `↑(closure S) ≤ S`, then
`S` is already a subgroup, so this function can be defined using `subgroup.mk` and not `closure`.
This means the infimum of subgroups will be defined to be the intersection of sets, paired
with a proof that intersection of subgroups is a subgroup, rather than the closure of the
intersection.

-/

/-- A Galois connection is a pair of functions `l` and `u` satisfying
  `l a ≤ b ↔ a ≤ u b`. They are special cases of  adjoint functors in category theory,
    but do not depend on the category theory library in mathlib. -/
def galois_connection {α : Type u} {β : Type v} [preorder α] [preorder β] (l : α → β) (u : β → α) :=
  ∀ (a : α) (b : β), l a ≤ b ↔ a ≤ u b

/-- Makes a Galois connection from an order-preserving bijection. -/
theorem order_iso.to_galois_connection {α : Type u} {β : Type v} [preorder α] [preorder β] (oi : α ≃o β) : galois_connection ⇑oi ⇑(order_iso.symm oi) :=
  fun (b : α) (g : β) => iff.symm (rel_iso.rel_symm_apply oi)

namespace galois_connection

theorem monotone_intro {α : Type u} {β : Type v} [preorder α] [preorder β] {l : α → β} {u : β → α} (hu : monotone u) (hl : monotone l) (hul : ∀ (a : α), a ≤ u (l a)) (hlu : ∀ (a : β), l (u a) ≤ a) : galois_connection l u :=
  fun (a : α) (b : β) =>
    { mp := fun (h : l a ≤ b) => le_trans (hul a) (hu h), mpr := fun (h : a ≤ u b) => le_trans (hl h) (hlu b) }

theorem l_le {α : Type u} {β : Type v} [preorder α] [preorder β] {l : α → β} {u : β → α} (gc : galois_connection l u) {a : α} {b : β} : a ≤ u b → l a ≤ b :=
  iff.mpr (gc a b)

theorem le_u {α : Type u} {β : Type v} [preorder α] [preorder β] {l : α → β} {u : β → α} (gc : galois_connection l u) {a : α} {b : β} : l a ≤ b → a ≤ u b :=
  iff.mp (gc a b)

theorem le_u_l {α : Type u} {β : Type v} [preorder α] [preorder β] {l : α → β} {u : β → α} (gc : galois_connection l u) (a : α) : a ≤ u (l a) :=
  le_u gc (le_refl (l a))

theorem l_u_le {α : Type u} {β : Type v} [preorder α] [preorder β] {l : α → β} {u : β → α} (gc : galois_connection l u) (a : β) : l (u a) ≤ a :=
  l_le gc (le_refl (u a))

theorem monotone_u {α : Type u} {β : Type v} [preorder α] [preorder β] {l : α → β} {u : β → α} (gc : galois_connection l u) : monotone u :=
  fun (a b : β) (H : a ≤ b) => le_u gc (le_trans (l_u_le gc a) H)

theorem monotone_l {α : Type u} {β : Type v} [preorder α] [preorder β] {l : α → β} {u : β → α} (gc : galois_connection l u) : monotone l :=
  fun (a b : α) (H : a ≤ b) => l_le gc (le_trans H (le_u_l gc b))

theorem upper_bounds_l_image_subset {α : Type u} {β : Type v} [preorder α] [preorder β] {l : α → β} {u : β → α} (gc : galois_connection l u) {s : set α} : upper_bounds (l '' s) ⊆ u ⁻¹' upper_bounds s :=
  fun (b : β) (hb : b ∈ upper_bounds (l '' s)) (c : α) (this : c ∈ s) => le_u gc (hb (set.mem_image_of_mem l this))

theorem lower_bounds_u_image_subset {α : Type u} {β : Type v} [preorder α] [preorder β] {l : α → β} {u : β → α} (gc : galois_connection l u) {s : set β} : lower_bounds (u '' s) ⊆ l ⁻¹' lower_bounds s :=
  fun (a : α) (ha : a ∈ lower_bounds (u '' s)) (c : β) (this : c ∈ s) => l_le gc (ha (set.mem_image_of_mem u this))

theorem is_lub_l_image {α : Type u} {β : Type v} [preorder α] [preorder β] {l : α → β} {u : β → α} (gc : galois_connection l u) {s : set α} {a : α} (h : is_lub s a) : is_lub (l '' s) (l a) := sorry

theorem is_glb_u_image {α : Type u} {β : Type v} [preorder α] [preorder β] {l : α → β} {u : β → α} (gc : galois_connection l u) {s : set β} {b : β} (h : is_glb s b) : is_glb (u '' s) (u b) := sorry

theorem is_glb_l {α : Type u} {β : Type v} [preorder α] [preorder β] {l : α → β} {u : β → α} (gc : galois_connection l u) {a : α} : is_glb (set_of fun (b : β) => a ≤ u b) (l a) :=
  { left := fun (b : β) => l_le gc,
    right := fun (b : β) (h : b ∈ lower_bounds (set_of fun (b : β) => a ≤ u b)) => h (le_u_l gc a) }

theorem is_lub_u {α : Type u} {β : Type v} [preorder α] [preorder β] {l : α → β} {u : β → α} (gc : galois_connection l u) {b : β} : is_lub (set_of fun (a : α) => l a ≤ b) (u b) :=
  { left := fun (b_1 : α) => le_u gc,
    right := fun (b_1 : α) (h : b_1 ∈ upper_bounds (set_of fun (a : α) => l a ≤ b)) => h (l_u_le gc b) }

theorem u_l_u_eq_u {α : Type u} {β : Type v} [partial_order α] [partial_order β] {l : α → β} {u : β → α} (gc : galois_connection l u) : u ∘ l ∘ u = u :=
  funext fun (x : β) => le_antisymm (monotone_u gc (l_u_le gc x)) (le_u_l gc (u x))

theorem l_u_l_eq_l {α : Type u} {β : Type v} [partial_order α] [partial_order β] {l : α → β} {u : β → α} (gc : galois_connection l u) : l ∘ u ∘ l = l :=
  funext fun (x : α) => le_antisymm (l_u_le gc (l x)) (monotone_l gc (le_u_l gc x))

theorem l_unique {α : Type u} {β : Type v} [partial_order α] [partial_order β] {l : α → β} {u : β → α} (gc : galois_connection l u) {l' : α → β} {u' : β → α} (gc' : galois_connection l' u') (hu : ∀ (b : β), u b = u' b) {a : α} : l a = l' a :=
  le_antisymm (l_le gc (Eq.symm (hu (l' a)) ▸ le_u_l gc' a)) (l_le gc' (hu (l a) ▸ le_u_l gc a))

theorem u_unique {α : Type u} {β : Type v} [partial_order α] [partial_order β] {l : α → β} {u : β → α} (gc : galois_connection l u) {l' : α → β} {u' : β → α} (gc' : galois_connection l' u') (hl : ∀ (a : α), l a = l' a) {b : β} : u b = u' b :=
  le_antisymm (le_u gc' (hl (u b) ▸ l_u_le gc b)) (le_u gc (Eq.symm (hl (u' b)) ▸ l_u_le gc' b))

theorem u_top {α : Type u} {β : Type v} [order_top α] [order_top β] {l : α → β} {u : β → α} (gc : galois_connection l u) : u ⊤ = ⊤ := sorry

theorem l_bot {α : Type u} {β : Type v} [order_bot α] [order_bot β] {l : α → β} {u : β → α} (gc : galois_connection l u) : l ⊥ = ⊥ := sorry

theorem l_sup {α : Type u} {β : Type v} {a₁ : α} {a₂ : α} [semilattice_sup α] [semilattice_sup β] {l : α → β} {u : β → α} (gc : galois_connection l u) : l (a₁ ⊔ a₂) = l a₁ ⊔ l a₂ := sorry

theorem u_inf {α : Type u} {β : Type v} {b₁ : β} {b₂ : β} [semilattice_inf α] [semilattice_inf β] {l : α → β} {u : β → α} (gc : galois_connection l u) : u (b₁ ⊓ b₂) = u b₁ ⊓ u b₂ := sorry

theorem l_supr {α : Type u} {β : Type v} {ι : Sort x} [complete_lattice α] [complete_lattice β] {l : α → β} {u : β → α} (gc : galois_connection l u) {f : ι → α} : l (supr f) = supr fun (i : ι) => l (f i) := sorry

theorem u_infi {α : Type u} {β : Type v} {ι : Sort x} [complete_lattice α] [complete_lattice β] {l : α → β} {u : β → α} (gc : galois_connection l u) {f : ι → β} : u (infi f) = infi fun (i : ι) => u (f i) := sorry

theorem l_Sup {α : Type u} {β : Type v} [complete_lattice α] [complete_lattice β] {l : α → β} {u : β → α} (gc : galois_connection l u) {s : set α} : l (Sup s) = supr fun (a : α) => supr fun (H : a ∈ s) => l a := sorry

theorem u_Inf {α : Type u} {β : Type v} [complete_lattice α] [complete_lattice β] {l : α → β} {u : β → α} (gc : galois_connection l u) {s : set β} : u (Inf s) = infi fun (a : β) => infi fun (H : a ∈ s) => u a := sorry

/- Constructing Galois connections -/

protected theorem id {α : Type u} [pα : preorder α] : galois_connection id id :=
  fun (a b : α) => { mp := fun (x : id a ≤ b) => x, mpr := fun (x : a ≤ id b) => x }

protected theorem compose {α : Type u} {β : Type v} {γ : Type w} [preorder α] [preorder β] [preorder γ] (l1 : α → β) (u1 : β → α) (l2 : β → γ) (u2 : γ → β) (gc1 : galois_connection l1 u1) (gc2 : galois_connection l2 u2) : galois_connection (l2 ∘ l1) (u1 ∘ u2) := sorry

protected theorem dual {α : Type u} {β : Type v} [pα : preorder α] [pβ : preorder β] {l : α → β} {u : β → α} (gc : galois_connection l u) : galois_connection u l :=
  fun (a : order_dual β) (b : order_dual α) => iff.symm (gc b a)

protected theorem dfun {ι : Type u} {α : ι → Type v} {β : ι → Type w} [(i : ι) → preorder (α i)] [(i : ι) → preorder (β i)] (l : (i : ι) → α i → β i) (u : (i : ι) → β i → α i) (gc : ∀ (i : ι), galois_connection (l i) (u i)) : galois_connection (fun (a : (i : ι) → α i) (i : ι) => l i (a i)) fun (b : (i : ι) → β i) (i : ι) => u i (b i) :=
  fun (a : (i : ι) → α i) (b : (i : ι) → β i) => forall_congr fun (i : ι) => gc i (a i) (b i)

end galois_connection

namespace nat

theorem galois_connection_mul_div {k : ℕ} (h : 0 < k) : galois_connection (fun (n : ℕ) => n * k) fun (n : ℕ) => n / k :=
  fun (x y : ℕ) => iff.symm (le_div_iff_mul_le x y h)

end nat

/-- A Galois insertion is a Galois connection where `l ∘ u = id`. It also contains a constructive
choice function, to give better definitional equalities when lifting order structures. Dual
to `galois_coinsertion` -/
structure galois_insertion {α : Type u_1} {β : Type u_2} [preorder α] [preorder β] (l : α → β) (u : β → α)
where
  choice : (x : α) → u (l x) ≤ x → β
  gc : galois_connection l u
  le_l_u : ∀ (x : β), x ≤ l (u x)
  choice_eq : ∀ (a : α) (h : u (l a) ≤ a), choice a h = l a

/-- A constructor for a Galois insertion with the trivial `choice` function. -/
def galois_insertion.monotone_intro {α : Type u_1} {β : Type u_2} [preorder α] [preorder β] {l : α → β} {u : β → α} (hu : monotone u) (hl : monotone l) (hul : ∀ (a : α), a ≤ u (l a)) (hlu : ∀ (b : β), l (u b) = b) : galois_insertion l u :=
  galois_insertion.mk (fun (x : α) (_x : u (l x) ≤ x) => l x) sorry sorry sorry

/-- Makes a Galois insertion from an order-preserving bijection. -/
protected def rel_iso.to_galois_insertion {α : Type u} {β : Type v} [preorder α] [preorder β] (oi : α ≃o β) : galois_insertion ⇑oi ⇑(order_iso.symm oi) :=
  galois_insertion.mk (fun (b : α) (h : coe_fn (order_iso.symm oi) (coe_fn oi b) ≤ b) => coe_fn oi b)
    (order_iso.to_galois_connection oi) sorry sorry

/-- Make a `galois_insertion l u` from a `galois_connection l u` such that `∀ b, b ≤ l (u b)` -/
def galois_connection.to_galois_insertion {α : Type u_1} {β : Type u_2} [preorder α] [preorder β] {l : α → β} {u : β → α} (gc : galois_connection l u) (h : ∀ (b : β), b ≤ l (u b)) : galois_insertion l u :=
  galois_insertion.mk (fun (x : α) (_x : u (l x) ≤ x) => l x) gc h sorry

/-- Lift the bottom along a Galois connection -/
def galois_connection.lift_order_bot {α : Type u_1} {β : Type u_2} [order_bot α] [partial_order β] {l : α → β} {u : β → α} (gc : galois_connection l u) : order_bot β :=
  order_bot.mk (l ⊥) partial_order.le partial_order.lt partial_order.le_refl partial_order.le_trans
    partial_order.le_antisymm sorry

namespace galois_insertion

theorem l_u_eq {α : Type u} {β : Type v} {l : α → β} {u : β → α} [preorder α] [partial_order β] (gi : galois_insertion l u) (b : β) : l (u b) = b :=
  le_antisymm (galois_connection.l_u_le (gc gi) b) (le_l_u gi b)

theorem l_surjective {α : Type u} {β : Type v} {l : α → β} {u : β → α} [preorder α] [partial_order β] (gi : galois_insertion l u) : function.surjective l :=
  fun (b : β) => Exists.intro (u b) (l_u_eq gi b)

theorem u_injective {α : Type u} {β : Type v} {l : α → β} {u : β → α} [preorder α] [partial_order β] (gi : galois_insertion l u) : function.injective u :=
  fun (a b : β) (h : u a = u b) => Eq.trans (Eq.trans (Eq.symm (l_u_eq gi a)) (congr_arg l h)) (l_u_eq gi b)

theorem l_sup_u {α : Type u} {β : Type v} {l : α → β} {u : β → α} [semilattice_sup α] [semilattice_sup β] (gi : galois_insertion l u) (a : β) (b : β) : l (u a ⊔ u b) = a ⊔ b := sorry

theorem l_supr_u {α : Type u} {β : Type v} {l : α → β} {u : β → α} [complete_lattice α] [complete_lattice β] (gi : galois_insertion l u) {ι : Sort x} (f : ι → β) : l (supr fun (i : ι) => u (f i)) = supr fun (i : ι) => f i :=
  Eq.trans (galois_connection.l_supr (gc gi)) (congr_arg supr (funext fun (i : ι) => l_u_eq gi (f i)))

theorem l_supr_of_ul_eq_self {α : Type u} {β : Type v} {l : α → β} {u : β → α} [complete_lattice α] [complete_lattice β] (gi : galois_insertion l u) {ι : Sort x} (f : ι → α) (hf : ∀ (i : ι), u (l (f i)) = f i) : l (supr fun (i : ι) => f i) = supr fun (i : ι) => l (f i) := sorry

theorem l_inf_u {α : Type u} {β : Type v} {l : α → β} {u : β → α} [semilattice_inf α] [semilattice_inf β] (gi : galois_insertion l u) (a : β) (b : β) : l (u a ⊓ u b) = a ⊓ b := sorry

theorem l_infi_u {α : Type u} {β : Type v} {l : α → β} {u : β → α} [complete_lattice α] [complete_lattice β] (gi : galois_insertion l u) {ι : Sort x} (f : ι → β) : l (infi fun (i : ι) => u (f i)) = infi fun (i : ι) => f i :=
  Eq.trans (congr_arg l (Eq.symm (galois_connection.u_infi (gc gi)))) (l_u_eq gi (infi fun (i : ι) => f i))

theorem l_infi_of_ul_eq_self {α : Type u} {β : Type v} {l : α → β} {u : β → α} [complete_lattice α] [complete_lattice β] (gi : galois_insertion l u) {ι : Sort x} (f : ι → α) (hf : ∀ (i : ι), u (l (f i)) = f i) : l (infi fun (i : ι) => f i) = infi fun (i : ι) => l (f i) := sorry

theorem u_le_u_iff {α : Type u} {β : Type v} {l : α → β} {u : β → α} [preorder α] [preorder β] (gi : galois_insertion l u) {a : β} {b : β} : u a ≤ u b ↔ a ≤ b :=
  { mp := fun (h : u a ≤ u b) => le_trans (le_l_u gi a) (galois_connection.l_le (gc gi) h),
    mpr := fun (h : a ≤ b) => galois_connection.monotone_u (gc gi) h }

theorem strict_mono_u {α : Type u} {β : Type v} {l : α → β} {u : β → α} [preorder α] [partial_order β] (gi : galois_insertion l u) : strict_mono u :=
  strict_mono_of_le_iff_le fun (_x _x_1 : β) => iff.symm (u_le_u_iff gi)

/-- Lift the suprema along a Galois insertion -/
def lift_semilattice_sup {α : Type u} {β : Type v} {l : α → β} {u : β → α} [partial_order β] [semilattice_sup α] (gi : galois_insertion l u) : semilattice_sup β :=
  semilattice_sup.mk (fun (a b : β) => l (u a ⊔ u b)) partial_order.le partial_order.lt partial_order.le_refl
    partial_order.le_trans partial_order.le_antisymm sorry sorry sorry

/-- Lift the infima along a Galois insertion -/
def lift_semilattice_inf {α : Type u} {β : Type v} {l : α → β} {u : β → α} [partial_order β] [semilattice_inf α] (gi : galois_insertion l u) : semilattice_inf β :=
  semilattice_inf.mk (fun (a b : β) => choice gi (u a ⊓ u b) sorry) partial_order.le partial_order.lt
    partial_order.le_refl partial_order.le_trans partial_order.le_antisymm sorry sorry sorry

/-- Lift the suprema and infima along a Galois insertion -/
def lift_lattice {α : Type u} {β : Type v} {l : α → β} {u : β → α} [partial_order β] [lattice α] (gi : galois_insertion l u) : lattice β :=
  lattice.mk semilattice_sup.sup semilattice_sup.le semilattice_sup.lt sorry sorry sorry sorry sorry sorry
    semilattice_inf.inf sorry sorry sorry

/-- Lift the top along a Galois insertion -/
def lift_order_top {α : Type u} {β : Type v} {l : α → β} {u : β → α} [partial_order β] [order_top α] (gi : galois_insertion l u) : order_top β :=
  order_top.mk (choice gi ⊤ sorry) partial_order.le partial_order.lt partial_order.le_refl partial_order.le_trans
    partial_order.le_antisymm sorry

/-- Lift the top, bottom, suprema, and infima along a Galois insertion -/
def lift_bounded_lattice {α : Type u} {β : Type v} {l : α → β} {u : β → α} [partial_order β] [bounded_lattice α] (gi : galois_insertion l u) : bounded_lattice β :=
  bounded_lattice.mk lattice.sup lattice.le lattice.lt sorry sorry sorry sorry sorry sorry lattice.inf sorry sorry sorry
    order_top.top sorry order_bot.bot sorry

/-- Lift all suprema and infima along a Galois insertion -/
def lift_complete_lattice {α : Type u} {β : Type v} {l : α → β} {u : β → α} [partial_order β] [complete_lattice α] (gi : galois_insertion l u) : complete_lattice β :=
  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
    (fun (s : set β) => l (supr fun (b : β) => supr fun (H : b ∈ s) => u b))
    (fun (s : set β) => choice gi (infi fun (b : β) => infi fun (H : b ∈ s) => u b) sorry) sorry sorry sorry sorry

end galois_insertion

/-- A Galois coinsertion is a Galois connection where `u ∘ l = id`. It also contains a constructive
choice function, to give better definitional equalities when lifting order structures. Dual to
`galois_insertion` -/
structure galois_coinsertion {α : Type u_1} {β : Type u_2} [preorder α] [preorder β] (l : α → β) (u : β → α)
where
  choice : (x : β) → x ≤ l (u x) → α
  gc : galois_connection l u
  u_l_le : ∀ (x : α), u (l x) ≤ x
  choice_eq : ∀ (a : β) (h : a ≤ l (u a)), choice a h = u a

/-- Make a `galois_insertion u l` in the `order_dual`, from a `galois_coinsertion l u` -/
def galois_coinsertion.dual {α : Type u_1} {β : Type u_2} [preorder α] [preorder β] {l : α → β} {u : β → α} : galois_coinsertion l u → galois_insertion u l :=
  fun (x : galois_coinsertion l u) =>
    galois_insertion.mk (galois_coinsertion.choice x) sorry (galois_coinsertion.u_l_le x) (galois_coinsertion.choice_eq x)

/-- Make a `galois_coinsertion u l` in the `order_dual`, from a `galois_insertion l u` -/
def galois_insertion.dual {α : Type u_1} {β : Type u_2} [preorder α] [preorder β] {l : α → β} {u : β → α} : galois_insertion l u → galois_coinsertion u l :=
  fun (x : galois_insertion l u) =>
    galois_coinsertion.mk (galois_insertion.choice x) sorry (galois_insertion.le_l_u x) (galois_insertion.choice_eq x)

/-- Make a `galois_coinsertion l u` from a `galois_insertion l u` in the `order_dual` -/
def galois_coinsertion.of_dual {α : Type u_1} {β : Type u_2} [preorder α] [preorder β] {l : α → β} {u : β → α} : galois_insertion u l → galois_coinsertion l u :=
  fun (x : galois_insertion u l) => galois_coinsertion.mk (galois_insertion.choice x) sorry sorry sorry

/-- Make a `galois_insertion l u` from a `galois_coinsertion l u` in the `order_dual` -/
def galois_insertion.of_dual {α : Type u_1} {β : Type u_2} [preorder α] [preorder β] {l : α → β} {u : β → α} : galois_coinsertion u l → galois_insertion l u :=
  fun (x : galois_coinsertion u l) => galois_insertion.mk (galois_coinsertion.choice x) sorry sorry sorry

/-- Makes a Galois coinsertion from an order-preserving bijection. -/
protected def rel_iso.to_galois_coinsertion {α : Type u} {β : Type v} [preorder α] [preorder β] (oi : α ≃o β) : galois_coinsertion ⇑oi ⇑(order_iso.symm oi) :=
  galois_coinsertion.mk (fun (b : β) (h : b ≤ coe_fn oi (coe_fn (order_iso.symm oi) b)) => coe_fn (order_iso.symm oi) b)
    (order_iso.to_galois_connection oi) sorry sorry

/-- A constructor for a Galois coinsertion with the trivial `choice` function. -/
def galois_coinsertion.monotone_intro {α : Type u_1} {β : Type u_2} [preorder α] [preorder β] {l : α → β} {u : β → α} (hu : monotone u) (hl : monotone l) (hlu : ∀ (b : β), l (u b) ≤ b) (hul : ∀ (a : α), u (l a) = a) : galois_coinsertion l u :=
  galois_coinsertion.of_dual (galois_insertion.monotone_intro (monotone.order_dual hl) (monotone.order_dual hu) hlu hul)

/-- Make a `galois_coinsertion l u` from a `galois_connection l u` such that `∀ b, b ≤ l (u b)` -/
def galois_connection.to_galois_coinsertion {α : Type u_1} {β : Type u_2} [preorder α] [preorder β] {l : α → β} {u : β → α} (gc : galois_connection l u) (h : ∀ (a : α), u (l a) ≤ a) : galois_coinsertion l u :=
  galois_coinsertion.mk (fun (x : β) (_x : x ≤ l (u x)) => u x) gc h sorry

/-- Lift the top along a Galois connection -/
def galois_connection.lift_order_top {α : Type u_1} {β : Type u_2} [partial_order α] [order_top β] {l : α → β} {u : β → α} (gc : galois_connection l u) : order_top α :=
  order_top.mk (u ⊤) partial_order.le partial_order.lt partial_order.le_refl partial_order.le_trans
    partial_order.le_antisymm sorry

namespace galois_coinsertion

theorem u_l_eq {α : Type u} {β : Type v} {l : α → β} {u : β → α} [partial_order α] [preorder β] (gi : galois_coinsertion l u) (a : α) : u (l a) = a :=
  galois_insertion.l_u_eq (dual gi) a

theorem u_surjective {α : Type u} {β : Type v} {l : α → β} {u : β → α} [partial_order α] [preorder β] (gi : galois_coinsertion l u) : function.surjective u :=
  galois_insertion.l_surjective (dual gi)

theorem l_injective {α : Type u} {β : Type v} {l : α → β} {u : β → α} [partial_order α] [preorder β] (gi : galois_coinsertion l u) : function.injective l :=
  galois_insertion.u_injective (dual gi)

theorem u_inf_l {α : Type u} {β : Type v} {l : α → β} {u : β → α} [semilattice_inf α] [semilattice_inf β] (gi : galois_coinsertion l u) (a : α) (b : α) : u (l a ⊓ l b) = a ⊓ b :=
  galois_insertion.l_sup_u (dual gi) a b

theorem u_infi_l {α : Type u} {β : Type v} {l : α → β} {u : β → α} [complete_lattice α] [complete_lattice β] (gi : galois_coinsertion l u) {ι : Sort x} (f : ι → α) : u (infi fun (i : ι) => l (f i)) = infi fun (i : ι) => f i :=
  galois_insertion.l_supr_u (dual gi) fun (i : ι) => f i

theorem u_infi_of_lu_eq_self {α : Type u} {β : Type v} {l : α → β} {u : β → α} [complete_lattice α] [complete_lattice β] (gi : galois_coinsertion l u) {ι : Sort x} (f : ι → β) (hf : ∀ (i : ι), l (u (f i)) = f i) : u (infi fun (i : ι) => f i) = infi fun (i : ι) => u (f i) :=
  galois_insertion.l_supr_of_ul_eq_self (dual gi) (fun (i : ι) => f i) hf

theorem u_sup_l {α : Type u} {β : Type v} {l : α → β} {u : β → α} [semilattice_sup α] [semilattice_sup β] (gi : galois_coinsertion l u) (a : α) (b : α) : u (l a ⊔ l b) = a ⊔ b :=
  galois_insertion.l_inf_u (dual gi) a b

theorem u_supr_l {α : Type u} {β : Type v} {l : α → β} {u : β → α} [complete_lattice α] [complete_lattice β] (gi : galois_coinsertion l u) {ι : Sort x} (f : ι → α) : u (supr fun (i : ι) => l (f i)) = supr fun (i : ι) => f i :=
  galois_insertion.l_infi_u (dual gi) fun (i : ι) => f i

theorem u_supr_of_lu_eq_self {α : Type u} {β : Type v} {l : α → β} {u : β → α} [complete_lattice α] [complete_lattice β] (gi : galois_coinsertion l u) {ι : Sort x} (f : ι → β) (hf : ∀ (i : ι), l (u (f i)) = f i) : u (supr fun (i : ι) => f i) = supr fun (i : ι) => u (f i) :=
  galois_insertion.l_infi_of_ul_eq_self (dual gi) (fun (i : ι) => f i) hf

theorem l_le_l_iff {α : Type u} {β : Type v} {l : α → β} {u : β → α} [preorder α] [preorder β] (gi : galois_coinsertion l u) {a : α} {b : α} : l a ≤ l b ↔ a ≤ b :=
  galois_insertion.u_le_u_iff (dual gi)

theorem strict_mono_l {α : Type u} {β : Type v} {l : α → β} {u : β → α} [partial_order α] [preorder β] (gi : galois_coinsertion l u) : strict_mono l :=
  fun (a b : α) (h : a < b) => galois_insertion.strict_mono_u (dual gi) h

/-- Lift the infima along a Galois coinsertion -/
def lift_semilattice_inf {α : Type u} {β : Type v} {l : α → β} {u : β → α} [partial_order α] [semilattice_inf β] (gi : galois_coinsertion l u) : semilattice_inf α :=
  semilattice_inf.mk (fun (a b : α) => u (l a ⊓ l b)) partial_order.le partial_order.lt partial_order.le_refl
    partial_order.le_trans partial_order.le_antisymm sorry sorry sorry

/-- Lift the suprema along a Galois coinsertion -/
def lift_semilattice_sup {α : Type u} {β : Type v} {l : α → β} {u : β → α} [partial_order α] [semilattice_sup β] (gi : galois_coinsertion l u) : semilattice_sup α :=
  semilattice_sup.mk (fun (a b : α) => choice gi (l a ⊔ l b) sorry) partial_order.le partial_order.lt
    partial_order.le_refl partial_order.le_trans partial_order.le_antisymm sorry sorry sorry

/-- Lift the suprema and infima along a Galois coinsertion -/
def lift_lattice {α : Type u} {β : Type v} {l : α → β} {u : β → α} [partial_order α] [lattice β] (gi : galois_coinsertion l u) : lattice α :=
  lattice.mk semilattice_sup.sup semilattice_sup.le semilattice_sup.lt sorry sorry sorry sorry sorry sorry
    semilattice_inf.inf sorry sorry sorry

/-- Lift the bot along a Galois coinsertion -/
def lift_order_bot {α : Type u} {β : Type v} {l : α → β} {u : β → α} [partial_order α] [order_bot β] (gi : galois_coinsertion l u) : order_bot α :=
  order_bot.mk (choice gi ⊥ sorry) partial_order.le partial_order.lt partial_order.le_refl partial_order.le_trans
    partial_order.le_antisymm sorry

/-- Lift the top, bottom, suprema, and infima along a Galois coinsertion -/
def lift_bounded_lattice {α : Type u} {β : Type v} {l : α → β} {u : β → α} [partial_order α] [bounded_lattice β] (gi : galois_coinsertion l u) : bounded_lattice α :=
  bounded_lattice.mk lattice.sup lattice.le lattice.lt sorry sorry sorry sorry sorry sorry lattice.inf sorry sorry sorry
    order_top.top sorry order_bot.bot sorry

/-- Lift all suprema and infima along a Galois coinsertion -/
def lift_complete_lattice {α : Type u} {β : Type v} {l : α → β} {u : β → α} [partial_order α] [complete_lattice β] (gi : galois_coinsertion l u) : complete_lattice α :=
  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
    (fun (s : set α) => choice gi (supr fun (a : α) => supr fun (H : a ∈ s) => l a) sorry)
    (fun (s : set α) => u (infi fun (a : α) => infi fun (H : a ∈ s) => l a)) sorry sorry sorry sorry

end galois_coinsertion

/-- If `α` is a partial order with bottom element (e.g., `ℕ`, `ℝ≥0`), then
`λ o : with_bot α, o.get_or_else ⊥` and coercion form a Galois insertion. -/
def with_bot.gi_get_or_else_bot {α : Type u} [order_bot α] : galois_insertion (fun (o : with_bot α) => option.get_or_else o ⊥) coe :=
  galois_insertion.mk (fun (o : with_bot α) (ho : ↑(option.get_or_else o ⊥) ≤ o) => option.get_or_else o ⊥) sorry sorry
    sorry


import .replace_free
import .misc_list

import data.finset

set_option pp.parens true

open formula

/-
[margaris]
pg. 48

If $v$ and $u$ are variables and $P$ is a formula, then $P$ admits $u$ for $v$ if and only if there is no free occurrence of $v$ in $P$ that becomes a bound occurrence of $u$ in $P(u/v)$. If $t$ is a term, then $P$ admits $t$ for $v$ if and only if $P$ admits for $v$ every variable in $t$.
-/

/--
  Helper function for admits.
-/
def admits_aux (v u : variable_) : finset variable_ → formula → Prop
| _ true_ := true
| binders (pred_ name args) :=
    (v ∈ args ∧ v ∉ binders) → -- if there is a free occurrence of v in P
    u ∉ binders -- then it does not become a bound occurrence of u in P(u/v)
| binders (eq_ x y) :=
    ((v = x ∨ v = y) ∧ (v ∉ binders)) →
    u ∉ binders
| binders (not_ P) := admits_aux binders P
| binders (imp_ P Q) := admits_aux binders P ∧ admits_aux binders Q
| binders (forall_ x P) := admits_aux (binders ∪ {x}) P

/--
  admits v u P := True if and only if there is no free occurrence of the variable v in the formula P that becomes a bound occurrence of the variable u in P(u/v).

  P admits u for v

  v → u in P
-/
def admits (v u : variable_) (P : formula) : Prop :=
  admits_aux v u ∅ P

/--
  Helper function for fast_admits.
-/
def fast_admits_aux (v u : variable_) : finset variable_ → formula → Prop
| _ true_ := true
| binders (pred_ name args) :=
    v ∈ args → -- if there is a free occurrence of v in P
    u ∉ binders -- then it does not become a bound occurrence of u in P(u/v)
| binders (eq_ x y) :=
    (v = x ∨ v = y) →
    u ∉ binders
| binders (not_ P) := fast_admits_aux binders P
| binders (imp_ P Q) := fast_admits_aux binders P ∧ fast_admits_aux binders Q
| binders (forall_ x P) := v = x ∨ fast_admits_aux (binders ∪ {x}) P

/--
  fast_admits v u P := True if and only if there is no free occurrence of the variable v in the formula P that becomes a bound occurrence of the variable u in P(u/v).

  P admits u for v

  v → u in P

  This is a more efficient version of admits.
-/
def fast_admits (v u : variable_) (P : formula) : Prop :=
  fast_admits_aux v u ∅ P

-- admits ↔ fast_admits

lemma admits_aux_imp_fast_admits_aux
  (P : formula)
  (v u : variable_)
  (binders : finset variable_)
  (h1 : v ∉ binders)
  (h2 : admits_aux v u binders P) :
  fast_admits_aux v u binders P :=
begin
  induction P generalizing binders,
  case formula.true_ : binders h1 h2
  {
    unfold fast_admits_aux,
  },
  case [formula.pred_, formula.eq_, formula.not_, formula.imp_]
  {
    all_goals
    {
      unfold admits_aux at h2,

      unfold fast_admits_aux,
      tauto,
    },
  },
  case formula.forall_ : x P P_ih binders h1 h2
  {
    unfold admits_aux at h2,

    unfold fast_admits_aux,
    by_cases c1 : v = x,
    {
      left,
      exact c1,
    },
    {
      right,
      apply P_ih,
      {
        simp only [finset.mem_union, finset.mem_singleton],
        tauto,
      },
      {
        exact h2,
      },
    }
  },
end

lemma mem_binders_imp_admits_aux
  (P : formula)
  (v u : variable_)
  (binders : finset variable_)
  (h1 : v ∈ binders) :
  admits_aux v u binders P :=
begin
  induction P generalizing binders,
  case formula.true_ : binders h1
  {
    unfold admits_aux,
  },
  case [formula.pred_, formula.eq_, formula.not_, formula.imp_]
  {
    all_goals
    {
      unfold admits_aux,
      tauto,
    }
  },
  case formula.forall_ : x P P_ih binders h1
  {
    unfold admits_aux,
    apply P_ih,
    simp only [finset.mem_union, finset.mem_singleton],
    left,
    exact h1,
  },
end

lemma fast_admits_aux_imp_admits_aux
  (P : formula)
  (v u : variable_)
  (binders : finset variable_)
  (h1 : fast_admits_aux v u binders P) :
  admits_aux v u binders P :=
begin
  induction P generalizing binders,
  case formula.true_ : binders h1
  {
    unfold admits_aux,
  },
  case [formula.pred_, formula.eq_, formula.not_, formula.imp_]
  {
    all_goals
    {
      unfold fast_admits_aux at h1,

      unfold admits_aux,
      tauto,
    }
  },
  case formula.forall_ : x P P_ih binders h1
  {
    unfold fast_admits_aux at h1,

    unfold admits_aux,
    cases h1,
    {
      apply mem_binders_imp_admits_aux,
      subst h1,
      simp only [finset.mem_union, finset.mem_singleton, eq_self_iff_true, or_true],
    },
    {
      apply P_ih,
      exact h1,
    }
  },
end

theorem admits_iff_fast_admits
  (P : formula)
  (v u : variable_) :
  admits v u P ↔ fast_admits v u P :=
begin
  unfold admits,
  unfold fast_admits,
  split,
  {
    apply admits_aux_imp_fast_admits_aux,
    simp only [finset.not_mem_empty, not_false_iff],
  },
  {
    apply fast_admits_aux_imp_admits_aux,
  }
end

-- fast_admits

lemma fast_admits_aux_self
  (P : formula)
  (v : variable_)
  (binders : finset variable_)
  (h1 : v ∉ binders) :
  fast_admits_aux v v binders P :=
begin
  induction P generalizing binders,
  case formula.true_ : binders h1
  {
    unfold fast_admits_aux,
  },
  case [formula.pred_, formula.eq_, formula.not_, formula.imp_]
  {
    all_goals
    {
      unfold fast_admits_aux,
      tauto,
    }
  },
  case formula.forall_ : x P P_ih binders h1
  {
    unfold fast_admits_aux,
    by_cases c1 : v = x,
    {
      tauto,
    },
    {
      right,
      apply P_ih,
      simp only [finset.mem_union, finset.mem_singleton],
      tauto,
    }
  },
end

theorem fast_admits_self
  (P : formula)
  (v : variable_) :
  fast_admits v v P :=
begin
  unfold fast_admits,
  apply fast_admits_aux_self,
  simp only [finset.not_mem_empty, not_false_iff],
end

--

lemma not_is_free_in_imp_fast_admits_aux
  (P : formula)
  (v u : variable_)
  (binders : finset variable_)
  (h1 : ¬ is_free_in v P) :
  fast_admits_aux v u binders P :=
begin
  induction P generalizing binders,
  case formula.true_ : binders
  {
    unfold fast_admits_aux,
  },
  case formula.pred_ : name args
  {
    unfold is_free_in at h1,
    simp only [list.mem_to_finset] at h1,

    unfold fast_admits_aux,
    tauto,
  },
  case [formula.eq_, formula.not_, formula.imp_, formula.forall_]
  {
    all_goals
    {
      unfold is_free_in at h1,

      unfold fast_admits_aux,
      tauto,
    }
  },
end

theorem not_is_free_in_imp_fast_admits
  (P : formula)
  (v u : variable_)
  (h1 : ¬ is_free_in v P) :
  fast_admits v u P :=
begin
  unfold fast_admits,
  apply not_is_free_in_imp_fast_admits_aux,
  exact h1,
end

--

lemma not_is_bound_in_imp_fast_admits_aux
  (P : formula)
  (v u : variable_)
  (binders : finset variable_)
  (h1 : ¬ is_bound_in u P)
  (h2 : u ∉ binders) :
  fast_admits_aux v u binders P :=
begin
  induction P generalizing binders,
  case formula.true_ : binders h2
  {
    unfold fast_admits_aux,
  },
  case formula.pred_ : name args binders h2
  {
    unfold fast_admits_aux,
    tauto,
  },
  case formula.eq_ : x y binders h2
  {
    unfold fast_admits_aux,
    tauto,
  },
  case formula.not_ : P P_ih binders h2
  {
    unfold is_bound_in at h1,

    unfold fast_admits_aux,
    tauto,
  },
  case formula.imp_ : P Q P_ih Q_ih binders h2
  {
    unfold is_bound_in at h1,

    unfold fast_admits_aux,
    tauto,
  },
  case formula.forall_ : x P P_ih binders h2
  {
    unfold is_bound_in at h1,
    push_neg at h1,
    cases h1,

    unfold fast_admits_aux,
    right,
    apply P_ih,
    {
      exact h1_right,
    },
    {
      simp only [finset.mem_union, finset.mem_singleton],
      tauto,
    }
  },
end

theorem not_is_bound_in_imp_fast_admits
  (P : formula)
  (v u : variable_)
  (h1 : ¬ is_bound_in u P) :
  fast_admits v u P :=
begin
  unfold fast_admits,
  apply not_is_bound_in_imp_fast_admits_aux,
  {
    exact h1,
  },
  {
    simp only [finset.not_mem_empty, not_false_iff],
  }
end

--

lemma fast_replace_free_aux_fast_admits_aux
  (P : formula)
  (v t : variable_)
  (binders : finset variable_)
  (h1 : ¬ occurs_in t P)
  (h2 : v ∉ binders) :
  fast_admits_aux t v binders (fast_replace_free v t P) :=
begin
  induction P generalizing binders,
  case formula.true_ : binders h2
  {
    unfold fast_replace_free,
  },
  case formula.pred_ : name args binders h2
  {
    unfold fast_replace_free,
    unfold fast_admits_aux,
    tauto,
  },
  case formula.eq_ : x y binders h2
  {
    unfold fast_replace_free,
    unfold fast_admits_aux,
    tauto,
  },
  case formula.not_ : P P_ih binders h2
  {
    unfold occurs_in at h1,

    unfold fast_replace_free,
    unfold fast_admits_aux,
    tauto,
  },
  case formula.imp_ : P Q P_ih Q_ih binders h2
  {
    unfold occurs_in at h1,

    unfold fast_replace_free,
    unfold fast_admits_aux,
    tauto,
  },
  case formula.forall_ : x P P_ih binders h2
  {
    unfold occurs_in at h1,
    push_neg at h1,
    cases h1,

    unfold fast_replace_free,
    split_ifs,
    {
      unfold fast_admits_aux,
      subst h,
      right,
      apply not_is_free_in_imp_fast_admits_aux,
      intros contra,
      apply h1_right,
      apply is_free_in_imp_occurs_in,
      exact contra,
    },
    {
      unfold fast_admits_aux,
      right,
      apply P_ih h1_right,
      simp only [finset.mem_union, finset.mem_singleton],
      tauto,
    },
  },
end

lemma fast_replace_free_fast_admits
  (P : formula)
  (v t : variable_)
  (h1 : ¬ occurs_in t P) :
  fast_admits t v (fast_replace_free v t P) :=
begin
  unfold fast_admits,
  apply fast_replace_free_aux_fast_admits_aux P v t ∅ h1,
  simp only [finset.not_mem_empty, not_false_iff],
end

--

lemma replace_free_aux_fast_admits_aux
  (P : formula)
  (v t : variable_)
  (binders : finset variable_)
  (h1 : ¬ occurs_in t P) :
  fast_admits_aux t v binders (replace_free_aux v t binders P) :=
begin
  induction P generalizing binders,
  case formula.true_ : binders
  {
    unfold replace_free_aux,
  },
  case formula.pred_ : name args binders
  {
    unfold occurs_in at h1,
    simp only [list.mem_to_finset] at h1,

    unfold replace_free_aux,
    unfold fast_admits_aux,
    simp only [list.mem_map, forall_exists_index],
    intros x a1,
    cases a1,

    by_cases c1 : x = v ∧ x ∉ binders,
    {
      cases c1,
      subst c1_left,
      exact c1_right,
    },
    {
      simp only [if_neg c1] at a1_right,
      subst a1_right,
      contradiction,
    }
  },
  case formula.eq_ : x y binders
  {
    unfold occurs_in at h1,
    push_neg at h1,
    cases h1,

    unfold replace_free_aux,
    unfold fast_admits_aux,
    intros a1,
    cases a1,
    {
      by_cases c1 : x = v ∧ x ∉ binders,
      {
        cases c1,
        subst c1_left,
        exact c1_right,
      },
      {
        simp only [if_neg c1] at a1,
        contradiction,
      }
    },
    {
      by_cases c1 : y = v ∧ y ∉ binders,
      {
        cases c1,
        subst c1_left,
        exact c1_right,
      },
      {
        simp only [if_neg c1] at a1,
        contradiction,
      }
    },
  },
  case formula.not_ : P P_ih binders
  {
    unfold occurs_in at h1,

    unfold replace_free_aux,
    unfold fast_admits_aux,
    tauto,
  },
  case formula.imp_ : P Q P_ih Q_ih binders
  {
    unfold occurs_in at h1,

    unfold replace_free_aux,
    unfold fast_admits_aux,
    tauto,
  },
  case formula.forall_ : x P P_ih binders
  {
    unfold occurs_in at h1,

    unfold replace_free_aux,
    unfold fast_admits_aux,
    tauto,
  },
end

lemma replace_free_fast_admits
  (P : formula)
  (v t : variable_)
  (h1 : ¬ occurs_in t P) :
  fast_admits t v (replace_free v t P) :=
begin
  unfold replace_free,
  unfold fast_admits,
  apply replace_free_aux_fast_admits_aux,
  exact h1,
end

--

lemma fast_admits_aux_add_binders
  (P : formula)
  (v u : variable_)
  (S T : finset variable_)
  (h1 : fast_admits_aux v u S P)
  (h2 : u ∉ T) :
  fast_admits_aux v u (S ∪ T) P :=
begin
  induction P generalizing S,
  case formula.true_ : S h1
  {
    unfold fast_admits_aux,
  },
  case formula.pred_ : name args S h1
  {
    unfold fast_admits_aux at h1,

    unfold fast_admits_aux,
    simp only [finset.mem_union],
    tauto,
  },
  case formula.eq_ : x y S h1
  {
    unfold fast_admits_aux at h1,

    unfold fast_admits_aux,
    simp only [finset.mem_union],
    tauto,
  },
  case formula.not_ : P P_ih S h1
  {
    unfold fast_admits_aux at h1,

    unfold fast_admits_aux,
    tauto,
  },
  case formula.imp_ : P Q P_ih Q_ih S h1
  {
    unfold fast_admits_aux at h1,

    unfold fast_admits_aux,
    tauto,
  },
  case formula.forall_ : x P P_ih S h1
  {
    unfold fast_admits_aux at h1,

    unfold fast_admits_aux,
    cases h1,
    {
      tauto,
    },
    {
      right,
      simp only [finset.union_right_comm S T {x}],
      tauto,
    }
  },
end

lemma fast_admits_aux_del_binders
  (P : formula)
  (v u : variable_)
  (S T : finset variable_)
  (h1 : fast_admits_aux v u (S ∪ T) P) :
  fast_admits_aux v u S P :=
begin
  induction P generalizing S,
  case formula.true_ : S h1
  {
    unfold fast_admits_aux,
  },
  case formula.pred_ : name args S h1
  {
    unfold fast_admits_aux at h1,
    simp only [finset.mem_union] at h1,

    unfold fast_admits_aux,
    tauto,
  },
  case formula.eq_ : x y S h1
  {
    unfold fast_admits_aux at h1,
    simp only [finset.mem_union] at h1,

    unfold fast_admits_aux,
    tauto,
  },
  case formula.not_ : P P_ih S h1
  {
    unfold fast_admits_aux at h1,

    unfold fast_admits_aux,
    tauto,
  },
  case formula.imp_ : P Q P_ih Q_ih S h1
  {
    unfold fast_admits_aux at h1,
    cases h1,

    unfold fast_admits_aux,
    tauto,
  },
  case formula.forall_ : x P P_ih S h1
  {
    unfold fast_admits_aux at h1,
    simp only [finset.union_right_comm S T {x}] at h1,

    unfold fast_admits_aux,
    tauto,
  },
end

--

lemma fast_admits_aux_is_free_in
  (P : formula)
  (v u : variable_)
  (binders : finset variable_)
  (h1 : fast_admits_aux v u binders P)
  (h2 : is_free_in v P) :
  u ∉ binders :=
begin
  induction P generalizing binders,
  case formula.true_ : binders h1
  {
    unfold is_free_in at h2,

    contradiction,
  },
  case formula.pred_ : name args binders h1
  {
    unfold fast_admits_aux at h1,

    unfold is_free_in at h2,
    simp only [list.mem_to_finset] at h2,

    tauto,
  },
  case formula.eq_ : x y binders h1
  {
    unfold fast_admits_aux at h1,

    unfold is_free_in at h2,

    tauto,
  },
  case formula.not_ : P P_ih binders h1
  {
    unfold fast_admits_aux at h1,

    unfold is_free_in at h2,

    exact P_ih h2 binders h1,
  },
  case formula.imp_ : P Q P_ih Q_ih binders h1
  {
    unfold fast_admits_aux at h1,
    cases h1,

    unfold is_free_in at h2,

    cases h2,
    {
      exact P_ih h2 binders h1_left,
    },
    {
      exact Q_ih h2 binders h1_right,
    }
  },
  case formula.forall_ : x P P_ih binders h1
  {
    unfold fast_admits_aux at h1,

    unfold is_free_in at h2,
    cases h2,

    apply P_ih h2_right,
    {
      cases h1,
      {
        contradiction,
      },
      {
        apply fast_admits_aux_del_binders P v u binders {x} h1,
      }
    }
  },
end

lemma fast_admits_aux_mem_binders
  (P : formula)
  (v u : variable_)
  (binders : finset variable_)
  (h1 : fast_admits_aux v u binders P)
  (h2 : u ∈ binders) :
  ¬ is_free_in v P :=
begin
  contrapose! h2,
  exact fast_admits_aux_is_free_in P v u binders h1 h2,
end

--

/--
  Used to label each occurrence of a variable in a formula as free or bound.
-/
@[derive [inhabited, decidable_eq]]
inductive bool_formula : Type
| true_ : bool_formula
| pred_ : pred_name_ → list bool → bool_formula
| eq_ : bool → bool → bool_formula
| not_ : bool_formula → bool_formula
| imp_ : bool_formula → bool_formula → bool_formula
| forall_ : bool → bool_formula → bool_formula

/--
  Helper function for to_is_bound.
-/
def to_is_bound_aux : finset variable_ → formula → bool_formula
| _ true_ := bool_formula.true_
| binders (pred_ name args) := bool_formula.pred_ name (args.map (fun (v : variable_), v ∈ binders))
| binders (eq_ x y) := bool_formula.eq_ (x ∈ binders) (y ∈ binders)
| binders (not_ P) := bool_formula.not_ (to_is_bound_aux binders P)
| binders (imp_ P Q) := bool_formula.imp_ (to_is_bound_aux binders P) (to_is_bound_aux binders Q)
| binders (forall_ x P) := bool_formula.forall_ true (to_is_bound_aux (binders ∪ {x}) P)

/--
  Creates a bool_formula from a formula. Each bound occurence of a variable in the formula is mapped to true in the bool formula. Each free occurence of a variable in the formula is mapped to false in the bool formula.
-/
def to_is_bound (P : formula) : bool_formula :=
  to_is_bound_aux ∅ P

lemma fast_admits_aux_imp_free_and_bound_unchanged
  (P : formula)
  (v u : variable_)
  (binders : finset variable_)
  (h1 : v ∉ binders)
  (h2 : fast_admits_aux v u binders P) :
  to_is_bound_aux binders P = to_is_bound_aux binders (fast_replace_free v u P) :=
begin
  induction P generalizing binders,
  case formula.true_ : binders h1 h2
  {
    refl,
  },
  case formula.pred_ : name args binders h1 h2
  {
    induction args,
    case list.nil
    {
      unfold fast_replace_free,
      simp only [list.map_nil],
    },
    case list.cons : args_hd args_tl args_ih
    {
      unfold fast_admits_aux at h2,
      simp only [list.mem_cons_iff] at h2,

      unfold fast_admits_aux at args_ih,
      unfold fast_replace_free at args_ih,
      unfold to_is_bound_aux at args_ih,
      simp only [list.map_map, eq_self_iff_true, true_and] at args_ih,

      unfold fast_replace_free,
      unfold to_is_bound_aux,
      simp only [list.map, list.map_map, eq_self_iff_true, bool.to_bool_eq, true_and],

      split,
      {
        split_ifs,
        {
          subst h,
          tauto,
        },
        {
          refl,
        }
      },
      {
        tauto,
      }
    },
  },
  case formula.eq_ : x y binders h1 h2
  {
    unfold fast_admits_aux at h2,

    unfold fast_replace_free,
    unfold to_is_bound_aux,
    simp only [bool.to_bool_eq],
    split;
    {
      split_ifs,
      {
        subst h,
        tauto,
      },
      {
        refl,
      }
    }
  },
  case formula.not_ : P P_ih binders h1 h2
  {
    unfold fast_admits_aux at h2,

    unfold fast_replace_free,
    unfold to_is_bound_aux,
    congr' 1,
    exact P_ih binders h1 h2,
  },
  case formula.imp_ : P Q P_ih Q_ih binders h1 h2
  {
    unfold fast_admits_aux at h2,
    cases h2,

    unfold fast_replace_free,
    unfold to_is_bound_aux,
    congr' 1,
    {
      exact P_ih binders h1 h2_left,
    },
    {
      exact Q_ih binders h1 h2_right,
    }
  },
  case formula.forall_ : x P P_ih binders h1 h2
  {
    unfold fast_admits_aux at h2,

    unfold fast_replace_free,
    split_ifs,
    {
      refl,
    },
    {
      unfold to_is_bound_aux,
      simp only [eq_self_iff_true, true_and],
      apply P_ih,
      {
        simp only [finset.mem_union, finset.mem_singleton],
        tauto,
      },
      {
        tauto,
      }
    }
  },
end

lemma free_and_bound_unchanged_imp_fast_admits_aux
  (P : formula)
  (v u : variable_)
  (binders : finset variable_)
  (h1 : v ∉ binders)
  (h2 : to_is_bound_aux binders P = to_is_bound_aux binders (fast_replace_free v u P)) :
  fast_admits_aux v u binders P :=
begin
  induction P generalizing binders,
  case formula.true_ : binders h1 h2
  {
    unfold fast_admits_aux,
  },
  case formula.pred_ : name args binders h1 h2
  {
    induction args,
    case list.nil
    {
      unfold fast_admits_aux,
      simp only [list.not_mem_nil, is_empty.forall_iff],
    },
    case list.cons : args_hd args_tl args_ih
    {
      unfold fast_replace_free at h2,
      unfold to_is_bound_aux at h2,
      simp only [list.map, list.map_map, eq_self_iff_true, bool.to_bool_eq, true_and] at h2,
      cases h2,

      unfold fast_admits_aux at args_ih,
      unfold fast_replace_free at args_ih,
      unfold to_is_bound_aux at args_ih,
      simp only [list.map_map, eq_self_iff_true, true_and] at args_ih,

      unfold fast_admits_aux,
      simp only [list.mem_cons_iff],
      intros a1,
      cases a1,
      {
        subst a1,
        simp only [eq_self_iff_true, if_true] at h2_left,
        tauto,
      },
      {
        tauto,
      }
    },
  },
  case formula.eq_ : x y binders h1 h2
  {
    unfold fast_replace_free at h2,
    unfold to_is_bound_aux at h2,
    simp only [bool.to_bool_eq] at h2,
    cases h2,

    unfold fast_admits_aux,
    intros a1 contra,
    cases a1,
    {
      subst a1,
      simp only [eq_self_iff_true, if_true] at h2_left,
      tauto,
    },
    {
      subst a1,
      simp only [eq_self_iff_true, if_true] at h2_right,
      tauto,
    },
  },
  case formula.not_ : P P_ih binders h1 h2
  {
    unfold fast_replace_free at h2,
    unfold to_is_bound_aux at h2,
    simp only at h2,

    unfold fast_admits_aux,
    exact P_ih binders h1 h2,
  },
  case formula.imp_ : P Q P_ih Q_ih binders h1 h2
  {
    unfold fast_replace_free at h2,
    unfold to_is_bound_aux at h2,
    simp only at h2,
    cases h2,

    unfold fast_admits_aux,
    tauto,
  },
  case formula.forall_ : x P P_ih binders h1 h2
  {
    unfold fast_replace_free at h2,

    unfold fast_admits_aux,
    split_ifs at h2,
    {
      left,
      exact h,
    },
    {
      right,
      apply P_ih,
      {
        simp only [finset.mem_union, finset.mem_singleton],
        tauto,
      },
      {
        unfold to_is_bound_aux at h2,
        simp only [eq_self_iff_true, true_and] at h2,
        exact h2,
      }
    }
  },
end

example
  (P : formula)
  (v u : variable_) :
  fast_admits v u P ↔ to_is_bound P = to_is_bound (fast_replace_free v u P) :=
begin
  unfold fast_admits,
  unfold to_is_bound,
  split,
  {
    apply fast_admits_aux_imp_free_and_bound_unchanged,
    simp only [finset.not_mem_empty, not_false_iff],
  },
  {
    apply free_and_bound_unchanged_imp_fast_admits_aux,
    simp only [finset.not_mem_empty, not_false_iff],
  }
end

-- admits

lemma admits_aux_self
  (P : formula)
  (v : variable_)
  (binders : finset variable_) :
  admits_aux v v binders P :=
begin
  induction P generalizing binders;
  unfold admits_aux;
  tauto,
end

theorem admits_self
  (P : formula)
  (v : variable_) :
  admits v v P :=
begin
  unfold admits,
  apply admits_aux_self,
end

--

lemma not_is_free_in_imp_admits_aux
  (P : formula)
  (v u : variable_)
  (binders : finset variable_)
  (h1 : ¬ is_free_in v P) :
  admits_aux v u binders P :=
begin
  induction P generalizing binders,
  case formula.true_ : binders
  {
    unfold admits_aux,
  },
  case formula.pred_ : name args binders
  {
    unfold is_free_in at h1,
    simp only [list.mem_to_finset] at h1,

    unfold admits_aux,
    tauto,
  },
  case [formula.eq_, formula.not_, formula.imp_]
  {
    all_goals
    {
      unfold is_free_in at h1,

      unfold admits_aux,
      tauto,
    }
  },
  case formula.forall_ : x P P_ih binders
  {
    unfold is_free_in at h1,

    unfold admits_aux,
    by_cases c1 : v = x,
    {
      apply mem_binders_imp_admits_aux,
      simp only [finset.mem_union, finset.mem_singleton],
      tauto,
    },
    {
      tauto,
    },
  },
end

theorem not_is_free_in_imp_admits
  (P : formula)
  (v u : variable_)
  (h1 : ¬ is_free_in v P) :
  admits v u P :=
begin
  unfold admits,
  apply not_is_free_in_imp_admits_aux,
  exact h1,
end

--

lemma not_is_bound_in_imp_admits_aux
  (P : formula)
  (v u : variable_)
  (binders : finset variable_)
  (h1 : ¬ is_bound_in u P)
  (h2 : u ∉ binders) :
  admits_aux v u binders P :=
begin
  induction P generalizing binders,
  case formula.true_ : binders h2
  {
    unfold admits_aux,
  },
  case formula.pred_ : name args binders h2
  {
    unfold admits_aux,
    tauto,
  },
  case formula.eq_ : x y binders h2
  {
    unfold admits_aux,
    tauto,
  },
  case formula.not_ : P P_ih binders h2
  {
    unfold is_bound_in at h1,

    unfold admits_aux,
    tauto,
  },
  case formula.imp_ : P Q P_ih Q_ih binders h2
  {
    unfold is_bound_in at h1,

    unfold admits_aux,
    tauto,
  },
  case formula.forall_ : x P P_ih binders h2
  {
    unfold is_bound_in at h1,
    push_neg at h1,
    cases h1,

    unfold admits_aux,
    apply P_ih h1_right,
    simp only [finset.mem_union, finset.mem_singleton],
    tauto,
  },
end

theorem not_is_bound_in_imp_admits
  (P : formula)
  (v u : variable_)
  (h1 : ¬ is_bound_in u P) :
  admits v u P :=
begin
  unfold admits,
  apply not_is_bound_in_imp_admits_aux,
  {
    exact h1,
  },
  {
    simp only [finset.not_mem_empty, not_false_iff],
  }
end

--

lemma replace_free_aux_admits_aux
  (P : formula)
  (v t : variable_)
  (binders : finset variable_)
  (h1 : ¬ occurs_in t P) :
  admits_aux t v binders (replace_free_aux v t binders P) :=
begin
  induction P generalizing binders,
  case formula.true_ : binders
  {
    unfold replace_free_aux,
  },
  case formula.pred_ : name args binders
  {
    unfold occurs_in at h1,
    simp only [list.mem_to_finset] at h1,

    unfold replace_free_aux,
    unfold admits_aux,
    simp only [list.mem_map, not_and, not_not, and_imp, forall_exists_index],
    intros x a1 a2 a3,

    by_cases c1 : x = v ∧ x ∉ binders,
    {
      cases c1,
      subst c1_left,
      exact c1_right,
    },
    {
      simp only [if_neg c1] at a2,
      subst a2,
      contradiction,
    }
  },
  case formula.eq_ : x y binders
  {
    unfold occurs_in at h1,
    push_neg at h1,
    cases h1,

    unfold replace_free_aux,
    unfold admits_aux,
    intros a1,
    cases a1,
    cases a1_left,
    {
      by_cases c1 : x = v ∧ x ∉ binders,
      {
        cases c1,
        subst c1_left,
        exact c1_right,
      },
      {
        simp only [if_neg c1] at a1_left,
        contradiction,
      }
    },
    {
      by_cases c1 : y = v ∧ y ∉ binders,
      {
        cases c1,
        subst c1_left,
        exact c1_right,
      },
      {
        simp only [if_neg c1] at a1_left,
        contradiction,
      }
    },
  },
  case formula.not_ : P P_ih binders
  {
    unfold occurs_in at h1,

    unfold replace_free_aux,
    unfold admits_aux,
    tauto,
  },
  case formula.imp_ : P Q P_ih Q_ih binders
  {
    unfold occurs_in at h1,

    unfold replace_free_aux,
    unfold admits_aux,
    tauto,
  },
  case formula.forall_ : x P P_ih binders
  {
    unfold occurs_in at h1,

    unfold replace_free_aux,
    unfold admits_aux,
    tauto,
  },
end

theorem replace_free_admits
  (P : formula)
  (v t : variable_)
  (h1 : ¬ occurs_in t P) :
  admits t v (replace_free v t P) :=
begin
  unfold replace_free,
  unfold admits,
  apply replace_free_aux_admits_aux,
  exact h1,
end

--

lemma admits_aux_add_binders
  (P : formula)
  (v u : variable_)
  (S T : finset variable_)
  (h1 : admits_aux v u S P)
  (h2 : u ∉ T) :
  admits_aux v u (S ∪ T) P :=
begin
  induction P generalizing S,
  case formula.true_ : S h1
  {
    unfold admits_aux,
  },
  case formula.pred_ : name args S h1
  {
    unfold admits_aux at h1,

    unfold admits_aux,
    simp only [finset.mem_union, and_imp],
    tauto,
  },
  case formula.eq_ : x y S h1
  {
    unfold admits_aux at h1,

    unfold admits_aux,
    simp only [finset.mem_union, and_imp],
    tauto,
  },
  case formula.not_ : P P_ih S h1
  {
    unfold admits_aux at h1,

    unfold admits_aux,
    tauto,
  },
  case formula.imp_ : P Q P_ih Q_ih S h1
  {
    unfold admits_aux at h1,

    unfold admits_aux,
    tauto,
  },
  case formula.forall_ : x P P_ih S h1
  {
    unfold admits_aux at h1,

    unfold admits_aux,
    simp only [finset.union_right_comm S T {x}],
    tauto,
  },
end

lemma admits_aux_del_binders
  (P : formula)
  (v u : variable_)
  (S T : finset variable_)
  (h1 : admits_aux v u (S ∪ T) P)
  (h2 : v ∉ T) :
  admits_aux v u S P :=
begin
  induction P generalizing S,
  case formula.true_ : S h1
  {
    unfold admits_aux,
  },
  case formula.pred_ : name args S h1
  {
    unfold admits_aux at h1,
    simp only [finset.mem_union, and_imp] at h1,

    unfold admits_aux,
    tauto,
  },
  case formula.eq_ : x y S h1
  {
    unfold admits_aux at h1,
    simp only [finset.mem_union, and_imp] at h1,

    unfold admits_aux,
    tauto,
  },
  case formula.not_ : P P_ih S h1
  {
    unfold admits_aux at h1,

    unfold admits_aux,
    tauto,
  },
  case formula.imp_ : P Q P_ih Q_ih S h1
  {
    unfold admits_aux at h1,
    cases h1,

    unfold admits_aux,
    tauto,
  },
  case formula.forall_ : x P P_ih S h1
  {
    unfold admits_aux at h1,
    simp only [finset.union_right_comm S T {x}] at h1,

    unfold admits_aux,
    tauto,
  },
end

lemma admits_aux_is_free_in
  (P : formula)
  (v u : variable_)
  (binders : finset variable_)
  (h1 : admits_aux v u binders P)
  (h2 : is_free_in v P)
  (h3 : v ∉ binders) :
  u ∉ binders :=
begin
  induction P generalizing binders,
  case formula.true_ : binders h1
  {
    unfold is_free_in at h2,

    contradiction,
  },
  case formula.pred_ : name args binders h1
  {
    unfold admits_aux at h1,

    unfold is_free_in at h2,
    simp only [list.mem_to_finset] at h2,

    tauto,
  },
  case formula.eq_ : x y binders h1
  {
    unfold admits_aux at h1,

    unfold is_free_in at h2,

    tauto,
  },
  case formula.not_ : P P_ih binders h1
  {
    unfold admits_aux at h1,

    unfold is_free_in at h2,

    exact P_ih h2 binders h1 h3,
  },
  case formula.imp_ : P Q P_ih Q_ih binders h1
  {
    unfold admits_aux at h1,
    cases h1,

    unfold is_free_in at h2,

    cases h2,
    {
      exact P_ih h2 binders h1_left h3,
    },
    {
      exact Q_ih h2 binders h1_right h3,
    }
  },
  case formula.forall_ : x P P_ih binders h1
  {
    unfold admits_aux at h1,

    unfold is_free_in at h2,
    cases h2,

    apply P_ih h2_right,
    {
      apply admits_aux_del_binders P v u binders {x},
      {
        exact h1,
      },
      {
        simp only [finset.mem_singleton],
        exact h2_left,
      },
    },
    {
      exact h3,
    },
  },
end

#lint


/-
Copyright (c) 2022 Yaël Dillies. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Yaël Dillies
-/
import order.hom.basic
import topology.continuous_function.basic

/-!
# Continuous order homomorphisms

This file defines continuous order homomorphisms, that is maps which are both continuous and
monotone. They are also called Priestley homomorphisms because they are the morphisms of the
category of Priestley spaces.

We use the `fun_like` design, so each type of morphisms has a companion typeclass which is meant to
be satisfied by itself and all stricter types.

## Types of morphisms

* `continuous_order_hom`: Continuous monotone functions, aka Priestley homomorphisms.

## Typeclasses

* `continuous_order_hom_class`
-/

open function

variables {F α β γ δ : Type*}

/-- The type of continuous monotone maps from `α` to `β`, aka Priestley homomorphisms. -/
structure continuous_order_hom (α β : Type*) [preorder α] [preorder β] [topological_space α]
  [topological_space β]
  extends order_hom α β :=
(continuous_to_fun : continuous to_fun)

infixr ` →Co `:25 := continuous_order_hom

/-- `continuous_order_hom_class F α β` states that `F` is a type of continuous monotone maps.

You should extend this class when you extend `continuous_order_hom`. -/
class continuous_order_hom_class (F : Type*) (α β : out_param $ Type*) [preorder α] [preorder β]
  [topological_space α] [topological_space β]
  extends rel_hom_class F ((≤) : α → α → Prop) ((≤) : β → β → Prop) :=
(map_continuous (f : F) : continuous f)

@[priority 100] -- See note [lower instance priority]
instance continuous_order_hom_class.to_continuous_map_class [preorder α] [preorder β]
  [topological_space α] [topological_space β] [continuous_order_hom_class F α β] :
  continuous_map_class F α β :=
{ ..‹continuous_order_hom_class F α β› }

instance [preorder α] [preorder β] [topological_space α] [topological_space β]
  [continuous_order_hom_class F α β] :
  has_coe_t F (α →Co β) :=
⟨λ f, { to_fun := f, monotone' := order_hom_class.mono f, continuous_to_fun := map_continuous f }⟩

/-! ### Top homomorphisms -/

namespace continuous_order_hom
variables [topological_space α] [preorder α] [topological_space β]

section preorder
variables [preorder β] [topological_space γ] [preorder γ] [topological_space δ] [preorder δ]

/-- Reinterpret a `continuous_order_hom` as a `continuous_map`. -/
def to_continuous_map (f : α →Co β) : C(α, β) := { ..f }

instance : continuous_order_hom_class (α →Co β) α β :=
{ coe := λ f, f.to_fun,
  coe_injective' := λ f g h, by { obtain ⟨⟨_, _⟩, _⟩ := f, obtain ⟨⟨_, _⟩, _⟩ := g, congr' },
  map_rel := λ f, f.monotone',
  map_continuous := λ f, f.continuous_to_fun }

/-- Helper instance for when there's too many metavariables to apply `fun_like.has_coe_to_fun`
directly. -/
instance : has_coe_to_fun (α →Co β) (λ _, α → β) := fun_like.has_coe_to_fun

@[simp] lemma to_fun_eq_coe {f : α →Co β} : f.to_fun = (f : α → β) := rfl

@[ext] lemma ext {f g : α →Co β} (h : ∀ a, f a = g a) : f = g := fun_like.ext f g h

/-- Copy of a `continuous_order_hom` with a new `continuous_map` equal to the old one. Useful to fix
definitional equalities. -/
protected def copy (f : α →Co β) (f' : α → β) (h : f' = f) : α →Co β :=
⟨f.to_order_hom.copy f' $ by exact h, h.symm.subst f.continuous_to_fun⟩

variables (α)

/-- `id` as a `continuous_order_hom`. -/
protected def id : α →Co α := ⟨order_hom.id, continuous_id⟩

instance : inhabited (α →Co α) := ⟨continuous_order_hom.id _⟩

@[simp] lemma coe_id : ⇑(continuous_order_hom.id α) = id := rfl

variables {α}

@[simp] lemma id_apply (a : α) : continuous_order_hom.id α a = a := rfl

/-- Composition of `continuous_order_hom`s as a `continuous_order_hom`. -/
def comp (f : β →Co γ) (g : α →Co β) : continuous_order_hom α γ :=
⟨f.to_order_hom.comp g.to_order_hom, f.continuous_to_fun.comp g.continuous_to_fun⟩

@[simp]

lemma cancel_right {g₁ g₂ : β →Co γ} {f : α →Co β} (hf : surjective f) :
  g₁.comp f = g₂.comp f ↔ g₁ = g₂ :=
⟨λ h, ext $ hf.forall.2 $ fun_like.ext_iff.1 h, congr_arg _⟩

lemma cancel_left {g : β →Co γ} {f₁ f₂ : α →Co β} (hg : injective g) :
  g.comp f₁ = g.comp f₂ ↔ f₁ = f₂ :=
⟨λ h, ext $ λ a, hg $ by rw [←comp_apply, h, comp_apply], congr_arg _⟩

instance : preorder (α →Co β) := preorder.lift (coe_fn : (α →Co β) → α → β)

end preorder

instance [partial_order β] : partial_order (α →Co β) := partial_order.lift _ fun_like.coe_injective

end continuous_order_hom


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

! This file was ported from Lean 3 source module category_theory.limits.final
! leanprover-community/mathlib commit 8a318021995877a44630c898d0b2bc376fceef3b
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathlib.CategoryTheory.PUnit
import Mathlib.CategoryTheory.StructuredArrow
import Mathlib.CategoryTheory.IsConnected
import Mathlib.CategoryTheory.Limits.Yoneda
import Mathlib.CategoryTheory.Limits.Types

/-!
# Final and initial functors

A functor `F : C ⥤ D` is final if for every `d : D`,
the comma category of morphisms `d ⟶ F.obj c` is connected.

Dually, a functor `F : C ⥤ D` is initial if for every `d : D`,
the comma category of morphisms `F.obj c ⟶ d` is connected.

We show that right adjoints are examples of final functors, while
left adjoints are examples of initial functors.

For final functors, we prove that the following three statements are equivalent:
1. `F : C ⥤ D` is final.
2. Every functor `G : D ⥤ E` has a colimit if and only if `F ⋙ G` does,
   and these colimits are isomorphic via `colimit.pre G F`.
3. `colimit (F ⋙ coyoneda.obj (op d)) ≅ PUnit`.

Starting at 1. we show (in `coconesEquiv`) that
the categories of cocones over `G : D ⥤ E` and over `F ⋙ G` are equivalent.
(In fact, via an equivalence which does not change the cocone point.)
This readily implies 2., as `comp_hasColimit`, `hasColimit_of_comp`, and `colimitIso`.

From 2. we can specialize to `G = coyoneda.obj (op d)` to obtain 3., as `colimitCompCoyonedaIso`.

From 3., we prove 1. directly in `cofinal_of_colimit_comp_coyoneda_iso_pUnit`.

Dually, we prove that if a functor `F : C ⥤ D` is initial, then any functor `G : D ⥤ E` has a
limit if and only if `F ⋙ G` does, and these limits are isomorphic via `limit.pre G F`.

## Naming
There is some discrepancy in the literature about naming; some say 'cofinal' instead of 'final'.
The explanation for this is that the 'co' prefix here is *not* the usual category-theoretic one
indicating duality, but rather indicating the sense of "along with".

## Future work
Dualise condition 3 above and the implications 2 ⇒ 3 and 3 ⇒ 1 to initial functors.

## References
* https://stacks.math.columbia.edu/tag/09WN
* https://ncatlab.org/nlab/show/final+functor
* Borceux, Handbook of Categorical Algebra I, Section 2.11.
  (Note he reverses the roles of definition and main result relative to here!)
-/

noncomputable section

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

namespace CategoryTheory

namespace Functor

open Opposite

open CategoryTheory.Limits

section ArbitraryUniverse

variable {C : Type u₁} [Category.{v₁} C]

variable {D : Type u₂} [Category.{v₂} D]

/--
A functor `F : C ⥤ D` is final if for every `d : D`, the comma category of morphisms `d ⟶ F.obj c`
is connected.

See <https://stacks.math.columbia.edu/tag/04E6>
-/
class Final (F : C ⥤ D) : Prop where
  out (d : D) : IsConnected (StructuredArrow d F)
#align category_theory.functor.final CategoryTheory.Functor.Final

attribute [instance] Final.out

/-- A functor `F : C ⥤ D` is initial if for every `d : D`, the comma category of morphisms
`F.obj c ⟶ d` is connected.
-/
class Initial (F : C ⥤ D) : Prop where
  out (d : D) : IsConnected (CostructuredArrow F d)
#align category_theory.functor.initial CategoryTheory.Functor.Initial

attribute [instance] Initial.out

instance final_op_of_initial (F : C ⥤ D) [Initial F] : Final F.op
    where out d := isConnected_of_equivalent (costructuredArrowOpEquivalence F (unop d))
#align category_theory.functor.final_op_of_initial CategoryTheory.Functor.final_op_of_initial

instance initial_op_of_final (F : C ⥤ D) [Final F] : Initial F.op
    where out d := isConnected_of_equivalent (structuredArrowOpEquivalence F (unop d))
#align category_theory.functor.initial_op_of_final CategoryTheory.Functor.initial_op_of_final

theorem final_of_initial_op (F : C ⥤ D) [Initial F.op] : Final F :=
  {
    out := fun d =>
      @isConnected_of_isConnected_op _ _
        (isConnected_of_equivalent (structuredArrowOpEquivalence F d).symm) }
#align category_theory.functor.final_of_initial_op CategoryTheory.Functor.final_of_initial_op

theorem initial_of_final_op (F : C ⥤ D) [Final F.op] : Initial F :=
  {
    out := fun d =>
      @isConnected_of_isConnected_op _ _
        (isConnected_of_equivalent (costructuredArrowOpEquivalence F d).symm) }
#align category_theory.functor.initial_of_final_op CategoryTheory.Functor.initial_of_final_op

/-- If a functor `R : D ⥤ C` is a right adjoint, it is final. -/
theorem final_of_adjunction {L : C ⥤ D} {R : D ⥤ C} (adj : L ⊣ R) : Final R :=
  {
    out := fun c =>
      let u : StructuredArrow c R := StructuredArrow.mk (adj.unit.app c)
      @zigzag_isConnected _ _ ⟨u⟩ fun f g =>
        Relation.ReflTransGen.trans
          (Relation.ReflTransGen.single
            (show Zag f u from
              Or.inr ⟨StructuredArrow.homMk ((adj.homEquiv c f.right).symm f.hom) (by simp)⟩))
          (Relation.ReflTransGen.single
            (show Zag u g from
              Or.inl ⟨StructuredArrow.homMk ((adj.homEquiv c g.right).symm g.hom) (by simp)⟩)) }
#align category_theory.functor.final_of_adjunction CategoryTheory.Functor.final_of_adjunction

/-- If a functor `L : C ⥤ D` is a left adjoint, it is initial. -/
theorem initial_of_adjunction {L : C ⥤ D} {R : D ⥤ C} (adj : L ⊣ R) : Initial L :=
  {
    out := fun d =>
      let u : CostructuredArrow L d := CostructuredArrow.mk (adj.counit.app d)
      @zigzag_isConnected _ _ ⟨u⟩ fun f g =>
        Relation.ReflTransGen.trans
          (Relation.ReflTransGen.single
            (show Zag f u from
              Or.inl ⟨CostructuredArrow.homMk (adj.homEquiv f.left d f.hom) (by simp)⟩))
          (Relation.ReflTransGen.single
            (show Zag u g from
              Or.inr ⟨CostructuredArrow.homMk (adj.homEquiv g.left d g.hom) (by simp)⟩)) }
#align category_theory.functor.initial_of_adjunction CategoryTheory.Functor.initial_of_adjunction

instance (priority := 100) final_of_isRightAdjoint (F : C ⥤ D) [h : IsRightAdjoint F] : Final F :=
  final_of_adjunction h.adj
#align category_theory.functor.final_of_is_right_adjoint CategoryTheory.Functor.final_of_isRightAdjoint

instance (priority := 100) initial_of_isLeftAdjoint (F : C ⥤ D) [h : IsLeftAdjoint F] : Initial F :=
  initial_of_adjunction h.adj
#align category_theory.functor.initial_of_is_left_adjoint CategoryTheory.Functor.initial_of_isLeftAdjoint

namespace Final

variable (F : C ⥤ D) [Final F]

instance (d : D) : Nonempty (StructuredArrow d F) :=
  IsConnected.is_nonempty

variable {E : Type u₃} [Category.{v₃} E] (G : D ⥤ E)

/--
When `F : C ⥤ D` is cofinal, we denote by `lift F d` an arbitrary choice of object in `C` such that
there exists a morphism `d ⟶ F.obj (lift F d)`.
-/
def lift (d : D) : C :=
  (Classical.arbitrary (StructuredArrow d F)).right
#align category_theory.functor.final.lift CategoryTheory.Functor.Final.lift

/-- When `F : C ⥤ D` is cofinal, we denote by `homToLift` an arbitrary choice of morphism
`d ⟶ F.obj (lift F d)`.
-/
def homToLift (d : D) : d ⟶ F.obj (lift F d) :=
  (Classical.arbitrary (StructuredArrow d F)).hom
#align category_theory.functor.final.hom_to_lift CategoryTheory.Functor.Final.homToLift

/-- We provide an induction principle for reasoning about `lift` and `homToLift`.
We want to perform some construction (usually just a proof) about
the particular choices `lift F d` and `homToLift F d`,
it suffices to perform that construction for some other pair of choices
(denoted `X₀ : C` and `k₀ : d ⟶ F.obj X₀` below),
and to show how to transport such a construction
*both* directions along a morphism between such choices.
-/
def induction {d : D} (Z : ∀ (X : C) (_ : d ⟶ F.obj X), Sort _)
    (h₁ :
      ∀ (X₁ X₂) (k₁ : d ⟶ F.obj X₁) (k₂ : d ⟶ F.obj X₂) (f : X₁ ⟶ X₂),
        k₁ ≫ F.map f = k₂ → Z X₁ k₁ → Z X₂ k₂)
    (h₂ :
      ∀ (X₁ X₂) (k₁ : d ⟶ F.obj X₁) (k₂ : d ⟶ F.obj X₂) (f : X₁ ⟶ X₂),
        k₁ ≫ F.map f = k₂ → Z X₂ k₂ → Z X₁ k₁)
    {X₀ : C} {k₀ : d ⟶ F.obj X₀} (z : Z X₀ k₀) : Z (lift F d) (homToLift F d) := by
  apply Nonempty.some
  apply
    @isPreconnected_induction _ _ _ (fun Y : StructuredArrow d F => Z Y.right Y.hom) _ _
      (StructuredArrow.mk k₀) z
  · intro j₁ j₂ f a
    fapply h₁ _ _ _ _ f.right _ a
    convert f.w.symm
    dsimp
    simp
  · intro j₁ j₂ f a
    fapply h₂ _ _ _ _ f.right _ a
    convert f.w.symm
    dsimp
    simp
#align category_theory.functor.final.induction CategoryTheory.Functor.Final.induction

variable {F G}

/-- Given a cocone over `F ⋙ G`, we can construct a `Cocone G` with the same cocone point.
-/
@[simps]
def extendCocone : Cocone (F ⋙ G) ⥤ Cocone G
    where
  obj c :=
    { pt := c.pt
      ι :=
        { app := fun X => G.map (homToLift F X) ≫ c.ι.app (lift F X)
          naturality := fun X Y f => by
            dsimp; simp
            -- This would be true if we'd chosen `lift F X` to be `lift F Y`
            -- and `homToLift F X` to be `f ≫ homToLift F Y`.
            apply
              induction F fun Z k =>
                G.map f ≫ G.map (homToLift F Y) ≫ c.ι.app (lift F Y) = G.map k ≫ c.ι.app Z
            · intro Z₁ Z₂ k₁ k₂ g a z
              rw [← a, Functor.map_comp, Category.assoc, ← Functor.comp_map, c.w, z]
            · intro Z₁ Z₂ k₁ k₂ g a z
              rw [← a, Functor.map_comp, Category.assoc, ← Functor.comp_map, c.w] at z
              rw [z]
            · rw [← Functor.map_comp_assoc] } }
  map f := { Hom := f.Hom }
#align category_theory.functor.final.extend_cocone CategoryTheory.Functor.Final.extendCocone

@[simp]
theorem colimit_cocone_comp_aux (s : Cocone (F ⋙ G)) (j : C) :
    G.map (homToLift F (F.obj j)) ≫ s.ι.app (lift F (F.obj j)) = s.ι.app j := by
  -- This point is that this would be true if we took `lift (F.obj j)` to just be `j`
  -- and `homToLift (F.obj j)` to be `𝟙 (F.obj j)`.
  apply induction F fun X k => G.map k ≫ s.ι.app X = (s.ι.app j : _)
  · intro j₁ j₂ k₁ k₂ f w h
    rw [← w]
    rw [← s.w f] at h
    simpa using h
  · intro j₁ j₂ k₁ k₂ f w h
    rw [← w] at h
    rw [← s.w f]
    simpa using h
  · exact s.w (𝟙 _)
#align category_theory.functor.final.colimit_cocone_comp_aux CategoryTheory.Functor.Final.colimit_cocone_comp_aux

variable (F G)

/-- If `F` is cofinal,
the category of cocones on `F ⋙ G` is equivalent to the category of cocones on `G`,
for any `G : D ⥤ E`.
-/
@[simps]
def coconesEquiv : Cocone (F ⋙ G) ≌ Cocone G
    where
  functor := extendCocone
  inverse := Cocones.whiskering F
  unitIso := NatIso.ofComponents (fun c => Cocones.ext (Iso.refl _) (by aesop_cat)) (by aesop_cat)
  counitIso := NatIso.ofComponents (fun c => Cocones.ext (Iso.refl _) (by aesop_cat)) (by aesop_cat)
#align category_theory.functor.final.cocones_equiv CategoryTheory.Functor.Final.coconesEquiv

variable {G}

/-- When `F : C ⥤ D` is cofinal, and `t : Cocone G` for some `G : D ⥤ E`,
`t.whisker F` is a colimit cocone exactly when `t` is.
-/
def isColimitWhiskerEquiv (t : Cocone G) : IsColimit (t.whisker F) ≃ IsColimit t :=
  IsColimit.ofCoconeEquiv (coconesEquiv F G).symm
#align category_theory.functor.final.is_colimit_whisker_equiv CategoryTheory.Functor.Final.isColimitWhiskerEquiv

/-- When `F` is cofinal, and `t : Cocone (F ⋙ G)`,
`extendCocone.obj t` is a colimit coconne exactly when `t` is.
-/
def isColimitExtendCoconeEquiv (t : Cocone (F ⋙ G)) :
    IsColimit (extendCocone.obj t) ≃ IsColimit t :=
  IsColimit.ofCoconeEquiv (coconesEquiv F G)
#align category_theory.functor.final.is_colimit_extend_cocone_equiv CategoryTheory.Functor.Final.isColimitExtendCoconeEquiv

/-- Given a colimit cocone over `G : D ⥤ E` we can construct a colimit cocone over `F ⋙ G`. -/
@[simps]
def colimitCoconeComp (t : ColimitCocone G) : ColimitCocone (F ⋙ G)
    where
  cocone := _
  isColimit := (isColimitWhiskerEquiv F _).symm t.isColimit
#align category_theory.functor.final.colimit_cocone_comp CategoryTheory.Functor.Final.colimitCoconeComp

instance (priority := 100) comp_hasColimit [HasColimit G] : HasColimit (F ⋙ G) :=
  HasColimit.mk (colimitCoconeComp F (getColimitCocone G))
#align category_theory.functor.final.comp_has_colimit CategoryTheory.Functor.Final.comp_hasColimit

theorem colimit_pre_is_iso_aux {t : Cocone G} (P : IsColimit t) :
    ((isColimitWhiskerEquiv F _).symm P).desc (t.whisker F) = 𝟙 t.pt := by
  dsimp [isColimitWhiskerEquiv]
  apply P.hom_ext
  intro j
  dsimp; simp
#align category_theory.functor.final.colimit_pre_is_iso_aux CategoryTheory.Functor.Final.colimit_pre_is_iso_aux

instance colimit_pre_isIso [HasColimit G] : IsIso (colimit.pre G F) := by
  rw [colimit.pre_eq (colimitCoconeComp F (getColimitCocone G)) (getColimitCocone G)]
  erw [colimit_pre_is_iso_aux]
  dsimp
  infer_instance
#align category_theory.functor.final.colimit_pre_is_iso CategoryTheory.Functor.Final.colimit_pre_isIso

section

variable (G)

/-- When `F : C ⥤ D` is cofinal, and `G : D ⥤ E` has a colimit, then `F ⋙ G` has a colimit also and
`colimit (F ⋙ G) ≅ colimit G`

https://stacks.math.columbia.edu/tag/04E7
-/
def colimitIso [HasColimit G] : colimit (F ⋙ G) ≅ colimit G :=
  asIso (colimit.pre G F)
#align category_theory.functor.final.colimit_iso CategoryTheory.Functor.Final.colimitIso

end

/-- Given a colimit cocone over `F ⋙ G` we can construct a colimit cocone over `G`. -/
@[simps]
def colimitCoconeOfComp (t : ColimitCocone (F ⋙ G)) : ColimitCocone G
    where
  cocone := extendCocone.obj t.cocone
  isColimit := (isColimitExtendCoconeEquiv F _).symm t.isColimit
#align category_theory.functor.final.colimit_cocone_of_comp CategoryTheory.Functor.Final.colimitCoconeOfComp

/-- When `F` is cofinal, and `F ⋙ G` has a colimit, then `G` has a colimit also.

We can't make this an instance, because `F` is not determined by the goal.
(Even if this weren't a problem, it would cause a loop with `comp_hasColimit`.)
-/
theorem hasColimit_of_comp [HasColimit (F ⋙ G)] : HasColimit G :=
  HasColimit.mk (colimitCoconeOfComp F (getColimitCocone (F ⋙ G)))
#align category_theory.functor.final.has_colimit_of_comp CategoryTheory.Functor.Final.hasColimit_of_comp

section

-- porting note: this instance does not seem to be found automatically
--attribute [local instance] hasColimit_of_comp

/-- When `F` is cofinal, and `F ⋙ G` has a colimit, then `G` has a colimit also and
`colimit (F ⋙ G) ≅ colimit G`

https://stacks.math.columbia.edu/tag/04E7
-/
def colimitIso' [HasColimit (F ⋙ G)] :
    haveI : HasColimit G := hasColimit_of_comp F;
    colimit (F ⋙ G) ≅ colimit G :=
  haveI : HasColimit G := hasColimit_of_comp F;
  asIso (colimit.pre G F)
#align category_theory.functor.final.colimit_iso' CategoryTheory.Functor.Final.colimitIso'

end

end Final

end ArbitraryUniverse

namespace Final

variable {C : Type v} [Category.{v} C] {D : Type v} [Category.{v} D] (F : C ⥤ D) [Final F]

/-- If the universal morphism `colimit (F ⋙ coyoneda.obj (op d)) ⟶ colimit (coyoneda.obj (op d))`
is an isomorphism (as it always is when `F` is cofinal),
then `colimit (F ⋙ coyoneda.obj (op d)) ≅ PUnit`
(simply because `colimit (coyoneda.obj (op d)) ≅ PUnit`).
-/
def colimitCompCoyonedaIso (d : D) [IsIso (colimit.pre (coyoneda.obj (op d)) F)] :
    colimit (F ⋙ coyoneda.obj (op d)) ≅ PUnit :=
  asIso (colimit.pre (coyoneda.obj (op d)) F) ≪≫ Coyoneda.colimitCoyonedaIso (op d)
#align category_theory.functor.final.colimit_comp_coyoneda_iso CategoryTheory.Functor.Final.colimitCompCoyonedaIso

theorem zigzag_of_eqvGen_quot_rel {F : C ⥤ D} {d : D} {f₁ f₂ : ΣX, d ⟶ F.obj X}
    (t : EqvGen (Types.Quot.Rel.{v, v} (F ⋙ coyoneda.obj (op d))) f₁ f₂) :
    Zigzag (StructuredArrow.mk f₁.2) (StructuredArrow.mk f₂.2) := by
  induction t
  case rel x y r =>
    obtain ⟨f, w⟩ := r
    fconstructor
    swap; fconstructor
    left; fconstructor
    exact StructuredArrow.homMk f (by aesop_cat)
  case refl => fconstructor
  case symm x y _ ih =>
    apply zigzag_symmetric
    exact ih
  case trans x y z _ _ ih₁ ih₂ =>
    apply Relation.ReflTransGen.trans
    exact ih₁; exact ih₂
#align category_theory.functor.final.zigzag_of_eqv_gen_quot_rel CategoryTheory.Functor.Final.zigzag_of_eqvGen_quot_rel

/-- If `colimit (F ⋙ coyoneda.obj (op d)) ≅ PUnit` for all `d : D`, then `F` is cofinal.
-/
theorem cofinal_of_colimit_comp_coyoneda_iso_pUnit
    (I : ∀ d, colimit (F ⋙ coyoneda.obj (op d)) ≅ PUnit) : Final F :=
  ⟨fun d =>
    by
    have : Nonempty (StructuredArrow d F) :=
      by
      have := (I d).inv PUnit.unit
      obtain ⟨j, y, rfl⟩ := Limits.Types.jointly_surjective'.{v, v} this
      exact ⟨StructuredArrow.mk y⟩
    apply zigzag_isConnected
    rintro ⟨⟨⟨⟩⟩, X₁, f₁⟩ ⟨⟨⟨⟩⟩, X₂, f₂⟩
    dsimp at *
    let y₁ := colimit.ι (F ⋙ coyoneda.obj (op d)) X₁ f₁
    let y₂ := colimit.ι (F ⋙ coyoneda.obj (op d)) X₂ f₂
    have e : y₁ = y₂ := by
      apply (I d).toEquiv.injective
      ext
    have t := Types.colimit_eq.{v, v} e
    clear e y₁ y₂
    exact zigzag_of_eqvGen_quot_rel t⟩
#align category_theory.functor.final.cofinal_of_colimit_comp_coyoneda_iso_punit CategoryTheory.Functor.Final.cofinal_of_colimit_comp_coyoneda_iso_pUnit

end Final

namespace Initial

variable {C : Type u₁} [Category.{v₁} C] {D : Type u₂} [Category.{v₂} D] (F : C ⥤ D) [Initial F]

instance (d : D) : Nonempty (CostructuredArrow F d) :=
  IsConnected.is_nonempty

variable {E : Type u₃} [Category.{v₃} E] (G : D ⥤ E)

/--
When `F : C ⥤ D` is initial, we denote by `lift F d` an arbitrary choice of object in `C` such that
there exists a morphism `F.obj (lift F d) ⟶ d`.
-/
def lift (d : D) : C :=
  (Classical.arbitrary (CostructuredArrow F d)).left
#align category_theory.functor.initial.lift CategoryTheory.Functor.Initial.lift

/-- When `F : C ⥤ D` is initial, we denote by `homToLift` an arbitrary choice of morphism
`F.obj (lift F d) ⟶ d`.
-/
def homToLift (d : D) : F.obj (lift F d) ⟶ d :=
  (Classical.arbitrary (CostructuredArrow F d)).hom
#align category_theory.functor.initial.hom_to_lift CategoryTheory.Functor.Initial.homToLift

/-- We provide an induction principle for reasoning about `lift` and `homToLift`.
We want to perform some construction (usually just a proof) about
the particular choices `lift F d` and `homToLift F d`,
it suffices to perform that construction for some other pair of choices
(denoted `X₀ : C` and `k₀ : F.obj X₀ ⟶ d` below),
and to show how to transport such a construction
*both* directions along a morphism between such choices.
-/
def induction {d : D} (Z : ∀ (X : C) (_ : F.obj X ⟶ d), Sort _)
    (h₁ :
      ∀ (X₁ X₂) (k₁ : F.obj X₁ ⟶ d) (k₂ : F.obj X₂ ⟶ d) (f : X₁ ⟶ X₂),
        F.map f ≫ k₂ = k₁ → Z X₁ k₁ → Z X₂ k₂)
    (h₂ :
      ∀ (X₁ X₂) (k₁ : F.obj X₁ ⟶ d) (k₂ : F.obj X₂ ⟶ d) (f : X₁ ⟶ X₂),
        F.map f ≫ k₂ = k₁ → Z X₂ k₂ → Z X₁ k₁)
    {X₀ : C} {k₀ : F.obj X₀ ⟶ d} (z : Z X₀ k₀) : Z (lift F d) (homToLift F d) := by
  apply Nonempty.some
  apply
    @isPreconnected_induction _ _ _ (fun Y : CostructuredArrow F d => Z Y.left Y.hom) _ _
      (CostructuredArrow.mk k₀) z
  · intro j₁ j₂ f a
    fapply h₁ _ _ _ _ f.left _ a
    convert f.w
    dsimp
    simp
  · intro j₁ j₂ f a
    fapply h₂ _ _ _ _ f.left _ a
    convert f.w
    dsimp
    simp
#align category_theory.functor.initial.induction CategoryTheory.Functor.Initial.induction

variable {F G}

/-- Given a cone over `F ⋙ G`, we can construct a `Cone G` with the same cocone point.
-/
@[simps]
def extendCone : Cone (F ⋙ G) ⥤ Cone G
    where
  obj c :=
    { pt := c.pt
      π :=
        { app := fun d => c.π.app (lift F d) ≫ G.map (homToLift F d)
          naturality := fun X Y f => by
            dsimp; simp
            -- This would be true if we'd chosen `lift F Y` to be `lift F X`
            -- and `homToLift F Y` to be `homToLift F X ≫ f`.
            apply
              induction F fun Z k =>
                (c.π.app Z ≫ G.map k : c.pt ⟶ _) =
                  c.π.app (lift F X) ≫ G.map (homToLift F X) ≫ G.map f
            · intro Z₁ Z₂ k₁ k₂ g a z
              rw [← a, Functor.map_comp, ← Functor.comp_map, ← Category.assoc, ← Category.assoc,
                c.w] at z
              rw [z, Category.assoc]
            · intro Z₁ Z₂ k₁ k₂ g a z
              rw [← a, Functor.map_comp, ← Functor.comp_map, ← Category.assoc, ← Category.assoc,
                c.w, z, Category.assoc]
            · rw [← Functor.map_comp] } }
  map f := { Hom := f.Hom }
#align category_theory.functor.initial.extend_cone CategoryTheory.Functor.Initial.extendCone

@[simp]
theorem limit_cone_comp_aux (s : Cone (F ⋙ G)) (j : C) :
    s.π.app (lift F (F.obj j)) ≫ G.map (homToLift F (F.obj j)) = s.π.app j := by
  -- This point is that this would be true if we took `lift (F.obj j)` to just be `j`
  -- and `homToLift (F.obj j)` to be `𝟙 (F.obj j)`.
  apply induction F fun X k => s.π.app X ≫ G.map k = (s.π.app j : _)
  · intro j₁ j₂ k₁ k₂ f w h
    rw [← s.w f]
    rw [← w] at h
    simpa using h
  · intro j₁ j₂ k₁ k₂ f w h
    rw [← s.w f] at h
    rw [← w]
    simpa using h
  · exact s.w (𝟙 _)
#align category_theory.functor.initial.limit_cone_comp_aux CategoryTheory.Functor.Initial.limit_cone_comp_aux

variable (F G)

/-- If `F` is initial,
the category of cones on `F ⋙ G` is equivalent to the category of cones on `G`,
for any `G : D ⥤ E`.
-/
@[simps]
def conesEquiv : Cone (F ⋙ G) ≌ Cone G
    where
  functor := extendCone
  inverse := Cones.whiskering F
  unitIso := NatIso.ofComponents (fun c => Cones.ext (Iso.refl _) (by aesop_cat)) (by aesop_cat)
  counitIso := NatIso.ofComponents (fun c => Cones.ext (Iso.refl _) (by aesop_cat)) (by aesop_cat)
#align category_theory.functor.initial.cones_equiv CategoryTheory.Functor.Initial.conesEquiv

variable {G}

/-- When `F : C ⥤ D` is initial, and `t : Cone G` for some `G : D ⥤ E`,
`t.whisker F` is a limit cone exactly when `t` is.
-/
def isLimitWhiskerEquiv (t : Cone G) : IsLimit (t.whisker F) ≃ IsLimit t :=
  IsLimit.ofConeEquiv (conesEquiv F G).symm
#align category_theory.functor.initial.is_limit_whisker_equiv CategoryTheory.Functor.Initial.isLimitWhiskerEquiv

/-- When `F` is initial, and `t : Cone (F ⋙ G)`,
`extendCone.obj t` is a limit cone exactly when `t` is.
-/
def isLimitExtendConeEquiv (t : Cone (F ⋙ G)) : IsLimit (extendCone.obj t) ≃ IsLimit t :=
  IsLimit.ofConeEquiv (conesEquiv F G)
#align category_theory.functor.initial.is_limit_extend_cone_equiv CategoryTheory.Functor.Initial.isLimitExtendConeEquiv

/-- Given a limit cone over `G : D ⥤ E` we can construct a limit cone over `F ⋙ G`. -/
@[simps]
def limitConeComp (t : LimitCone G) : LimitCone (F ⋙ G)
    where
  cone := _
  isLimit := (isLimitWhiskerEquiv F _).symm t.isLimit
#align category_theory.functor.initial.limit_cone_comp CategoryTheory.Functor.Initial.limitConeComp

instance (priority := 100) comp_hasLimit [HasLimit G] : HasLimit (F ⋙ G) :=
  HasLimit.mk (limitConeComp F (getLimitCone G))
#align category_theory.functor.initial.comp_has_limit CategoryTheory.Functor.Initial.comp_hasLimit

theorem limit_pre_is_iso_aux {t : Cone G} (P : IsLimit t) :
    ((isLimitWhiskerEquiv F _).symm P).lift (t.whisker F) = 𝟙 t.pt := by
  change 𝟙 t.pt ≫ P.lift (extendCone.obj (Cone.whisker F t)) = 𝟙 t.pt
  apply P.hom_ext
  intro j
  simp
#align category_theory.functor.initial.limit_pre_is_iso_aux CategoryTheory.Functor.Initial.limit_pre_is_iso_aux

instance limit_pre_isIso [HasLimit G] : IsIso (limit.pre G F) := by
  rw [limit.pre_eq (limitConeComp F (getLimitCone G)) (getLimitCone G)]
  erw [limit_pre_is_iso_aux]
  dsimp
  infer_instance
#align category_theory.functor.initial.limit_pre_is_iso CategoryTheory.Functor.Initial.limit_pre_isIso

section

variable (G)

/-- When `F : C ⥤ D` is initial, and `G : D ⥤ E` has a limit, then `F ⋙ G` has a limit also and
`limit (F ⋙ G) ≅ limit G`

https://stacks.math.columbia.edu/tag/04E7
-/
def limitIso [HasLimit G] : limit (F ⋙ G) ≅ limit G :=
  (asIso (limit.pre G F)).symm
#align category_theory.functor.initial.limit_iso CategoryTheory.Functor.Initial.limitIso

end

/-- Given a limit cone over `F ⋙ G` we can construct a limit cone over `G`. -/
@[simps]
def limitConeOfComp (t : LimitCone (F ⋙ G)) : LimitCone G
    where
  cone := extendCone.obj t.cone
  isLimit := (isLimitExtendConeEquiv F _).symm t.isLimit
#align category_theory.functor.initial.limit_cone_of_comp CategoryTheory.Functor.Initial.limitConeOfComp

/-- When `F` is initial, and `F ⋙ G` has a limit, then `G` has a limit also.

We can't make this an instance, because `F` is not determined by the goal.
(Even if this weren't a problem, it would cause a loop with `comp_hasLimit`.)
-/
theorem hasLimit_of_comp [HasLimit (F ⋙ G)] : HasLimit G :=
  HasLimit.mk (limitConeOfComp F (getLimitCone (F ⋙ G)))
#align category_theory.functor.initial.has_limit_of_comp CategoryTheory.Functor.Initial.hasLimit_of_comp

section

-- porting note: this instance does not seem to be found automatically
-- attribute [local instance] hasLimit_of_comp

/-- When `F` is initial, and `F ⋙ G` has a limit, then `G` has a limit also and
`limit (F ⋙ G) ≅ limit G`

https://stacks.math.columbia.edu/tag/04E7
-/
def limitIso' [HasLimit (F ⋙ G)] :
    haveI : HasLimit G := hasLimit_of_comp F;
    limit (F ⋙ G) ≅ limit G :=
  haveI : HasLimit G := hasLimit_of_comp F;
  (asIso (limit.pre G F)).symm
#align category_theory.functor.initial.limit_iso' CategoryTheory.Functor.Initial.limitIso'

end

end Initial

end Functor

end CategoryTheory


/-
Copyright (c) 2020 Yury Kudryashov. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Yury Kudryashov
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.topology.metric_space.lipschitz
import Mathlib.PostPort

universes u_1 u_2 u_3

namespace Mathlib

/-!
# Antilipschitz functions

We say that a map `f : α → β` between two (extended) metric spaces is
`antilipschitz_with K`, `K ≥ 0`, if for all `x, y` we have `edist x y ≤ K * edist (f x) (f y)`.
For a metric space, the latter inequality is equivalent to `dist x y ≤ K * dist (f x) (f y)`.

## Implementation notes

The parameter `K` has type `ℝ≥0`. This way we avoid conjuction in the definition and have
coercions both to `ℝ` and `ennreal`. We do not require `0 < K` in the definition, mostly because
we do not have a `posreal` type.
-/

/-- We say that `f : α → β` is `antilipschitz_with K` if for any two points `x`, `y` we have
`K * edist x y ≤ edist (f x) (f y)`. -/
def antilipschitz_with {α : Type u_1} {β : Type u_2} [emetric_space α] [emetric_space β]
    (K : nnreal) (f : α → β) :=
  ∀ (x y : α), edist x y ≤ ↑K * edist (f x) (f y)

theorem antilipschitz_with_iff_le_mul_dist {α : Type u_1} {β : Type u_2} [metric_space α]
    [metric_space β] {K : nnreal} {f : α → β} :
    antilipschitz_with K f ↔ ∀ (x y : α), dist x y ≤ ↑K * dist (f x) (f y) :=
  sorry

theorem antilipschitz_with.of_le_mul_dist {α : Type u_1} {β : Type u_2} [metric_space α]
    [metric_space β] {K : nnreal} {f : α → β} :
    (∀ (x y : α), dist x y ≤ ↑K * dist (f x) (f y)) → antilipschitz_with K f :=
  iff.mpr antilipschitz_with_iff_le_mul_dist

theorem antilipschitz_with.mul_le_dist {α : Type u_1} {β : Type u_2} [metric_space α]
    [metric_space β] {K : nnreal} {f : α → β} (hf : antilipschitz_with K f) (x : α) (y : α) :
    ↑(K⁻¹) * dist x y ≤ dist (f x) (f y) :=
  sorry

namespace antilipschitz_with

/-- Extract the constant from `hf : antilipschitz_with K f`. This is useful, e.g.,
if `K` is given by a long formula, and we want to reuse this value. -/
protected def K {α : Type u_1} {β : Type u_2} [emetric_space α] [emetric_space β] {K : nnreal}
    {f : α → β} (hf : antilipschitz_with K f) : nnreal :=
  K

protected theorem injective {α : Type u_1} {β : Type u_2} [emetric_space α] [emetric_space β]
    {K : nnreal} {f : α → β} (hf : antilipschitz_with K f) : function.injective f :=
  sorry

theorem mul_le_edist {α : Type u_1} {β : Type u_2} [emetric_space α] [emetric_space β] {K : nnreal}
    {f : α → β} (hf : antilipschitz_with K f) (x : α) (y : α) :
    ↑(K⁻¹) * edist x y ≤ edist (f x) (f y) :=
  sorry

protected theorem id {α : Type u_1} [emetric_space α] : antilipschitz_with 1 id := sorry

theorem comp {α : Type u_1} {β : Type u_2} {γ : Type u_3} [emetric_space α] [emetric_space β]
    [emetric_space γ] {Kg : nnreal} {g : β → γ} (hg : antilipschitz_with Kg g) {Kf : nnreal}
    {f : α → β} (hf : antilipschitz_with Kf f) : antilipschitz_with (Kf * Kg) (g ∘ f) :=
  sorry

theorem restrict {α : Type u_1} {β : Type u_2} [emetric_space α] [emetric_space β] {K : nnreal}
    {f : α → β} (hf : antilipschitz_with K f) (s : set α) :
    antilipschitz_with K (set.restrict f s) :=
  fun (x y : ↥s) => hf ↑x ↑y

theorem cod_restrict {α : Type u_1} {β : Type u_2} [emetric_space α] [emetric_space β] {K : nnreal}
    {f : α → β} (hf : antilipschitz_with K f) {s : set β} (hs : ∀ (x : α), f x ∈ s) :
    antilipschitz_with K (set.cod_restrict f s hs) :=
  fun (x y : α) => hf x y

theorem to_right_inv_on' {α : Type u_1} {β : Type u_2} [emetric_space α] [emetric_space β]
    {K : nnreal} {f : α → β} {s : set α} (hf : antilipschitz_with K (set.restrict f s)) {g : β → α}
    {t : set β} (g_maps : set.maps_to g t s) (g_inv : set.right_inv_on g f t) :
    lipschitz_with K (set.restrict g t) :=
  sorry

theorem to_right_inv_on {α : Type u_1} {β : Type u_2} [emetric_space α] [emetric_space β]
    {K : nnreal} {f : α → β} (hf : antilipschitz_with K f) {g : β → α} {t : set β}
    (h : set.right_inv_on g f t) : lipschitz_with K (set.restrict g t) :=
  to_right_inv_on' (restrict hf set.univ) (set.maps_to_univ g t) h

theorem to_right_inverse {α : Type u_1} {β : Type u_2} [emetric_space α] [emetric_space β]
    {K : nnreal} {f : α → β} (hf : antilipschitz_with K f) {g : β → α}
    (hg : function.right_inverse g f) : lipschitz_with K g :=
  sorry

theorem uniform_embedding {α : Type u_1} {β : Type u_2} [emetric_space α] [emetric_space β]
    {K : nnreal} {f : α → β} (hf : antilipschitz_with K f) (hfc : uniform_continuous f) :
    uniform_embedding f :=
  sorry

theorem subtype_coe {α : Type u_1} [emetric_space α] (s : set α) : antilipschitz_with 1 coe :=
  restrict antilipschitz_with.id s

theorem of_subsingleton {α : Type u_1} {β : Type u_2} [emetric_space α] [emetric_space β]
    {f : α → β} [subsingleton α] {K : nnreal} : antilipschitz_with K f :=
  sorry

end antilipschitz_with

theorem lipschitz_with.to_right_inverse {α : Type u_1} {β : Type u_2} [emetric_space α]
    [emetric_space β] {K : nnreal} {f : α → β} (hf : lipschitz_with K f) {g : β → α}
    (hg : function.right_inverse g f) : antilipschitz_with K g :=
  sorry

end Mathlib