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

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

/-!
# Heyting algebra morphisms

A Heyting homomorphism between two Heyting algebras is a bounded lattice homomorphism that preserves
Heyting implication.

We use the `FunLike` 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

* `HeytingHom`: Heyting homomorphisms.
* `Coheytinghom`: Co-Heyting homomorphisms.
* `BiheytingHom`: Bi-Heyting homomorphisms.

## Typeclasses

* `HeytingHomClass`
* `CoheytinghomClass`
* `BiheytinghomClass`
-/

open Function

variable {F α β γ δ : Type _}

/-- The type of Heyting homomorphisms from `α` to `β`. Bounded lattice homomorphisms that preserve
Heyting implication. -/
-- @[protect_proj] -- Porting note: Not yet implemented
structure HeytingHom (α β : Type _) [HeytingAlgebra α] [HeytingAlgebra β] extends
  LatticeHom α β where
  /-- The proposition that a Heyting homomorphism preserves the bottom element.-/
  map_bot' : toFun ⊥ = ⊥
  /-- The proposition that a Heyting homomorphism preserves the Heyting implication.-/
  map_himp' : ∀ a b, toFun (a ⇨ b) = toFun a ⇨ toFun b
#align heyting_hom HeytingHom

/-- The type of co-Heyting homomorphisms from `α` to `β`. Bounded lattice homomorphisms that
preserve difference. -/
-- @[protect_proj] -- Porting note: Not yet implemented
structure CoheytingHom (α β : Type _) [CoheytingAlgebra α] [CoheytingAlgebra β] extends
  LatticeHom α β where
  /-- The proposition that a co-Heyting homomorphism preserves the top element.-/
  map_top' : toFun ⊤ = ⊤
  /-- The proposition that a co-Heyting homomorphism preserves the difference operation.-/
  map_sdiff' : ∀ a b, toFun (a \ b) = toFun a \ toFun b
#align coheyting_hom CoheytingHom

/-- The type of bi-Heyting homomorphisms from `α` to `β`. Bounded lattice homomorphisms that
preserve Heyting implication and difference. -/
-- @[protect_proj] -- Porting note: Not yet implemented
structure BiheytingHom (α β : Type _) [BiheytingAlgebra α] [BiheytingAlgebra β] extends
  LatticeHom α β where
  /-- The proposition that a bi-Heyting homomorphism preserves the Heyting implication.-/
  map_himp' : ∀ a b, toFun (a ⇨ b) = toFun a ⇨ toFun b
  /-- The proposition that a bi-Heyting homomorphism preserves the difference operation.-/
  map_sdiff' : ∀ a b, toFun (a \ b) = toFun a \ toFun b
#align biheyting_hom BiheytingHom

/-- `HeytingHomClass F α β` states that `F` is a type of Heyting homomorphisms.

You should extend this class when you extend `HeytingHom`. -/
class HeytingHomClass (F : Type _) (α β : outParam <| Type _) [HeytingAlgebra α]
  [HeytingAlgebra β] extends LatticeHomClass F α β where
  /-- The proposition that a Heyting homomorphism preserves the bottom element.-/
  map_bot (f : F) : f ⊥ = ⊥
  /-- The proposition that a Heyting homomorphism preserves the Heyting implication.-/
  map_himp (f : F) : ∀ a b, f (a ⇨ b) = f a ⇨ f b
#align heyting_hom_class HeytingHomClass

/-- `CoheytingHomClass F α β` states that `F` is a type of co-Heyting homomorphisms.

You should extend this class when you extend `CoheytingHom`. -/
class CoheytingHomClass (F : Type _) (α β : outParam <| Type _) [CoheytingAlgebra α]
  [CoheytingAlgebra β] extends LatticeHomClass F α β where
  /-- The proposition that a co-Heyting homomorphism preserves the top element.-/
  map_top (f : F) : f ⊤ = ⊤
  /-- The proposition that a co-Heyting homomorphism preserves the difference operation.-/
  map_sdiff (f : F) : ∀ a b, f (a \ b) = f a \ f b
#align coheyting_hom_class CoheytingHomClass

/-- `BiheytingHomClass F α β` states that `F` is a type of bi-Heyting homomorphisms.

You should extend this class when you extend `BiheytingHom`. -/
class BiheytingHomClass (F : Type _) (α β : outParam <| Type _) [BiheytingAlgebra α]
  [BiheytingAlgebra β] extends LatticeHomClass F α β where
  /-- The proposition that a bi-Heyting homomorphism preserves the Heyting implication.-/
  map_himp (f : F) : ∀ a b, f (a ⇨ b) = f a ⇨ f b
  /-- The proposition that a bi-Heyting homomorphism preserves the difference operation.-/
  map_sdiff (f : F) : ∀ a b, f (a \ b) = f a \ f b
#align biheyting_hom_class BiheytingHomClass

export HeytingHomClass (map_himp)

export CoheytingHomClass (map_sdiff)

attribute [simp] map_himp map_sdiff

/- Porting note: `[HeytingAlgebra α, β]` -> `{ _ : HeytingAlgebra α, β}` as a dangerous instance fix
similar for Coheyting & Biheyting instances -/
-- See note [lower instance priority]
instance (priority := 100) HeytingHomClass.toBoundedLatticeHomClass {_ : HeytingAlgebra α}
    { _ : HeytingAlgebra β} [HeytingHomClass F α β] : BoundedLatticeHomClass F α β :=
  { ‹HeytingHomClass F α β› with
    map_top := fun f => by rw [← @himp_self α _ ⊥, ← himp_self, map_himp] }
#align heyting_hom_class.to_bounded_lattice_hom_class HeytingHomClass.toBoundedLatticeHomClass

-- See note [lower instance priority]
instance (priority := 100) CoheytingHomClass.toBoundedLatticeHomClass {_ : CoheytingAlgebra α}
    { _ : CoheytingAlgebra β} [CoheytingHomClass F α β] : BoundedLatticeHomClass F α β :=
  { ‹CoheytingHomClass F α β› with
    map_bot := fun f => by rw [← @sdiff_self α _ ⊤, ← sdiff_self, map_sdiff] }
#align coheyting_hom_class.to_bounded_lattice_hom_class CoheytingHomClass.toBoundedLatticeHomClass

-- See note [lower instance priority]
instance (priority := 100) BiheytingHomClass.toHeytingHomClass {_ : BiheytingAlgebra α}
    { _ : BiheytingAlgebra β} [BiheytingHomClass F α β] : HeytingHomClass F α β :=
  { ‹BiheytingHomClass F α β› with
    map_bot := fun f => by rw [← @sdiff_self α _ ⊤, ← sdiff_self, BiheytingHomClass.map_sdiff] }
#align biheyting_hom_class.to_heyting_hom_class BiheytingHomClass.toHeytingHomClass

-- See note [lower instance priority]
instance (priority := 100) BiheytingHomClass.toCoheytingHomClass {_ : BiheytingAlgebra α}
    { _ : BiheytingAlgebra β}  [BiheytingHomClass F α β] : CoheytingHomClass F α β :=
  { ‹BiheytingHomClass F α β› with
    map_top := fun f => by rw [← @himp_self α _ ⊥, ← himp_self, map_himp] }
#align biheyting_hom_class.to_coheyting_hom_class BiheytingHomClass.toCoheytingHomClass

-- See note [lower instance priority]
instance (priority := 100) OrderIsoClass.toHeytingHomClass {_ : HeytingAlgebra α}
    { _ : HeytingAlgebra β} [OrderIsoClass F α β] : HeytingHomClass F α β :=
  { OrderIsoClass.toBoundedLatticeHomClass with
    map_himp := fun f a b =>
      eq_of_forall_le_iff fun c => by
        simp only [← map_inv_le_iff, le_himp_iff]
        rw [← OrderIsoClass.map_le_map_iff f]
        simp }
#align order_iso_class.to_heyting_hom_class OrderIsoClass.toHeytingHomClass

-- See note [lower instance priority]
instance (priority := 100) OrderIsoClass.toCoheytingHomClass {_ : CoheytingAlgebra α}
    { _ : CoheytingAlgebra β} [OrderIsoClass F α β] : CoheytingHomClass F α β :=
  { OrderIsoClass.toBoundedLatticeHomClass with
    map_sdiff := fun f a b =>
      eq_of_forall_ge_iff fun c => by
        simp only [← le_map_inv_iff, sdiff_le_iff]
        rw [← OrderIsoClass.map_le_map_iff f]
        simp }
#align order_iso_class.to_coheyting_hom_class OrderIsoClass.toCoheytingHomClass

-- See note [lower instance priority]
instance (priority := 100) OrderIsoClass.toBiheytingHomClass {_ : BiheytingAlgebra α}
    { _ : BiheytingAlgebra β} [OrderIsoClass F α β] : BiheytingHomClass F α β :=
  { OrderIsoClass.toLatticeHomClass with
    map_himp := fun f a b =>
      eq_of_forall_le_iff fun c => by
        simp only [← map_inv_le_iff, le_himp_iff]
        rw [← OrderIsoClass.map_le_map_iff f]
        simp
    map_sdiff := fun f a b =>
      eq_of_forall_ge_iff fun c => by
        simp only [← le_map_inv_iff, sdiff_le_iff]
        rw [← OrderIsoClass.map_le_map_iff f]
        simp }
#align order_iso_class.to_biheyting_hom_class OrderIsoClass.toBiheytingHomClass

-- Porting note: Revisit this issue to see if it works in Lean 4. -/
-- See note [reducible non instances]
/-- This can't be an instance because of typeclass loops. -/
@[reducible]
def BoundedLatticeHomClass.toBiheytingHomClass [BooleanAlgebra α] [BooleanAlgebra β]
    [BoundedLatticeHomClass F α β] : BiheytingHomClass F α β :=
  { ‹BoundedLatticeHomClass F α β› with
    map_himp := fun f a b => by rw [himp_eq, himp_eq, map_sup, (isCompl_compl.map _).compl_eq]
    map_sdiff := fun f a b => by rw [sdiff_eq, sdiff_eq, map_inf, (isCompl_compl.map _).compl_eq] }
#align bounded_lattice_hom_class.to_biheyting_hom_class BoundedLatticeHomClass.toBiheytingHomClass

section HeytingAlgebra

variable [HeytingAlgebra α] [HeytingAlgebra β] [HeytingHomClass F α β] (f : F)

@[simp]
theorem map_compl (a : α) : f (aᶜ) = f aᶜ := by rw [← himp_bot, ← himp_bot, map_himp, map_bot]
#align map_compl map_compl

@[simp]
theorem map_bihimp (a b : α) : f (a ⇔ b) = f a ⇔ f b := by simp_rw [bihimp, map_inf, map_himp]
#align map_bihimp map_bihimp

-- TODO: `map_bihimp`
end HeytingAlgebra

section CoheytingAlgebra

variable [CoheytingAlgebra α] [CoheytingAlgebra β] [CoheytingHomClass F α β] (f : F)

@[simp]
theorem map_hnot (a : α) : f (￢a) = ￢f a := by rw [← top_sdiff', ← top_sdiff', map_sdiff, map_top]
#align map_hnot map_hnot

@[simp]
theorem map_symmDiff (a b : α) : f (a ∆ b) = f a ∆ f b := by simp_rw [symmDiff, map_sup, map_sdiff]
#align map_symm_diff map_symmDiff

end CoheytingAlgebra

instance [HeytingAlgebra α] [HeytingAlgebra β] [HeytingHomClass F α β] : CoeTC F (HeytingHom α β) :=
  ⟨fun f =>
    { toFun := f
      map_sup' := map_sup f
      map_inf' := map_inf f
      map_bot' := map_bot f
      map_himp' := map_himp f }⟩

instance [CoheytingAlgebra α] [CoheytingAlgebra β] [CoheytingHomClass F α β] :
    CoeTC F (CoheytingHom α β) :=
  ⟨fun f =>
    { toFun := f
      map_sup' := map_sup f
      map_inf' := map_inf f
      map_top' := map_top f
      map_sdiff' := map_sdiff f }⟩

instance [BiheytingAlgebra α] [BiheytingAlgebra β] [BiheytingHomClass F α β] :
    CoeTC F (BiheytingHom α β) :=
  ⟨fun f =>
    { toFun := f
      map_sup' := map_sup f
      map_inf' := map_inf f
      map_himp' := map_himp f
      map_sdiff' := map_sdiff f }⟩

namespace HeytingHom

variable [HeytingAlgebra α] [HeytingAlgebra β] [HeytingAlgebra γ] [HeytingAlgebra δ]

instance : HeytingHomClass (HeytingHom α β) α β where
  coe f := f.toFun
  coe_injective' f g h := by obtain ⟨⟨⟨_, _⟩, _⟩, _⟩ := f; obtain ⟨⟨⟨_, _⟩, _⟩, _⟩ := g; congr
  map_sup f := f.map_sup'
  map_inf f := f.map_inf'
  map_bot f := f.map_bot'
  map_himp := HeytingHom.map_himp'

-- Porting note: CoeFun undesired here in lean 4
-- /-- Helper instance for when there's too many metavariables to apply `FunLike.CoeFun`
-- directly. -/
-- instance : CoeFun (HeytingHom α β) fun _ => α → β :=
--   FunLike.hasCoeToFun

-- @[simp] -- Porting note: not in simp-nf, simp can simplify lhs. Added aux simp lemma
theorem toFun_eq_coe {f : HeytingHom α β} : f.toFun = ⇑f :=
  rfl
#align heyting_hom.to_fun_eq_coe HeytingHom.toFun_eq_coe

@[simp]
theorem toFun_eq_coe_aux {f : HeytingHom α β} : (↑f.toLatticeHom) = ⇑f :=
  rfl

@[ext]
theorem ext {f g : HeytingHom α β} (h : ∀ a, f a = g a) : f = g :=
  FunLike.ext f g h
#align heyting_hom.ext HeytingHom.ext

/-- Copy of a `HeytingHom` with a new `toFun` equal to the old one. Useful to fix definitional
equalities. -/
protected def copy (f : HeytingHom α β) (f' : α → β) (h : f' = f) : HeytingHom α β where
  toFun := f'
  map_sup' := by simpa only [h] using map_sup f
  map_inf' := by simpa only [h] using map_inf f
  map_bot' := by simpa only [h] using map_bot f
  map_himp' := by simpa only [h] using map_himp f
#align heyting_hom.copy HeytingHom.copy

@[simp]
theorem coe_copy (f : HeytingHom α β) (f' : α → β) (h : f' = f) : ⇑(f.copy f' h) = f' :=
  rfl
#align heyting_hom.coe_copy HeytingHom.coe_copy

theorem copy_eq (f : HeytingHom α β) (f' : α → β) (h : f' = f) : f.copy f' h = f :=
  FunLike.ext' h
#align heyting_hom.copy_eq HeytingHom.copy_eq

variable (α)

/-- `id` as a `HeytingHom`. -/
protected def id : HeytingHom α α :=
  { BotHom.id _ with
    toLatticeHom := LatticeHom.id _
    map_himp' := fun _ _ => rfl }
#align heyting_hom.id HeytingHom.id

@[simp]
theorem coe_id : ⇑(HeytingHom.id α) = id :=
  rfl
#align heyting_hom.coe_id HeytingHom.coe_id

variable {α}

@[simp]
theorem id_apply (a : α) : HeytingHom.id α a = a :=
  rfl
#align heyting_hom.id_apply HeytingHom.id_apply

instance : Inhabited (HeytingHom α α) :=
  ⟨HeytingHom.id _⟩

instance : PartialOrder (HeytingHom α β) :=
  PartialOrder.lift _ FunLike.coe_injective

/-- Composition of `HeytingHom`s as a `HeytingHom`. -/
def comp (f : HeytingHom β γ) (g : HeytingHom α β) : HeytingHom α γ :=
  { f.toLatticeHom.comp g.toLatticeHom with
    toFun := f ∘ g
    map_bot' := by simp
    map_himp' := fun a b => by simp }
#align heyting_hom.comp HeytingHom.comp

variable {f f₁ f₂ : HeytingHom α β} {g g₁ g₂ : HeytingHom β γ}

@[simp]
theorem coe_comp (f : HeytingHom β γ) (g : HeytingHom α β) : ⇑(f.comp g) = f ∘ g :=
  rfl
#align heyting_hom.coe_comp HeytingHom.coe_comp

@[simp]
theorem comp_apply (f : HeytingHom β γ) (g : HeytingHom α β) (a : α) : f.comp g a = f (g a) :=
  rfl
#align heyting_hom.comp_apply HeytingHom.comp_apply

@[simp]
theorem comp_assoc (f : HeytingHom γ δ) (g : HeytingHom β γ) (h : HeytingHom α β) :
    (f.comp g).comp h = f.comp (g.comp h) :=
  rfl
#align heyting_hom.comp_assoc HeytingHom.comp_assoc

@[simp]
theorem comp_id (f : HeytingHom α β) : f.comp (HeytingHom.id α) = f :=
  ext fun _ => rfl
#align heyting_hom.comp_id HeytingHom.comp_id

@[simp]
theorem id_comp (f : HeytingHom α β) : (HeytingHom.id β).comp f = f :=
  ext fun _ => rfl
#align heyting_hom.id_comp HeytingHom.id_comp

theorem cancel_right (hf : Surjective f) : g₁.comp f = g₂.comp f ↔ g₁ = g₂ :=
  ⟨fun h => ext <| hf.forall.2 <| FunLike.ext_iff.1 h, congr_arg (fun a ↦ comp a f)⟩
#align heyting_hom.cancel_right HeytingHom.cancel_right

theorem cancel_left (hg : Injective g) : g.comp f₁ = g.comp f₂ ↔ f₁ = f₂ :=
  ⟨fun h => HeytingHom.ext fun a => hg <| by rw [← comp_apply, h, comp_apply], congr_arg _⟩
#align heyting_hom.cancel_left HeytingHom.cancel_left

end HeytingHom

namespace CoheytingHom

variable [CoheytingAlgebra α] [CoheytingAlgebra β] [CoheytingAlgebra γ] [CoheytingAlgebra δ]

instance : CoheytingHomClass (CoheytingHom α β) α β where
  coe f := f.toFun
  coe_injective' f g h := by obtain ⟨⟨⟨_, _⟩, _⟩, _⟩ := f; obtain ⟨⟨⟨_, _⟩, _⟩, _⟩ := g; congr
  map_sup f := f.map_sup'
  map_inf f := f.map_inf'
  map_top f := f.map_top'
  map_sdiff := CoheytingHom.map_sdiff'

-- Porting note: CoeFun undesired here in lean 4
-- /-- Helper instance for when there's too many metavariables to apply `FunLike.CoeFun`
-- directly. -/
-- instance : CoeFun (CoheytingHom α β) fun _ => α → β :=
--   FunLike.hasCoeToFun

-- @[simp] -- Porting note: not in simp-nf, simp can simplify lhs. Added aux simp lemma
theorem toFun_eq_coe {f : CoheytingHom α β} : f.toFun = (f : α → β) :=
  rfl
#align coheyting_hom.to_fun_eq_coe CoheytingHom.toFun_eq_coe

@[simp]
theorem toFun_eq_coe_aux {f : CoheytingHom α β} : (↑f.toLatticeHom) = ⇑f :=
  rfl

@[ext]
theorem ext {f g : CoheytingHom α β} (h : ∀ a, f a = g a) : f = g :=
  FunLike.ext f g h
#align coheyting_hom.ext CoheytingHom.ext

/-- Copy of a `CoheytingHom` with a new `toFun` equal to the old one. Useful to fix definitional
equalities. -/
protected def copy (f : CoheytingHom α β) (f' : α → β) (h : f' = f) : CoheytingHom α β where
  toFun := f'
  map_sup' := by simpa only [h] using map_sup f
  map_inf' := by simpa only [h] using map_inf f
  map_top' := by simpa only [h] using map_top f
  map_sdiff' := by simpa only [h] using map_sdiff f
#align coheyting_hom.copy CoheytingHom.copy

@[simp]
theorem coe_copy (f : CoheytingHom α β) (f' : α → β) (h : f' = f) : ⇑(f.copy f' h) = f' :=
  rfl
#align coheyting_hom.coe_copy CoheytingHom.coe_copy

theorem copy_eq (f : CoheytingHom α β) (f' : α → β) (h : f' = f) : f.copy f' h = f :=
  FunLike.ext' h
#align coheyting_hom.copy_eq CoheytingHom.copy_eq

variable (α)

/-- `id` as a `Coheytinghom`. -/
protected def id : CoheytingHom α α :=
  { TopHom.id _ with
    toLatticeHom := LatticeHom.id _
    map_sdiff' := fun _ _ => rfl }
#align coheyting_hom.id CoheytingHom.id

@[simp]
theorem coe_id : ⇑(CoheytingHom.id α) = id :=
  rfl
#align coheyting_hom.coe_id CoheytingHom.coe_id

variable {α}

@[simp]
theorem id_apply (a : α) : CoheytingHom.id α a = a :=
  rfl
#align coheyting_hom.id_apply CoheytingHom.id_apply

instance : Inhabited (CoheytingHom α α) :=
  ⟨CoheytingHom.id _⟩

instance : PartialOrder (CoheytingHom α β) :=
  PartialOrder.lift _ FunLike.coe_injective

/-- Composition of `CoheytingHom`s as a `CoheytingHom`. -/
def comp (f : CoheytingHom β γ) (g : CoheytingHom α β) : CoheytingHom α γ :=
  { f.toLatticeHom.comp g.toLatticeHom with
    toFun := f ∘ g
    map_top' := by simp
    map_sdiff' := fun a b => by simp }
#align coheyting_hom.comp CoheytingHom.comp

variable {f f₁ f₂ : CoheytingHom α β} {g g₁ g₂ : CoheytingHom β γ}

@[simp]
theorem coe_comp (f : CoheytingHom β γ) (g : CoheytingHom α β) : ⇑(f.comp g) = f ∘ g :=
  rfl
#align coheyting_hom.coe_comp CoheytingHom.coe_comp

@[simp]
theorem comp_apply (f : CoheytingHom β γ) (g : CoheytingHom α β) (a : α) : f.comp g a = f (g a) :=
  rfl
#align coheyting_hom.comp_apply CoheytingHom.comp_apply

@[simp]
theorem comp_assoc (f : CoheytingHom γ δ) (g : CoheytingHom β γ) (h : CoheytingHom α β) :
    (f.comp g).comp h = f.comp (g.comp h) :=
  rfl
#align coheyting_hom.comp_assoc CoheytingHom.comp_assoc

@[simp]
theorem comp_id (f : CoheytingHom α β) : f.comp (CoheytingHom.id α) = f :=
  ext fun _ => rfl
#align coheyting_hom.comp_id CoheytingHom.comp_id

@[simp]
theorem id_comp (f : CoheytingHom α β) : (CoheytingHom.id β).comp f = f :=
  ext fun _ => rfl
#align coheyting_hom.id_comp CoheytingHom.id_comp

theorem cancel_right (hf : Surjective f) : g₁.comp f = g₂.comp f ↔ g₁ = g₂ :=
  ⟨fun h => ext <| hf.forall.2 <| FunLike.ext_iff.1 h, congr_arg (fun a ↦ comp a f)⟩
#align coheyting_hom.cancel_right CoheytingHom.cancel_right

theorem cancel_left (hg : Injective g) : g.comp f₁ = g.comp f₂ ↔ f₁ = f₂ :=
  ⟨fun h => CoheytingHom.ext fun a => hg <| by rw [← comp_apply, h, comp_apply], congr_arg _⟩
#align coheyting_hom.cancel_left CoheytingHom.cancel_left

end CoheytingHom

namespace BiheytingHom

variable [BiheytingAlgebra α] [BiheytingAlgebra β] [BiheytingAlgebra γ] [BiheytingAlgebra δ]

instance : BiheytingHomClass (BiheytingHom α β) α β where
  coe f := f.toFun
  coe_injective' f g h := by obtain ⟨⟨⟨_, _⟩, _⟩, _⟩ := f; obtain ⟨⟨⟨_, _⟩, _⟩, _⟩ := g; congr
  map_sup f := f.map_sup'
  map_inf f := f.map_inf'
  map_himp f := f.map_himp'
  map_sdiff f := f.map_sdiff'

-- Porting note: CoeFun undesired here in lean 4
-- /-- Helper instance for when there's too many metavariables to apply `FunLike.CoeFun`
-- directly. -/
-- instance : CoeFun (BiheytingHom α β) fun _ => α → β :=
--   FunLike.hasCoeToFun

-- @[simp] -- Porting note: not in simp-nf, simp can simplify lhs. Added aux simp lemma
theorem toFun_eq_coe {f : BiheytingHom α β} : f.toFun = (f : α → β) :=
  rfl
#align biheyting_hom.to_fun_eq_coe BiheytingHom.toFun_eq_coe

@[simp]
theorem toFun_eq_coe_aux {f : BiheytingHom α β} : (↑f.toLatticeHom) = ⇑f :=
  rfl

@[ext]
theorem ext {f g : BiheytingHom α β} (h : ∀ a, f a = g a) : f = g :=
  FunLike.ext f g h
#align biheyting_hom.ext BiheytingHom.ext

/-- Copy of a `BiheytingHom` with a new `toFun` equal to the old one. Useful to fix definitional
equalities. -/
protected def copy (f : BiheytingHom α β) (f' : α → β) (h : f' = f) : BiheytingHom α β where
  toFun := f'
  map_sup' := by simpa only [h] using map_sup f
  map_inf' := by simpa only [h] using map_inf f
  map_himp' := by simpa only [h] using map_himp f
  map_sdiff' := by simpa only [h] using map_sdiff f
#align biheyting_hom.copy BiheytingHom.copy

@[simp]
theorem coe_copy (f : BiheytingHom α β) (f' : α → β) (h : f' = f) : ⇑(f.copy f' h) = f' :=
  rfl
#align biheyting_hom.coe_copy BiheytingHom.coe_copy

theorem copy_eq (f : BiheytingHom α β) (f' : α → β) (h : f' = f) : f.copy f' h = f :=
  FunLike.ext' h
#align biheyting_hom.copy_eq BiheytingHom.copy_eq

variable (α)

/-- `id` as a `BiheytingHom`. -/
protected def id : BiheytingHom α α :=
  { HeytingHom.id _, CoheytingHom.id _ with toLatticeHom := LatticeHom.id _ }
#align biheyting_hom.id BiheytingHom.id

@[simp]
theorem coe_id : ⇑(BiheytingHom.id α) = id :=
  rfl
#align biheyting_hom.coe_id BiheytingHom.coe_id

variable {α}

@[simp]
theorem id_apply (a : α) : BiheytingHom.id α a = a :=
  rfl
#align biheyting_hom.id_apply BiheytingHom.id_apply

instance : Inhabited (BiheytingHom α α) :=
  ⟨BiheytingHom.id _⟩

instance : PartialOrder (BiheytingHom α β) :=
  PartialOrder.lift _ FunLike.coe_injective

/-- Composition of `BiheytingHom`s as a `BiheytingHom`. -/
def comp (f : BiheytingHom β γ) (g : BiheytingHom α β) : BiheytingHom α γ :=
  { f.toLatticeHom.comp g.toLatticeHom with
    toFun := f ∘ g
    map_himp' := fun a b => by simp
    map_sdiff' := fun a b => by simp }
#align biheyting_hom.comp BiheytingHom.comp

variable {f f₁ f₂ : BiheytingHom α β} {g g₁ g₂ : BiheytingHom β γ}

@[simp]
theorem coe_comp (f : BiheytingHom β γ) (g : BiheytingHom α β) : ⇑(f.comp g) = f ∘ g :=
  rfl
#align biheyting_hom.coe_comp BiheytingHom.coe_comp

@[simp]
theorem comp_apply (f : BiheytingHom β γ) (g : BiheytingHom α β) (a : α) : f.comp g a = f (g a) :=
  rfl
#align biheyting_hom.comp_apply BiheytingHom.comp_apply

@[simp]
theorem comp_assoc (f : BiheytingHom γ δ) (g : BiheytingHom β γ) (h : BiheytingHom α β) :
    (f.comp g).comp h = f.comp (g.comp h) :=
  rfl
#align biheyting_hom.comp_assoc BiheytingHom.comp_assoc

@[simp]
theorem comp_id (f : BiheytingHom α β) : f.comp (BiheytingHom.id α) = f :=
  ext fun _ => rfl
#align biheyting_hom.comp_id BiheytingHom.comp_id

@[simp]
theorem id_comp (f : BiheytingHom α β) : (BiheytingHom.id β).comp f = f :=
  ext fun _ => rfl
#align biheyting_hom.id_comp BiheytingHom.id_comp

theorem cancel_right (hf : Surjective f) : g₁.comp f = g₂.comp f ↔ g₁ = g₂ :=
  ⟨fun h => ext <| hf.forall.2 <| FunLike.ext_iff.1 h, congr_arg (fun a ↦ comp a f)⟩
#align biheyting_hom.cancel_right BiheytingHom.cancel_right

theorem cancel_left (hg : Injective g) : g.comp f₁ = g.comp f₂ ↔ f₁ = f₂ :=
  ⟨fun h => BiheytingHom.ext fun a => hg <| by rw [← comp_apply, h, comp_apply], congr_arg _⟩
#align biheyting_hom.cancel_left BiheytingHom.cancel_left

end BiheytingHom


/-
Copyright (c) 2014 Microsoft Corporation. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Leonardo de Moura
-/
prelude
import init.logic init.control.monad init.control.alternative
open decidable

universes u v

namespace option

def to_monad {m : Type → Type} [monad m] [alternative m] {A} : option A → m A
| none := failure
| (some a) := return a

def get_or_else {α : Type u} : option α → α → α
| (some x) _ := x
| none     e := e

def is_some {α : Type u} : option α → bool
| (some _) := tt
| none     := ff

def is_none {α : Type u} : option α → bool
| (some _) := ff
| none     := tt

def get {α : Type u} : Π {o : option α}, is_some o → α
| (some x) h := x
| none     h := false.rec _ $ bool.ff_ne_tt h

def rhoare {α : Type u} : bool → α → option α
| tt a := none
| ff a := some a

def lhoare {α : Type u} : α → option α → α
| a none     := a
| _ (some b) := b

infixr `|>`:1 := rhoare
infixr `<|`:1 := lhoare

@[inline] protected def bind {α : Type u} {β : Type v} : option α → (α → option β) → option β
| none     b := none
| (some a) b := b a

protected def map {α β} (f : α → β) (o : option α) : option β :=
option.bind o (some ∘ f)

theorem map_id {α} : (option.map id : option α → option α) = id :=
funext (λo, match o with | none := rfl | some x := rfl end)

instance : monad option :=
{pure := @some, bind := @option.bind, map := @option.map}

protected def orelse {α : Type u} : option α → option α → option α
| (some a) o         := some a
| none     (some a)  := some a
| none     none      := none

instance : alternative option :=
{ failure := @none,
  orelse  := @option.orelse }

end option

instance (α : Type u) : inhabited (option α) :=
⟨none⟩

instance {α : Type u} [d : decidable_eq α] : decidable_eq (option α)
| none      none      := is_true rfl
| none      (some v₂) := is_false (λ h, option.no_confusion h)
| (some v₁) none      := is_false (λ h, option.no_confusion h)
| (some v₁) (some v₂) :=
  match (d v₁ v₂) with
  | (is_true e)  := is_true (congr_arg (@some α) e)
  | (is_false n) := is_false (λ h, option.no_confusion h (λ e, absurd e n))
  end


import .basic group_theory.subgroup

variables {ι : Type*} {G : ι → Type*}
variables [decidable_eq ι] [Π i, decidable_eq (G i)]
variables [Π i, group (G i)]

open coprod  subgroup function

lemma mul_aux_mem (S : Π i, subgroup (G i)) : ∀ (l₁ l₂ : list (Σ i, G i))
  (h₁ : ∀ a : Σ i, G i, a ∈ l₁ → a.2 ∈ S a.1)
  (h₂ : ∀ a : Σ i, G i, a ∈ l₂ → a.2 ∈ S a.1)
  {i : ι} {a : G i} (ha : (⟨i, a⟩ : Σ i, G i) ∈ pre.mul_aux l₁ l₂),
  a ∈ S i
| []           l₂      := by simp [pre.mul_aux]
| (⟨j, b⟩::l₁) []      := begin
    assume h₁ _ i a ha,
    simp only [pre.mul_aux, list.mem_reverse, list.mem_cons_iff] at ha,
    rcases ha with ⟨rfl, hab⟩ | hia,
    { rw [heq_iff_eq] at hab,
      subst hab,
      exact h₁ ⟨i, a⟩ (list.mem_cons_self _ _) },
    { exact h₁ ⟨i, a⟩ (list.mem_cons_of_mem _ hia) }
  end
| (⟨j, b⟩::l₁) (⟨k, c⟩::l₂) := begin
  assume h₁ h₂ i a ha,
  simp only [pre.mul_aux] at ha,
  split_ifs at ha,
  { exact mul_aux_mem _ _
      (λ d hd, h₁ d (list.mem_cons_of_mem _ hd))
      (λ d hd, h₂ d (list.mem_cons_of_mem _ hd))
      ha },
  { dsimp at h,
    subst j,
    simp only [list.reverse_core_eq, list.mem_append, list.mem_cons_iff,
      list.mem_reverse, cast_eq] at ha,
    simp only [cast_eq] at *,
    rcases ha with ha | ⟨rfl, h, h⟩ | ha,
    { exact h₁ ⟨i, a⟩ (list.mem_cons_of_mem _ ha) },
    { exact subgroup.mul_mem _
        (h₁ ⟨i, b⟩ (list.mem_cons_self _ _))
        (h₂ ⟨i, c⟩ (list.mem_cons_self _ _)) },
    { exact h₂ ⟨i, a⟩ (list.mem_cons_of_mem _ ha) } },
  { clear_aux_decl,
    simp only [list.reverse_core_eq, list.mem_append, list.mem_cons_iff,
      list.mem_reverse] at ha,
    rcases ha with ha | ⟨rfl, hab⟩ | ⟨rfl, hab⟩ | ha,
    { exact h₁ ⟨i, a⟩ (list.mem_cons_of_mem _ ha) },
    { rw [heq_iff_eq] at hab,
      subst hab,
      exact h₁ ⟨i, a⟩ (list.mem_cons_self _ _) },
    { rw [heq_iff_eq] at hab,
      subst hab,
      exact h₂ ⟨i, a⟩ (list.mem_cons_self _ _) },
    { exact h₂ ⟨i, a⟩ (list.mem_cons_of_mem _ ha) } }
end

def blah (S : Π i, subgroup (G i)) : subgroup (coprod G) :=
{ carrier  := { w : coprod G | ∀ (a : Σ i, G i), a ∈ w.to_list → a.2 ∈ S a.1 },
  one_mem' := λ a h, h.elim,
  mul_mem' := begin
    rintros ⟨l₁, hl₁⟩ ⟨l₂, hl₂⟩ h₁ h₂ ⟨i, a⟩ h,
    exact mul_aux_mem S l₁.reverse l₂ (by simpa using h₁) (by simpa using h₂) h
  end,
  inv_mem' := begin
    rintros ⟨l, hl⟩ h i hi,
    dsimp at *,
    replace hi : i ∈ (l.map _).reverse := hi,
    rw [← inv_mem_iff],
    simp at hi,
    rcases hi with ⟨j, a, ha, rfl⟩,
    simp,
    exact h _ ha
  end }

lemma mem_blah (S : Π i, subgroup (G i)) (w : coprod G) :
  w ∈ blah S ↔ ∀ (a : Σ i, G i), a ∈ w.to_list → a.2 ∈ S a.1 := iff.rfl

variable {S : Π i, subgroup (G i)}

@[simp] lemma of_mem_blah_iff {i : ι} {a : G i} : of i a ∈ blah S ↔ a ∈ S i :=
begin
  simp only [mem_blah, to_list_of],
  split_ifs,
  { simp [*, subgroup.one_mem] },
  { simp only [list.mem_singleton],
    split,
    { exact λ h, h ⟨i, a⟩ rfl },
    { assume ha j hj,
      subst j,
      exact ha } }
end

lemma blah_eq_supr : blah S = ⨆ i, (S i).map (of i) :=
le_antisymm
  (λ w hw, begin
    cases w with l hl,
    induction l with i l ih,
    { simp [subgroup.one_mem] },
    { rw [cons_eq_of_mul],
      refine subgroup.mul_mem _ _ _,
      { exact (le_supr (λ i, (S i).map begin show G i →* coprod G, from of i end) i.1 : _)
        (mem_map.2 ⟨i.2, hw _ (list.mem_cons_self _ _), rfl⟩) },
      { exact ih _ (λ j hj, hw _ (list.mem_cons_of_mem _ hj)) } }
  end)
  (supr_le (λ i a ha, begin
    rw [mem_map] at ha,
    rcases ha with ⟨a, ha, rfl⟩,
    simp only [to_list_of, mem_blah],
    split_ifs,
    { simp },
    { simp only [list.mem_singleton],
      assume a ha,
      subst a,
      exact ha }
  end))


/-
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.category.PartOrd
import order.hom.lattice

/-!
# The categories of semilattices

This defines `SemilatSup` and `SemilatInf`, the categories of sup-semilattices with a bottom
element and inf-semilattices with a top element.

## References

* [nLab, *semilattice*](https://ncatlab.org/nlab/show/semilattice)
-/

universes u
open category_theory

/-- The category of sup-semilattices with a bottom element. -/
structure SemilatSup : Type.{u+1} :=
(X : Type.{u})
[is_semilattice_sup : semilattice_sup X]
[is_order_bot : order_bot X]

/-- The category of inf-semilattices with a top element. -/
structure SemilatInf : Type.{u+1} :=
(X : Type.{u})
[is_semilattice_inf : semilattice_inf X]
[is_order_top : order_top X]

attribute [protected] SemilatSup.X SemilatInf.X

namespace SemilatSup

instance : has_coe_to_sort SemilatSup Type* := ⟨SemilatSup.X⟩
attribute [instance] is_semilattice_sup is_order_bot

/-- Construct a bundled `SemilatSup` from a `semilattice_sup`. -/
def of (α : Type*) [semilattice_sup α] [order_bot α] : SemilatSup := ⟨α⟩

@[simp] lemma coe_of (α : Type*) [semilattice_sup α] [order_bot α] : ↥(of α) = α := rfl

instance : inhabited SemilatSup := ⟨of punit⟩

instance : large_category.{u} SemilatSup :=
{ hom := λ X Y, sup_bot_hom X Y,
  id := λ X, sup_bot_hom.id X,
  comp := λ X Y Z f g, g.comp f,
  id_comp' := λ X Y, sup_bot_hom.comp_id,
  comp_id' := λ X Y, sup_bot_hom.id_comp,
  assoc' := λ W X Y Z _ _ _, sup_bot_hom.comp_assoc _ _ _ }

instance : concrete_category SemilatSup :=
{ forget := { obj := SemilatSup.X, map := λ X Y, coe_fn },
  forget_faithful := ⟨λ X Y, fun_like.coe_injective⟩ }

instance has_forget_to_PartOrd : has_forget₂ SemilatSup PartOrd :=
{ forget₂ := { obj := λ X, ⟨X⟩, map := λ X Y f, f } }

@[simp] lemma coe_forget_to_PartOrd (X : SemilatSup) :
  ↥((forget₂ SemilatSup PartOrd).obj X) = ↥X := rfl

end SemilatSup

namespace SemilatInf

instance : has_coe_to_sort SemilatInf Type* := ⟨SemilatInf.X⟩

attribute [instance] is_semilattice_inf is_order_top

/-- Construct a bundled `SemilatInf` from a `semilattice_inf`. -/
def of (α : Type*) [semilattice_inf α] [order_top α] : SemilatInf := ⟨α⟩

@[simp] lemma coe_of (α : Type*) [semilattice_inf α] [order_top α] : ↥(of α) = α := rfl

instance : inhabited SemilatInf := ⟨of punit⟩

instance : large_category.{u} SemilatInf :=
{ hom := λ X Y, inf_top_hom X Y,
  id := λ X, inf_top_hom.id X,
  comp := λ X Y Z f g, g.comp f,
  id_comp' := λ X Y, inf_top_hom.comp_id,
  comp_id' := λ X Y, inf_top_hom.id_comp,
  assoc' := λ W X Y Z _ _ _, inf_top_hom.comp_assoc _ _ _ }

instance : concrete_category SemilatInf :=
{ forget := { obj := SemilatInf.X, map := λ X Y, coe_fn },
  forget_faithful := ⟨λ X Y, fun_like.coe_injective⟩ }

instance has_forget_to_PartOrd : has_forget₂ SemilatInf PartOrd :=
{ forget₂ := { obj := λ X, ⟨X⟩, map := λ X Y f, f } }

@[simp] lemma coe_forget_to_PartOrd (X : SemilatInf) :
  ↥((forget₂ SemilatInf PartOrd).obj X) = ↥X := rfl

end SemilatInf

/-! ### Order dual -/

namespace SemilatSup

/-- Constructs an isomorphism of lattices from an order isomorphism between them. -/
@[simps] def iso.mk {α β : SemilatSup.{u}} (e : α ≃o β) : α ≅ β :=
{ hom := e,
  inv := e.symm,
  hom_inv_id' := by { ext, exact e.symm_apply_apply _ },
  inv_hom_id' := by { ext, exact e.apply_symm_apply _ } }

/-- `order_dual` as a functor. -/
@[simps] def dual : SemilatSup ⥤ SemilatInf :=
{ obj := λ X, SemilatInf.of Xᵒᵈ, map := λ X Y, sup_bot_hom.dual }

end SemilatSup

namespace SemilatInf

/-- Constructs an isomorphism of lattices from an order isomorphism between them. -/
@[simps] def iso.mk {α β : SemilatInf.{u}} (e : α ≃o β) : α ≅ β :=
{ hom := e,
  inv := e.symm,
  hom_inv_id' := by { ext, exact e.symm_apply_apply _ },
  inv_hom_id' := by { ext, exact e.apply_symm_apply _ } }

/-- `order_dual` as a functor. -/
@[simps] def dual : SemilatInf ⥤ SemilatSup :=
{ obj := λ X, SemilatSup.of Xᵒᵈ, map := λ X Y, inf_top_hom.dual }

end SemilatInf

/-- The equivalence between `SemilatSup` and `SemilatInf` induced by `order_dual` both ways.
-/
@[simps functor inverse]
def SemilatSup_equiv_SemilatInf : SemilatSup ≌ SemilatInf :=
equivalence.mk SemilatSup.dual SemilatInf.dual
  (nat_iso.of_components (λ X, SemilatSup.iso.mk $ order_iso.dual_dual X) $ λ X Y f, rfl)
  (nat_iso.of_components (λ X, SemilatInf.iso.mk $ order_iso.dual_dual X) $ λ X Y f, rfl)

lemma SemilatSup_dual_comp_forget_to_PartOrd :
  SemilatSup.dual ⋙ forget₂ SemilatInf PartOrd =
    forget₂ SemilatSup PartOrd ⋙ PartOrd.dual := rfl

lemma SemilatInf_dual_comp_forget_to_PartOrd :
  SemilatInf.dual ⋙ forget₂ SemilatSup PartOrd =
    forget₂ SemilatInf PartOrd ⋙ PartOrd.dual := rfl


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

import topology.instances.complex tactic

/-!
# Path-Connectedness

This file defines path-connectedness for pairs of points of a topological space, path components
as well as path-connected subsets of a space and path-connected spaces. We build an interface for
these definitions and prove basic related theorems, including pointwise path-connectedness is an
equivalence relation and path-connectedness implies connectedness but not vice-versa (deleted comb
space). We also show some side-lemmas like connectedness of a dense subset implies that of the
entire set, continuity on restricted domains and an alternate characterisation of connectedness.

## Important definitions and classes

* `are_path_connected` : path-connectedness of pairs of points
* `is_pre_path_connected`, `is_path_connected` : path-connected sets (the latter being non-empty)
* `pre_path_connected_space`, `path_connected_space` : path-connected spaces (similar to previous)
* `path_component` : path_components of a space

## Implementation notes

Path-connectedness for sets and points has been implemented as `Prop`, while path-connected spaces
have been defined as classes.

## References

* J. R. Munkres : *Topology* :
https://www.pearson.com/us/higher-education/product/Munkres-Topology-2nd-Edition/9780131816299.html
* K. Conrad : *Spaces that are Connected but not Path-Connected* :
https://kconrad.math.uconn.edu/blurbs/topology/connnotpathconn.pdf

The theorem `continuous_on_if` uses a lemma proved under `continuous_if` in *topology\basic.lean*.
The interface for path-connectedness as well as several of the other proofs have been inspired from
*topology\subset_properties.lean*.
-/

open set
variables {α : Type*} {β : Type*}
variables [topological_space α] [topological_space β]
variables {A B : set α}
variables a b c : A
local notation `I01` := Icc (0 : ℝ) 1

/-- If a dense subset is preconnected, then so is the entire set -/
theorem is_preconnected.dense_subset (hAB : A ⊆ B) (hBcA : B ⊆ closure A)
  (hA : is_preconnected A) : is_preconnected B :=
λ C D hCo hDo hcov ⟨p, hpB, hpC⟩ ⟨q, hqB, hqD⟩,
let ⟨x, hxC, hxA⟩ := mem_closure_iff.mp (hBcA hpB) C hCo hpC in
let ⟨y, hyC, hyD⟩ := mem_closure_iff.mp (hBcA hqB) D hDo hqD in
let ⟨w, hwA, hwCD⟩ := hA C D hCo hDo (trans hAB hcov) ⟨x, hxA, hxC⟩ ⟨y, hyD, hyC⟩ in
⟨w, hAB hwA, hwCD⟩

/-- Continuity on restricted domains -/
theorem continuous_on_if {D : set α} {p : α → Prop} {f g : α → β}
  {h : ∀ a, decidable (p a)} (hp : ∀ a ∈ frontier {a | p a} ∩ D, f a = g a)
  (hf : continuous_on f $ closure {x | p x} ∩ D) (hg : continuous_on g $ closure {x | ¬p x} ∩ D) :
  continuous_on (λ a, @ite (p a) (h a) β (f a) (g a)) D :=
begin
  rw continuous_on_iff_is_closed,
  intros s hs,
  obtain ⟨sf, hsfc, hsf⟩ := (continuous_on_iff_is_closed.mp hf) s hs,
  obtain ⟨sg, hsgc, hsg⟩ := (continuous_on_iff_is_closed.mp hg) s hs,
  refine ⟨sf ∩ closure {a : α | p a} ∪ sg ∩ closure {a : α | ¬p a}, _, _⟩,
  { simp only [is_closed_closure, is_closed_union, is_closed_inter, *]  },
  suffices heq : (λ a, ite (p a) (f a) (g a)) ⁻¹' s ∩ D =
    ((f ⁻¹' s ∩ closure {a | p a}) ∪ (g ⁻¹' s ∩ closure {a | ¬ p a})) ∩ D,
  { rw [heq, union_inter_distrib_right, union_inter_distrib_right],
    assoc_rw [hsf, hsg] },
  ext a,
  classical,
  by_cases hf : a ∈ frontier {a | p a} ∩ D,
  { have hac := hf.left.left,
    have hai : a ∈ closure {a | ¬ p a} := (@closure_compl _ _ p).symm ▸ mem_compl hf.left.right,
    by_cases hpa : p a;
    { simp [hpa, hp a hf, hac, hai, iff_def];
      exact and.intro }},
  rw [inter_comm, inter_comm _ D],
  refine and_congr_right (λ had, _),
  replace hf := not_and'.mp hf had,
  by_cases hpa : p a,
  { have hc : a ∈ closure {a | p a} := subset_closure hpa,
    have hnc : a ∉ closure {a | ¬ p a},
    { show a ∉ closure {a | p a}ᶜ,
      simpa [closure_compl, frontier, hc] using hf  },
    simp [hpa, hc, hnc] },
  have hc : a ∈ closure {a | ¬ p a} := subset_closure hpa,
  have hnc : a ∉ closure {a | p a},
  { change a ∈ closure {a | p a}ᶜ at hc,
    simp [closure_compl] at hc,
    simpa [frontier, hc] using hf },
  simp [hpa, hc, hnc],
end

/-- Two points in a set `A` are path-connected if there exists a path in `A` between them. -/
def are_path_connected (a b : A) :=
  ∃ f : ℝ → α, (∀ x ≤ 0, f x = a) ∧ (∀ x, 1 ≤ x → f x = b) ∧ range f ⊆ A ∧ continuous f

theorem are_path_connected.refl : are_path_connected a a :=
⟨(λ _, a), (λ _ _, rfl), (λ _ _, rfl), (λ _ ⟨_, hx⟩, hx ▸ a.2), continuous_const⟩

theorem are_path_connected.symm : are_path_connected a b → are_path_connected b a :=
λ ⟨f, h0, h1, hr, hc⟩,
⟨λ x, f (1-x),
λ _ _, h1 _ (by linarith),
λ _ _, h0 _ (by linarith),
λ y ⟨x, hy⟩, hr ⟨1-x, hy⟩,
continuous.comp hc $ continuous.sub continuous_const continuous_id⟩

theorem are_path_connected.trans :
  are_path_connected a b → are_path_connected b c → are_path_connected a c :=
begin
  rintro ⟨f, hf0, hf1, hfr, hfc⟩ ⟨g, hg0, hg1, hgr, hgc⟩,
  refine ⟨λ x, ite (x ≤ 1/2) (f (2*x)) (g (2*x - 1)), λ x hx, _, λ x hx, _, _, _⟩,
      { rw ←hf0 (2*x) (by linarith),
        exact if_pos (by linarith)  },
    { rw ←hg1 (2*x-1) (by linarith),
      exact if_neg (by linarith)  },
  { rintro y ⟨x, rfl⟩,
    by_cases h0 : x ≤ 1/2,
      exact hfr ⟨2*x, (if_pos h0).symm⟩,
    exact hgr ⟨2*x - 1, (if_neg h0).symm⟩ },
  refine continuous_if (λ x hx, _) _ _,
    { have h : x = 1/2 := (frontier_le_subset_eq continuous_id continuous_const) hx,
      norm_num [h, hg0, hf1]  },
  { exact continuous.comp hfc (continuous.mul continuous_const continuous_id) },
  refine continuous.comp hgc (continuous.add _ continuous_const),
  exact continuous.mul continuous_const continuous_id,
end

instance : is_equiv A are_path_connected :=
{refl:= are_path_connected.refl, trans:= are_path_connected.trans, symm:= are_path_connected.symm}

theorem are_path_connected.mono {a b : A} {B} (hAB : A ⊆ B) :
  are_path_connected a b → are_path_connected ⟨a.1, hAB a.2⟩ ⟨b.1, hAB b.2⟩ :=
λ ⟨p, hp0, hp1, hpr, hpc⟩, ⟨p, hp0, hp1, trans hpr hAB, hpc⟩

/-- A weaker characterisation of `are_path_connected` for ease of proving concrete examples -/
theorem are_path_connected_iff {a b : A} : are_path_connected a b ↔
  ∃ f : ℝ → α, f 0 = a ∧ f 1 = b ∧ f '' I01 ⊆ A ∧ continuous_on f I01 :=
begin
  split; rintro ⟨p, h0, h1, hr, hc⟩,
  { use [p, h0 0 (le_refl 0), h1 1 (le_refl 1),
      trans (image_subset_range _ _) hr, continuous.continuous_on hc] },

  refine ⟨λ x, ite (x ≤ 0) a (ite (x ≥ 1) b (p x)),λ _ hx, if_pos hx,
    λ _ hx, trans (if_neg (by linarith)) (if_pos hx), _, _⟩,
  { rintro y ⟨x, rfl⟩,
    by_cases hx0 : x ≤ 0,
      {convert a.2,
      exact if_pos hx0},
    by_cases hx1 : x ≥ 1,
      {convert b.2,
      exact trans (if_neg hx0) (if_pos hx1)},
    refine hr ⟨x, _, symm $ trans (if_neg hx0) (if_neg hx1)⟩,
    exact Ioo_subset_Icc_self ⟨lt_of_not_ge hx0, lt_of_not_ge hx1⟩  },
  rw continuous_iff_continuous_on_univ,
  refine continuous_on_if (λ x hx, _) continuous_on_const _,
  { have : x = 0 := (frontier_le_subset_eq continuous_id continuous_const) hx.left,
    rw [this, if_neg (not_le_of_gt zero_lt_one), h0]  },
  refine continuous_on_if (λ x hx, _) continuous_on_const _,
  { have : 1 = x := (frontier_le_subset_eq continuous_const continuous_id) hx.left, cc  },
  push_neg,
  show continuous_on p (closure (Iio 1) ∩ (closure (Ioi 0) ∩ univ)),
  rwa [inter_univ, closure_Iio, closure_Ioi, inter_comm],
end

/-- A set is pre-path-connected if each pair of points in it is path-connected. -/
def is_pre_path_connected (A : set α) := ∀ a b, @are_path_connected _ _ A a b

theorem is_pre_path_connected_empty : is_pre_path_connected (∅ : set α) := λ x, x.2.elim

theorem is_pre_path_connected_sUnion (x : α) {c : set (set α)} (H1 : ∀ s ∈ c, x ∈ s)
  (H2 : ∀ s ∈ c, is_pre_path_connected s) : is_pre_path_connected (⋃₀ c) :=
have H : ∀ y ∈ ⋃₀ c, ∃ t ⊆ ⋃₀ c, x ∈ t ∧ y ∈ t ∧ is_pre_path_connected t,
  from λ y ⟨s, hs, hy⟩, ⟨s, subset_sUnion_of_mem hs, H1 s hs, hy, H2 s hs⟩,
λ a b,
let ⟨sa, hsa, hxsa, hasa, hsap⟩ := H a a.2 in
let ⟨sb, hsb, hxsb, hbsb, hsbp⟩ := H b b.2 in
let hxa := are_path_connected.mono hsa (hsap ⟨x, hxsa⟩ ⟨a, hasa⟩) in
let hxb := are_path_connected.mono hsb (hsbp ⟨x, hxsb⟩ ⟨b, hbsb⟩) in
trans (symm hxa) hxb

theorem is_pre_path_connected_Union {γ : Type*} (x : α) {p : γ → set α} (hx : ∀ g, x ∈ p g)
  (hp : ∀ g, is_pre_path_connected (p g)) : is_pre_path_connected (⋃ i, p i) :=
λ ⟨a, ha⟩ ⟨b, hb⟩,
let ⟨ga, hga⟩ := mem_Union.mp ha in
let ⟨gb, hgb⟩ := mem_Union.mp hb in
trans (are_path_connected.mono (subset_Union _ _) (hp ga ⟨a, hga⟩ ⟨x, hx ga⟩))
  (are_path_connected.mono (subset_Union _ _) (hp gb ⟨x, hx gb⟩ ⟨b, hgb⟩))

theorem is_pre_path_connected.union (x : α) {s t : set α} (hxs : x ∈ s) (hxt : x ∈ t)
  (hs : is_pre_path_connected s) (ht : is_pre_path_connected t) : is_pre_path_connected (s ∪ t) :=
sUnion_pair s t ▸ is_pre_path_connected_sUnion x
  (by rintro r (rfl | rfl | h); assumption)
  (by rintro r (rfl | rfl | h); assumption)

theorem is_pre_path_connected.image {s : set α} (H : is_pre_path_connected s) (f : α → β)
  (hf : continuous_on f s) : is_pre_path_connected (f '' s) :=
λ ⟨fx, x, hx, hfx⟩ ⟨fy, y, hy, hfy⟩,
let ⟨p, hp0, hp1, hpr, hpc⟩ := H ⟨x, hx⟩ ⟨y, hy⟩ in
let hpi := (trans (image_subset_range p I01) hpr) in
are_path_connected_iff.mpr
  ⟨λ x, f (p x),
  by simp [hp0 0 (le_refl 0), hfx],
  by simp [hp1 1 (le_refl 1), hfy],
  symm (image_comp f p I01) ▸ image_subset f hpi,
  continuous_on.comp hf (continuous.continuous_on hpc) (image_subset_iff.mp hpi)⟩

theorem is_pre_path_connected.is_pre_connected (h : is_pre_path_connected A) : is_preconnected A :=
begin
  have hw := @is_preconnected_univ ℝ _ _,
  dsimp [is_preconnected] at hw ⊢,
  contrapose! hw,
  obtain ⟨U, V, hUo, hVo, hcov, ⟨x, ⟨hxa, hxu⟩⟩, ⟨y, ⟨hya, hyu⟩⟩, hi⟩ := hw,
  obtain ⟨f, h0, h1, hr, hc⟩ := h ⟨x, hxa⟩ ⟨y, hya⟩,
  refine ⟨f ⁻¹' U, f ⁻¹' V, hc U hUo, hc V hVo, _, ⟨0, _⟩, ⟨1, _⟩, _⟩,
      { rw ←preimage_union,
        refine trans (trans _ (preimage_mono hr)) (preimage_mono hcov),
        rw preimage_range },
    { rwa [univ_inter, mem_preimage, h0 0 (le_refl 0)]  },
  { rwa [univ_inter, mem_preimage, h1 1 (le_refl 1)]  },
  contrapose! hi,
  rw [univ_inter, ←preimage_inter] at hi,
  cases hi with z hz,
  use [f z, hr ⟨z, rfl⟩, hz],
end

/-- A set is path-connected if it is nonempty and pre-path-connected. -/
def is_path_connected (A : set α) := A.nonempty ∧ is_pre_path_connected A

theorem is_path_connected.nonempty (h : is_path_connected A) : A.nonempty := h.left
theorem is_path_connected.is_pre_path_connected (h : is_path_connected A) :
  is_pre_path_connected A := h.right

theorem is_path_connected_singleton {a} : is_path_connected ({a} : set α) :=
⟨⟨a, rfl⟩, λ ⟨x, hx⟩ ⟨y, hy⟩, by convert are_path_connected.refl ⟨a, mem_singleton a⟩⟩

lemma is_path_connected_iff : is_path_connected A ↔ (∃ x : A, ∀ y : A, are_path_connected x y) :=
⟨λ ⟨⟨w, hw⟩, ha⟩, ⟨⟨w, hw⟩, λ x, ha ⟨w, hw⟩ x⟩,
λ ⟨⟨w, hw⟩, ha⟩, ⟨⟨w, hw⟩, λ x y, trans (symm (ha x)) (ha y)⟩⟩

theorem is_path_connected.is_connected (h : is_path_connected A): is_connected A :=
⟨h.left, is_pre_path_connected.is_pre_connected h.right⟩

theorem is_path_connected.union {s t : set α} (hst : (s ∩ t).nonempty)
  (hs : is_path_connected s) (ht : is_path_connected t) : is_path_connected (s ∪ t) :=
let ⟨x, hxs, hxt⟩ := hst in
⟨⟨x, or.inl hxs⟩, is_pre_path_connected.union x hxs hxt hs.right ht.right⟩

theorem is_path_connected.image {s : set α} (H : is_path_connected s) (f : α → β)
  (hf : continuous_on f s) : is_path_connected (f '' s) :=
let ⟨x, hx⟩ := H.1 in ⟨⟨f x, mem_image_of_mem f hx⟩, is_pre_path_connected.image H.2 f hf⟩

/-- The path component of a point is the maximal path connected set containing this point. -/
def path_component (x) := ⋃₀ {s : set α | is_pre_path_connected s ∧ x ∈ s}

theorem mem_path_component {x : α} : x ∈ path_component x :=
mem_sUnion_of_mem (mem_singleton x) ⟨is_path_connected_singleton.right, mem_singleton x⟩

theorem is_path_connected_path_component {x : α} : is_path_connected (path_component x) :=
⟨⟨x, mem_path_component⟩, is_pre_path_connected_sUnion x (λ _, and.right) (λ _, and.left)⟩

theorem subset_path_component {x : α} {A : set α} (ha : is_pre_path_connected A) (hx : x ∈ A) :
  A ⊆ path_component x := λ z hz, mem_sUnion_of_mem hz ⟨ha, hx⟩

theorem path_component.subset_connected_component (x : α) :
  path_component x ⊆ connected_component x :=
subset_connected_component
  (is_pre_path_connected.is_pre_connected is_path_connected_path_component.right)
  mem_path_component

/-- A path connected space is one where all points are path connected. -/
class pre_path_connected_space (α : Type*) [topological_space α] : Prop :=
(is_pre_path_connected_univ [] : is_pre_path_connected (univ : set α))

section prio
set_option default_priority 100 -- see Note [default priority]
/-- A path connected space is a nonempty one where all points are path connected. -/
class path_connected_space (α : Type*) [topological_space α]
extends pre_path_connected_space α : Prop := (to_nonempty : nonempty α)
end prio

lemma subtype.pre_path_connected_space (hA : is_pre_path_connected A) :
  pre_path_connected_space A :=
⟨λ a b,
let ⟨p, hp0, hp1, hpr, hpc⟩ := hA a b in
⟨(λ x, ⟨p x, hpr $ mem_range_self _⟩),
λ x hx, by simp [hp0 x hx],
λ x hx, by simp [hp1 x hx],
subset_univ _,
continuous_subtype_mk _ hpc⟩⟩

theorem is_pre_path_connected_univ [h : pre_path_connected_space α] :
is_pre_path_connected (univ : set α) := h.1

lemma subtype.path_connected_space (hA : is_path_connected A) :
  path_connected_space A :=
{ is_pre_path_connected_univ := (subtype.pre_path_connected_space hA.right).1,
  to_nonempty := hA.nonempty.to_subtype }

theorem exists_path [pre_path_connected_space α] (a b) :
  ∃ f : ℝ → α, (∀ x ≤ 0, f x = a) ∧ (∀ x, 1 ≤ x → f x = b) ∧ continuous f :=
let ⟨p, hp0, hp1, _, hpc⟩ := is_pre_path_connected_univ ⟨a, mem_univ a⟩ ⟨b, mem_univ b⟩ in
⟨p, hp0, hp1, hpc⟩

theorem exists_path' [pre_path_connected_space α] (a b) :
  ∃ f : ℝ → α, f 0 = a ∧ f 1 = b ∧ continuous_on f I01 :=
let ⟨p, hp0, hp1, _, hpc⟩ :=
  are_path_connected_iff.mp (is_pre_path_connected_univ ⟨a, mem_univ a⟩ ⟨b, mem_univ b⟩) in
⟨p, hp0, hp1, hpc⟩

-- This section proves a classic counterexample which is connected but not path-connected.
section comb_space
open complex metric
/-- The horizontal closed line segment between (x₁, y) and (x₂, y) -/
def hor_Icc (y x1 x2 : ℝ) : set ℂ := {z | z.im = y ∧ z.re ∈ Icc x1 x2}
/-- The vertical closed line segment between (x, y₁) and (x, y₂) -/
def ver_Icc (x y1 y2 : ℝ) : set ℂ := {z | z.re = x ∧ z.im ∈ Icc y1 y2}

/-- The comb space without the zero bristle in ℂ -/
def partial_comb := (⋃ (n : ℕ), ver_Icc (1/n.succ) 0 1) ∪ hor_Icc 0 0 1
/-- The deleted comb space in ℂ -/
def deleted_comb := partial_comb ∪ {I}

example : is_connected deleted_comb :=
begin
  refine ⟨⟨0, or.inl $ or.inr ⟨rfl, zero_re ▸ (left_mem_Icc.mpr zero_le_one)⟩⟩,
    is_preconnected.dense_subset (subset_union_left _ _) (union_subset subset_closure $
    singleton_subset_iff.mpr $ metric.mem_closure_iff.mpr $ λ e hep, _)
    (is_pre_path_connected.is_pre_connected _)⟩,
  { cases exists_nat_one_div_lt hep with n hn,
    use [⟨1/(n+1), 1⟩, or.inl $ mem_Union.mpr ⟨n, rfl, right_mem_Icc.mpr zero_le_one⟩],
    rwa [mk_eq_add_mul_I, of_real_one, one_mul, dist_comm,
      dist_eq, add_sub_cancel, abs_of_real, abs_of_pos],
    apply one_div_pos_of_pos,
    exact_mod_cast nat.succ_pos n },
  have mul_I01 : ∀ {a b}, a ∈ I01 → b ∈ I01 → a * b ∈ I01 := λ a b ⟨ha0, ha1⟩ ⟨hb0, hb1⟩,
    ⟨zero_mul (0:ℝ) ▸ mul_le_mul ha0 hb0 (le_refl 0) ha0,
    one_mul (1:ℝ) ▸ mul_le_mul ha1 hb1 hb0 (zero_le_one)⟩,
  unfold partial_comb,
  rw Union_union,
  refine is_pre_path_connected_Union 0 (λ _, or.inr ⟨rfl, left_mem_Icc.mpr zero_le_one⟩) (λ n,
    is_pre_path_connected.union ⟨1/n.succ, 0⟩ ⟨rfl, left_mem_Icc.mpr zero_le_one⟩ ⟨rfl, _⟩ _ _);
  try {apply is_path_connected.is_pre_path_connected ∘ is_path_connected_iff.mpr},
      split,
      { norm_num, norm_cast, linarith },
    { rw div_le_iff; norm_num, norm_cast, linarith  },
  { refine ⟨⟨⟨1/n.succ, 0⟩, ⟨rfl, left_mem_Icc.mpr zero_le_one⟩⟩, _⟩,
    rintro ⟨y, hyr, hyi⟩,
    refine are_path_connected_iff.mpr ⟨λ x, ⟨y.re, y.im * x⟩ , _⟩,
    rw [mul_zero, mul_one],
    refine ⟨congr_arg coe hyr, eta y, _, continuous.continuous_on _⟩,
    { rintro _ ⟨x, hx, rfl⟩,
      exact ⟨hyr, mul_I01 hyi hx⟩ },
    rw @funext _ _ (λ x, (⟨y.re, y.im * x⟩ : ℂ)) _ (λ x, mk_eq_add_mul_I (y.re) (y.im * x)),
    refine continuous.add continuous_const (continuous.mul _ continuous_const),
    exact continuous.comp continuous_of_real (continuous.mul continuous_const continuous_id)  },
  refine ⟨⟨0, rfl, left_mem_Icc.mpr zero_le_one⟩, _⟩,
  rintro ⟨y, hyi, hyr⟩,
  refine are_path_connected_iff.mpr ⟨λ x, y * x , _⟩,
  norm_cast,
  refine ⟨mul_zero y, mul_one y, _, _⟩,
  { rintro _ ⟨x, hx, rfl⟩,
    use [by norm_num [hyi], by norm_num [mul_I01 hyr hx]] },
  exact continuous.continuous_on (continuous.mul continuous_const continuous_of_real),
end

/-- The set of reciprocals of the natural numbers in ℝ is totally disconnected. -/
theorem is_totally_disconnected_nat_reciprocals :
  is_totally_disconnected {t : ℝ | ∃ n : ℕ, t = 1/n} :=
begin
 intros s hsk hs,
  constructor,
  rintro ⟨x, hx⟩ ⟨r, hr⟩,
  rw subtype.mk_eq_mk,
  by_contra hw,
  replace hw := lt_or_gt_of_ne hw,
  wlog := hw using x r,
  obtain ⟨x, rfl⟩ := hsk hx,
  obtain ⟨_ | r, rfl⟩ := hsk hr,
  { norm_num at hw, norm_cast at hw, linarith  },
  have hhqr : (1:ℝ)/r.succ.succ < 1/r.succ,
  { refine one_div_lt_one_div_of_lt (by exact_mod_cast nat.succ_pos _) _,
    exact_mod_cast lt_add_one _ },
  by_cases hx1 : x = 1,
  { rw hx1 at hw,
    replace hw := lt_of_one_div_lt_one_div (by norm_num) hw,
    norm_num at hw, norm_cast at hw, linarith  },
  have hhql : (1:ℝ)/x ≤ 1/r.succ.succ,
  { obtain _ | _ | x := x,
      { norm_num, norm_cast, linarith  },
    { contradiction },
  { refine one_div_le_one_div_of_le (by exact_mod_cast nat.succ_pos _) _,
    replace hw := lt_of_one_div_lt_one_div (by exact_mod_cast nat.succ_pos _) hw,
    norm_num at hw ⊢, norm_cast at hw ⊢, linarith  }},
  obtain ⟨q, hql, hqr⟩ := exists_rat_btwn hhqr,
  obtain ⟨w, _, hww⟩ := hs (Iio q) (Ioi q) is_open_Iio is_open_Ioi (λ w hw, _)
    ⟨1/x, hx, lt_of_le_of_lt hhql hql⟩ ⟨1/r.succ, hr, hqr⟩,
  { change w < q ∧ w > q at hww, cases hww, linarith },
  obtain ⟨_ | w, rfl⟩ := hsk hw,
  { exact or.inl (lt_trans (by norm_num; norm_cast; linarith) hql)  },
  by_cases hwp : (1:ℝ)/w.succ ≥ 1/r.succ,
  { exact or.inr (lt_of_lt_of_le hqr hwp)  },
  suffices heq : (1:ℝ)/w.succ ≤ 1/r.succ.succ,
  { exact or.inl (lt_of_le_of_lt heq hql) },
  refine one_div_le_one_div_of_le (by exact_mod_cast nat.succ_pos _) _,
  replace hw := lt_of_one_div_lt_one_div (by exact_mod_cast nat.succ_pos _) (not_le.mp hwp),
  norm_num at hw ⊢, norm_cast at hw ⊢, linarith
end

example : ¬ is_pre_path_connected deleted_comb :=
begin
  let V := ball I (1/2),
  have hV : ∀ x ∈ V, x ∈ deleted_comb → x = I ∨ x.im ∈ I01 ∧ ∃ n : ℕ, x.re = 1/n.succ,
  { rintro z hzv (⟨⟨_, ⟨n, rfl⟩, ⟨hfr, hfi⟩⟩ | ⟨hfi, hfr0, hfr1⟩⟩ | hc),
      { exact or.inr ⟨hfi, n, hfr⟩  },
    { change abs (z - I) < 1/2 at hzv,
      replace hzv := lt_of_le_of_lt (abs_im_le_abs _) hzv,
      rw [sub_im, hfi] at hzv,
      norm_num at hzv },
    exact or.inl (mem_singleton_iff.mp hc)  },
  intros hw,
  obtain ⟨f, hf0, hf1, hfr, hfc⟩ :=
    hw ⟨I, singleton_subset_iff.mp $ subset_union_of_subset_right subset.rfl _⟩
    ⟨0, or.inl $ or.inr ⟨rfl, zero_re ▸ (left_mem_Icc.mpr zero_le_one)⟩⟩,
  let A := f ⁻¹' {I},
  suffices hA : is_open A,
  { cases is_clopen_iff.mp ⟨hA, continuous_iff_is_closed.mp hfc _ is_closed_singleton⟩ with h h,
    { exact (subset.antisymm_iff.mp h).left (hf0 0 (le_refl 0)) },
    have hw1 : (1:ℝ) ∈ A := h.symm ▸ mem_univ 1,
    rw [mem_preimage, hf1 1 (le_refl 1), mem_singleton_iff] at hw1,
    injections, linarith  },
  rw is_open_iff,
  intros x hx,
  change f x = I at hx,
  obtain ⟨d, hdp, hd⟩ := (continuous_iff.mp hfc) x (1/2) (by norm_num),
  rw hx at hd,
  use [d, hdp],
  intros z hz,
  obtain hzp | ⟨hi, n, hr⟩ := hV (f z) (hd z hz) (hfr ⟨z, rfl⟩),
  { assumption },
  suffices hs : subsingleton (re ∘ f '' ball x d),
  { cases hs with hs,
    specialize hs ⟨(f z).re, z, hz, rfl⟩ ⟨0, x, mem_ball_self hdp, by norm_num [hx]⟩,
    rw subtype.mk_eq_mk.mp hs at hr,
    replace hr := eq_zero_of_one_div_eq_zero hr.symm,
    norm_cast at hr },
  apply is_totally_disconnected_nat_reciprocals,
  { rintro s ⟨r, hr, rfl⟩,
    obtain hsp | ⟨hsi, m, hsr⟩ := hV (f r) (hd r hr) (hfr ⟨r, rfl⟩),
    { use 0, norm_num [hsp]  },
    use m.succ, norm_num [hsr]  },
  refine is_preconnected.image _ _ (continuous.continuous_on (continuous.comp continuous_re hfc)),
  exact (real.ball_eq_Ioo x d).symm ▸ is_preconnected_Ioo,
end

end comb_space

example (A : set ℝ) : is_pre_path_connected A ↔ is_preconnected A :=
begin
  refine ⟨is_pre_path_connected.is_pre_connected, λ h a b, _⟩,
  wlog := le_total a b using a b;
    try {exact symm this},
  refine are_path_connected_iff.mpr ⟨λ x, a + (b - a) * x, by norm_num, by norm_num,
    trans _ $ (is_preconnected_iff_forall_Icc_subset.mp h) a b a.2 b.2 case,
    continuous_on_const.add $ continuous_on_const.mul continuous_on_id⟩,
  rintro _ ⟨x, hx, rfl⟩,
  use [(le_add_iff_nonneg_right _).mpr $ mul_nonneg (sub_nonneg.mpr case) hx.1,
    le_sub_iff_add_le'.mp $ mul_le_of_le_one_right (sub_nonneg.mpr case) hx.2],
end

/--A set is `preconnected` iff continuous functions from it to a discrete two-space are constant.-/
theorem is_preconnected_iff_continuous_const : is_preconnected A ↔
  ∀ f : α → ({0,1} : set ℝ), continuous_on f A → subsingleton (f '' A) :=
begin
  split,
  { intros hA f hfc,
    split,
    rintro ⟨_, ⟨x, hx, rfl⟩⟩ ⟨_, ⟨y, hy, rfl⟩⟩,
    obtain hw := is_totally_disconnected_nat_reciprocals _ _
      (is_preconnected.image hA (λ x, (f x).1) (continuous_subtype_coe.comp_continuous_on hfc)),
    { exact subtype.mk_eq_mk.mpr (subtype.eq $ subtype.mk_eq_mk.mp $
        hw ⟨f x, x, hx, rfl⟩ ⟨f y, y, hy, rfl⟩) },
    rintro _ ⟨w, hw, rfl⟩,
    cases (f w).2 with h h,
    { use 0, norm_num [h] },
    use 1, norm_num [mem_singleton_iff.mp h]  },
  intro h,
  classical,
  by_contra hw,
  unfold is_preconnected at hw,
  push_neg at hw,
  rcases hw with ⟨U, V, huo, hvo, hc, ⟨x, hxa, hxu⟩, ⟨y, hya, hyv⟩, he⟩,
  obtain hw := h (λ x, if x ∈ U then ⟨0, or.inl rfl⟩ else ⟨1, or.inr $ mem_singleton 1⟩) _,
  { specialize hw ⟨⟨0, or.inl rfl⟩, x, hxa, if_pos hxu⟩
      ⟨⟨1, or.inr $ mem_singleton 1⟩, y, hya, if_neg (λ hw, he ⟨y, hya, hw, hyv⟩)⟩,
    injections, linarith  },
  rw continuous_on_iff,
  intros a haa T hto h01,
  split_ifs at h01 with hau hnau,
  { rw [if_preimage, preimage_const, if_pos h01, inter_univ],
    use [U, huo, hau, trans (inter_subset_left U A) (subset_union_left U _)]  },
  rw [if_preimage, union_comm, preimage_const, if_pos h01, inter_univ],
  use [V, hvo, or.resolve_left (hc haa) hau,
    subset_union_of_subset_left (λ w ⟨hwv, hwa⟩ hwu, he ⟨w, hwa, hwu, hwv⟩) _],
end


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

Natural homomorphism from the natural numbers into a monoid with one.
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.data.nat.cast
import Mathlib.data.fintype.basic
import Mathlib.tactic.wlog
import Mathlib.PostPort

universes u_1 l

namespace Mathlib

/-- Typeclass for monoids with characteristic zero.
  (This is usually stated on fields but it makes sense for any additive monoid with 1.) -/
class char_zero (R : Type u_1) [add_monoid R] [HasOne R] where
  cast_injective : function.injective coe

theorem char_zero_of_inj_zero {R : Type u_1} [add_left_cancel_monoid R] [HasOne R]
    (H : ∀ (n : ℕ), ↑n = 0 → n = 0) : char_zero R :=
  sorry

protected instance linear_ordered_semiring.to_char_zero {R : Type u_1} [linear_ordered_semiring R] :
    char_zero R :=
  char_zero.mk (strict_mono.injective nat.strict_mono_cast)

namespace nat

theorem cast_injective {R : Type u_1} [add_monoid R] [HasOne R] [char_zero R] :
    function.injective coe :=
  char_zero.cast_injective

@[simp] theorem cast_inj {R : Type u_1} [add_monoid R] [HasOne R] [char_zero R] {m : ℕ} {n : ℕ} :
    ↑m = ↑n ↔ m = n :=
  function.injective.eq_iff cast_injective

@[simp] theorem cast_eq_zero {R : Type u_1} [add_monoid R] [HasOne R] [char_zero R] {n : ℕ} :
    ↑n = 0 ↔ n = 0 :=
  eq.mpr (id (Eq._oldrec (Eq.refl (↑n = 0 ↔ n = 0)) (Eq.symm cast_zero)))
    (eq.mpr (id (Eq._oldrec (Eq.refl (↑n = ↑0 ↔ n = 0)) (propext cast_inj))) (iff.refl (n = 0)))

theorem cast_ne_zero {R : Type u_1} [add_monoid R] [HasOne R] [char_zero R] {n : ℕ} :
    ↑n ≠ 0 ↔ n ≠ 0 :=
  not_congr cast_eq_zero

theorem cast_add_one_ne_zero {R : Type u_1} [add_monoid R] [HasOne R] [char_zero R] (n : ℕ) :
    ↑n + 1 ≠ 0 :=
  sorry

@[simp] theorem cast_dvd_char_zero {k : Type u_1} [field k] [char_zero k] {m : ℕ} {n : ℕ}
    (n_dvd : n ∣ m) : ↑(m / n) = ↑m / ↑n :=
  sorry

end nat

protected instance char_zero.infinite (M : Type u_1) [add_monoid M] [HasOne M] [char_zero M] :
    infinite M :=
  infinite.of_injective coe nat.cast_injective

theorem two_ne_zero' {M : Type u_1} [add_monoid M] [HasOne M] [char_zero M] : bit0 1 ≠ 0 :=
  (fun (this : ↑(bit0 1) ≠ 0) => eq.mp (Eq._oldrec (Eq.refl (↑(bit0 1) ≠ 0)) nat.cast_two) this)
    (iff.mpr nat.cast_ne_zero (of_as_true trivial))

theorem add_self_eq_zero {R : Type u_1} [semiring R] [no_zero_divisors R] [char_zero R] {a : R} :
    a + a = 0 ↔ a = 0 :=
  sorry

theorem bit0_eq_zero {R : Type u_1} [semiring R] [no_zero_divisors R] [char_zero R] {a : R} :
    bit0 a = 0 ↔ a = 0 :=
  add_self_eq_zero

@[simp] theorem half_add_self {R : Type u_1} [division_ring R] [char_zero R] (a : R) :
    (a + a) / bit0 1 = a :=
  eq.mpr (id (Eq._oldrec (Eq.refl ((a + a) / bit0 1 = a)) (Eq.symm (mul_two a))))
    (eq.mpr (id (Eq._oldrec (Eq.refl (a * bit0 1 / bit0 1 = a)) (mul_div_cancel a two_ne_zero')))
      (Eq.refl a))

@[simp] theorem add_halves' {R : Type u_1} [division_ring R] [char_zero R] (a : R) :
    a / bit0 1 + a / bit0 1 = a :=
  eq.mpr (id (Eq._oldrec (Eq.refl (a / bit0 1 + a / bit0 1 = a)) (Eq.symm (add_div a a (bit0 1)))))
    (eq.mpr (id (Eq._oldrec (Eq.refl ((a + a) / bit0 1 = a)) (half_add_self a))) (Eq.refl a))

theorem sub_half {R : Type u_1} [division_ring R] [char_zero R] (a : R) :
    a - a / bit0 1 = a / bit0 1 :=
  eq.mpr (id (Eq._oldrec (Eq.refl (a - a / bit0 1 = a / bit0 1)) (propext sub_eq_iff_eq_add)))
    (eq.mpr (id (Eq._oldrec (Eq.refl (a = a / bit0 1 + a / bit0 1)) (add_halves' a))) (Eq.refl a))

theorem half_sub {R : Type u_1} [division_ring R] [char_zero R] (a : R) :
    a / bit0 1 - a = -(a / bit0 1) :=
  eq.mpr
    (id (Eq._oldrec (Eq.refl (a / bit0 1 - a = -(a / bit0 1))) (Eq.symm (neg_sub a (a / bit0 1)))))
    (eq.mpr (id (Eq._oldrec (Eq.refl (-(a - a / bit0 1) = -(a / bit0 1))) (sub_half a)))
      (Eq.refl (-(a / bit0 1))))

namespace with_top

protected instance char_zero {R : Type u_1} [add_monoid R] [HasOne R] [char_zero R] :
    char_zero (with_top R) :=
  char_zero.mk
    fun (m n : ℕ) (h : ↑m = ↑n) =>
      eq.mp (Eq._oldrec (Eq.refl (↑m = ↑n)) (propext nat.cast_inj))
        (eq.mp (Eq._oldrec (Eq.refl (↑↑m = ↑↑n)) (propext coe_eq_coe))
          (eq.mp (Eq._oldrec (Eq.refl (↑↑m = ↑n)) (Eq.symm (coe_nat n)))
            (eq.mp (Eq._oldrec (Eq.refl (↑m = ↑n)) (Eq.symm (coe_nat m))) h)))

end Mathlib


/-
Copyright (c) 2017 Mario Carneiro. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Mario Carneiro
-/
import logic.basic data.bool data.option.defs tactic.interactive

namespace option
variables {α : Type*} {β : Type*}

@[simp] theorem get_mem : ∀ {o : option α} (h : is_some o), option.get h ∈ o
| (some a) _ := rfl

theorem get_of_mem {a : α} : ∀ {o : option α} (h : is_some o), a ∈ o → option.get h = a
| _ _ rfl := rfl

theorem mem_unique {o : option α} {a b : α} (ha : a ∈ o) (hb : b ∈ o) : a = b :=
option.some.inj $ ha.symm.trans hb

theorem injective_some (α : Type*) : function.injective (@some α) :=
λ _ _, some_inj.mp

@[extensionality] theorem ext : ∀ {o₁ o₂ : option α}, (∀ a, a ∈ o₁ ↔ a ∈ o₂) → o₁ = o₂
| none     none     H := rfl
| (some a) o        H := ((H _).1 rfl).symm
| o        (some b) H := (H _).2 rfl

theorem eq_none_iff_forall_not_mem {o : option α} :
  o = none ↔ (∀ a, a ∉ o) :=
⟨λ e a h, by rw e at h; cases h, λ h, ext $ by simpa⟩

@[simp] theorem none_bind {α β} (f : α → option β) : none >>= f = none := rfl

@[simp] theorem some_bind {α β} (a : α) (f : α → option β) : some a >>= f = f a := rfl

@[simp] theorem none_bind' (f : α → option β) : none.bind f = none := rfl

@[simp] theorem some_bind' (a : α) (f : α → option β) : (some a).bind f = f a := rfl

@[simp] theorem bind_some : ∀ x : option α, x >>= some = x :=
@bind_pure α option _ _

@[simp] theorem bind_eq_some {α β} {x : option α} {f : α → option β} {b : β} : x >>= f = some b ↔ ∃ a, x = some a ∧ f a = some b :=
by cases x; simp

@[simp] theorem bind_eq_some' {x : option α} {f : α → option β} {b : β} : x.bind f = some b ↔ ∃ a, x = some a ∧ f a = some b :=
by cases x; simp

lemma bind_comm {α β γ} {f : α → β → option γ} (a : option α) (b : option β) :
  a.bind (λx, b.bind (f x)) = b.bind (λy, a.bind (λx, f x y)) :=
by cases a; cases b; refl

@[simp] theorem map_none {α β} {f : α → β} : f <$> none = none := rfl

@[simp] theorem map_some {α β} {a : α} {f : α → β} : f <$> some a = some (f a) := rfl

@[simp] theorem map_none' {f : α → β} : option.map f none = none := rfl

@[simp] theorem map_some' {a : α} {f : α → β} : option.map f (some a) = some (f a) := rfl

@[simp] theorem map_eq_some {α β} {x : option α} {f : α → β} {b : β} : f <$> x = some b ↔ ∃ a, x = some a ∧ f a = b :=
by cases x; simp

@[simp] theorem map_eq_some' {x : option α} {f : α → β} {b : β} : x.map f = some b ↔ ∃ a, x = some a ∧ f a = b :=
by cases x; simp

@[simp] theorem map_id' : option.map (@id α) = id := map_id

@[simp] theorem seq_some {α β} {a : α} {f : α → β} : some f <*> some a = some (f a) := rfl

@[simp] theorem some_orelse' (a : α) (x : option α) : (some a).orelse x = some a := rfl

@[simp] theorem some_orelse (a : α) (x : option α) : (some a <|> x) = some a := rfl

@[simp] theorem none_orelse' (x : option α) : none.orelse x = x :=
by cases x; refl

@[simp] theorem none_orelse (x : option α) : (none <|> x) = x := none_orelse' x

@[simp] theorem orelse_none' (x : option α) : x.orelse none = x :=
by cases x; refl

@[simp] theorem orelse_none (x : option α) : (x <|> none) = x := orelse_none' x

@[simp] theorem is_some_none : @is_some α none = ff := rfl

@[simp] theorem is_some_some {a : α} : is_some (some a) = tt := rfl

theorem is_some_iff_exists {x : option α} : is_some x ↔ ∃ a, x = some a :=
by cases x; simp [is_some]; exact ⟨_, rfl⟩

@[simp] theorem is_none_none : @is_none α none = tt := rfl

@[simp] theorem is_none_some {a : α} : is_none (some a) = ff := rfl

@[simp] theorem not_is_some {a : option α} : is_some a = ff ↔ a.is_none = tt :=
by cases a; simp

theorem iget_mem [inhabited α] : ∀ {o : option α}, is_some o → o.iget ∈ o
| (some a) _ := rfl

theorem iget_of_mem [inhabited α] {a : α} : ∀ {o : option α}, a ∈ o → o.iget = a
| _ rfl := rfl

@[simp] theorem guard_eq_some {p : α → Prop} [decidable_pred p] {a b : α} :
  guard p a = some b ↔ a = b ∧ p a :=
by by_cases p a; simp [option.guard, h]; intro; contradiction

@[simp] theorem guard_eq_some' {p : Prop} [decidable p] :
  ∀ u, _root_.guard p = some u ↔ p
| () := by by_cases p; simp [guard, h, pure]; intro; contradiction

theorem lift_or_get_choice {f : α → α → α} (h : ∀ a b, f a b = a ∨ f a b = b) :
  ∀ o₁ o₂, lift_or_get f o₁ o₂ = o₁ ∨ lift_or_get f o₁ o₂ = o₂
| none     none     := or.inl rfl
| (some a) none     := or.inl rfl
| none     (some b) := or.inr rfl
| (some a) (some b) := by simpa [lift_or_get] using h a b

end option


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

! This file was ported from Lean 3 source module data.list.sections
! leanprover-community/mathlib commit 26f081a2fb920140ed5bc5cc5344e84bcc7cb2b2
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathlib.Data.List.Forall2
/-!
# List sections

This file proves some stuff about `List.sections` (definition in `Data.List.Defs`). A section of a
list of lists `[l₁, ..., lₙ]` is a list whose `i`-th element comes from the `i`-th list.
-/

open Nat Function

namespace List

variable {α β : Type _}

theorem mem_sections {L : List (List α)} {f} : f ∈ sections L ↔ Forall₂ (· ∈ ·) f L := by
  refine' ⟨fun h => _, fun h => _⟩
  · induction L generalizing f
    · cases mem_singleton.1 h
      exact Forall₂.nil
    simp only [sections, bind_eq_bind, mem_bind, mem_map] at h
    rcases h with ⟨_, _, _, _, rfl⟩
    simp only [*, forall₂_cons, true_and_iff]
  · induction' h with a l f L al fL fs
    · simp only [sections, mem_singleton]
    simp only [sections, bind_eq_bind, mem_bind, mem_map]
    exact ⟨f, fs, a, al, rfl⟩
#align list.mem_sections List.mem_sections

theorem mem_sections_length {L : List (List α)} {f} (h : f ∈ sections L) : length f = length L :=
  (mem_sections.1 h).length_eq
#align list.mem_sections_length List.mem_sections_length

theorem rel_sections {r : α → β → Prop} :
    (Forall₂ (Forall₂ r) ⇒ Forall₂ (Forall₂ r)) sections sections
  | _, _, Forall₂.nil => Forall₂.cons Forall₂.nil Forall₂.nil
  | _, _, Forall₂.cons h₀ h₁ =>
    rel_bind (rel_sections h₁) fun _ _ hl => rel_map (fun _ _ ha => Forall₂.cons ha hl) h₀
#align list.rel_sections List.rel_sections

end List


import algebra.star.pi

lemma function.star_sum_elim {I J α : Type*} (x : I → α) (y : J → α) [has_star α] :
  star (sum.elim x y) = sum.elim (star x) (star y) :=
by { ext x, cases x; simp }


/-
Copyright (c) 2020 Bhavik Mehta. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Bhavik Mehta, E. W. Ayers
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.category_theory.over
import Mathlib.category_theory.limits.shapes.finite_limits
import Mathlib.category_theory.yoneda
import Mathlib.order.complete_lattice
import Mathlib.data.set.lattice
import Mathlib.PostPort

universes v u l

namespace Mathlib

/-!
# Theory of sieves

- For an object `X` of a category `C`, a `sieve X` is a set of morphisms to `X`
  which is closed under left-composition.
- The complete lattice structure on sieves is given, as well as the Galois insertion
  given by downward-closing.
- A `sieve X` (functorially) induces a presheaf on `C` together with a monomorphism to
  the yoneda embedding of `X`.

## Tags

sieve, pullback
-/

namespace category_theory

/-- A set of arrows all with codomain `X`. -/
def presieve {C : Type u} [category C] (X : C) := {Y : C} → set (Y ⟶ X)

namespace presieve

protected instance inhabited {C : Type u} [category C] {X : C} : Inhabited (presieve X) :=
  { default := ⊤ }

/--
Given a set of arrows `S` all with codomain `X`, and a set of arrows with codomain `Y` for each
`f : Y ⟶ X` in `S`, produce a set of arrows with codomain `X`:
`{ g ≫ f | (f : Y ⟶ X) ∈ S, (g : Z ⟶ Y) ∈ R f }`.
-/
def bind {C : Type u} [category C] {X : C} (S : presieve X)
    (R : {Y : C} → {f : Y ⟶ X} → S f → presieve Y) : presieve X :=
  fun (Z : C) (h : Z ⟶ X) => ∃ (Y : C), ∃ (g : Z ⟶ Y), ∃ (f : Y ⟶ X), ∃ (H : S f), R H g ∧ g ≫ f = h

@[simp] theorem bind_comp {C : Type u} [category C] {X : C} {Y : C} {Z : C} (f : Y ⟶ X)
    {S : presieve X} {R : {Y : C} → {f : Y ⟶ X} → S f → presieve Y} {g : Z ⟶ Y} (h₁ : S f)
    (h₂ : R h₁ g) : bind S R (g ≫ f) :=
  Exists.intro Y (Exists.intro g (Exists.intro f (Exists.intro h₁ { left := h₂, right := rfl })))

/-- The singleton presieve.  -/
-- Note we can't make this into `has_singleton` because of the out-param.

structure singleton {C : Type u} [category C] {X : C} {Y : C} (f : Y ⟶ X) : presieve X where

@[simp] theorem singleton_eq_iff_domain {C : Type u} [category C] {X : C} {Y : C} (f : Y ⟶ X)
    (g : Y ⟶ X) : singleton f g ↔ f = g :=
  sorry

theorem singleton_self {C : Type u} [category C] {X : C} {Y : C} (f : Y ⟶ X) : singleton f f :=
  singleton.mk

end presieve

/--
For an object `X` of a category `C`, a `sieve X` is a set of morphisms to `X` which is closed under
left-composition.
-/
structure sieve {C : Type u} [category C] (X : C) where
  arrows : presieve X
  downward_closed' : ∀ {Y Z : C} {f : Y ⟶ X}, arrows f → ∀ (g : Z ⟶ Y), arrows (g ≫ f)

namespace sieve

protected instance has_coe_to_fun {C : Type u} [category C] {X : C} : has_coe_to_fun (sieve X) :=
  has_coe_to_fun.mk (fun (x : sieve X) => presieve X) arrows

@[simp] theorem downward_closed {C : Type u} [category C] {X : C} {Y : C} {Z : C} (S : sieve X)
    {f : Y ⟶ X} (hf : coe_fn S Y f) (g : Z ⟶ Y) : coe_fn S Z (g ≫ f) :=
  downward_closed' S hf g

theorem arrows_ext {C : Type u} [category C] {X : C} {R : sieve X} {S : sieve X} :
    arrows R = arrows S → R = S :=
  sorry

protected theorem ext {C : Type u} [category C] {X : C} {R : sieve X} {S : sieve X}
    (h : ∀ {Y : C} (f : Y ⟶ X), coe_fn R Y f ↔ coe_fn S Y f) : R = S :=
  arrows_ext (funext fun (x : C) => funext fun (f : x ⟶ X) => propext (h f))

protected theorem ext_iff {C : Type u} [category C] {X : C} {R : sieve X} {S : sieve X} :
    R = S ↔ ∀ {Y : C} (f : Y ⟶ X), coe_fn R Y f ↔ coe_fn S Y f :=
  { mp := fun (h : R = S) (Y : C) (f : Y ⟶ X) => h ▸ iff.rfl, mpr := sieve.ext }

/-- The supremum of a collection of sieves: the union of them all. -/
protected def Sup {C : Type u} [category C] {X : C} (𝒮 : set (sieve X)) : sieve X :=
  mk (fun (Y : C) => set_of fun (f : Y ⟶ X) => ∃ (S : sieve X), ∃ (H : S ∈ 𝒮), arrows S f) sorry

/-- The infimum of a collection of sieves: the intersection of them all. -/
protected def Inf {C : Type u} [category C] {X : C} (𝒮 : set (sieve X)) : sieve X :=
  mk (fun (Y : C) => set_of fun (f : Y ⟶ X) => ∀ (S : sieve X), S ∈ 𝒮 → arrows S f) sorry

/-- The union of two sieves is a sieve. -/
protected def union {C : Type u} [category C] {X : C} (S : sieve X) (R : sieve X) : sieve X :=
  mk (fun (Y : C) (f : Y ⟶ X) => coe_fn S Y f ∨ coe_fn R Y f) sorry

/-- The intersection of two sieves is a sieve. -/
protected def inter {C : Type u} [category C] {X : C} (S : sieve X) (R : sieve X) : sieve X :=
  mk (fun (Y : C) (f : Y ⟶ X) => coe_fn S Y f ∧ coe_fn R Y f) sorry

/--
Sieves on an object `X` form a complete lattice.
We generate this directly rather than using the galois insertion for nicer definitional properties.
-/
protected instance complete_lattice {C : Type u} [category C] {X : C} :
    complete_lattice (sieve X) :=
  complete_lattice.mk sieve.union
    (fun (S R : sieve X) => ∀ {Y : C} (f : Y ⟶ X), coe_fn S Y f → coe_fn R Y f)
    (bounded_lattice.lt._default
      fun (S R : sieve X) => ∀ {Y : C} (f : Y ⟶ X), coe_fn S Y f → coe_fn R Y f)
    sorry sorry sorry sorry sorry sorry sieve.inter sorry sorry sorry
    (mk (fun (_x : C) => set.univ) sorry) sorry (mk (fun (_x : C) => ∅) sorry) sorry sieve.Sup
    sieve.Inf sorry sorry sorry sorry

/-- The maximal sieve always exists. -/
protected instance sieve_inhabited {C : Type u} [category C] {X : C} : Inhabited (sieve X) :=
  { default := ⊤ }

@[simp] theorem Inf_apply {C : Type u} [category C] {X : C} {Ss : set (sieve X)} {Y : C}
    (f : Y ⟶ X) : coe_fn (Inf Ss) Y f ↔ ∀ (S : sieve X), S ∈ Ss → coe_fn S Y f :=
  iff.rfl

@[simp] theorem Sup_apply {C : Type u} [category C] {X : C} {Ss : set (sieve X)} {Y : C}
    (f : Y ⟶ X) : coe_fn (Sup Ss) Y f ↔ ∃ (S : sieve X), ∃ (H : S ∈ Ss), coe_fn S Y f :=
  iff.rfl

@[simp] theorem inter_apply {C : Type u} [category C] {X : C} {R : sieve X} {S : sieve X} {Y : C}
    (f : Y ⟶ X) : coe_fn (R ⊓ S) Y f ↔ coe_fn R Y f ∧ coe_fn S Y f :=
  iff.rfl

@[simp] theorem union_apply {C : Type u} [category C] {X : C} {R : sieve X} {S : sieve X} {Y : C}
    (f : Y ⟶ X) : coe_fn (R ⊔ S) Y f ↔ coe_fn R Y f ∨ coe_fn S Y f :=
  iff.rfl

@[simp] theorem top_apply {C : Type u} [category C] {X : C} {Y : C} (f : Y ⟶ X) : coe_fn ⊤ Y f :=
  trivial

/-- Generate the smallest sieve containing the given set of arrows. -/
@[simp] theorem generate_apply {C : Type u} [category C] {X : C} (R : presieve X) (Z : C)
    (f : Z ⟶ X) :
    coe_fn (generate R) Z f = ∃ (Y : C), ∃ (h : Z ⟶ Y), ∃ (g : Y ⟶ X), R g ∧ h ≫ g = f :=
  Eq.refl (coe_fn (generate R) Z f)

/--
Given a presieve on `X`, and a sieve on each domain of an arrow in the presieve, we can bind to
produce a sieve on `X`.
-/
@[simp] theorem bind_apply {C : Type u} [category C] {X : C} (S : presieve X)
    (R : {Y : C} → {f : Y ⟶ X} → S f → sieve Y) :
    ⇑(bind S R) = presieve.bind S fun (Y : C) (f : Y ⟶ X) (h : S f) => ⇑(R h) :=
  Eq.refl ⇑(bind S R)

theorem sets_iff_generate {C : Type u} [category C] {X : C} (R : presieve X) (S : sieve X) :
    generate R ≤ S ↔ R ≤ ⇑S :=
  sorry

/-- Show that there is a galois insertion (generate, set_over). -/
def gi_generate {C : Type u} [category C] {X : C} : galois_insertion generate arrows :=
  galois_insertion.mk (fun (𝒢 : presieve X) (_x : arrows (generate 𝒢) ≤ 𝒢) => generate 𝒢)
    sets_iff_generate sorry sorry

theorem le_generate {C : Type u} [category C] {X : C} (R : presieve X) : R ≤ ⇑(generate R) :=
  galois_connection.le_u_l (galois_insertion.gc gi_generate) R

/-- If the identity arrow is in a sieve, the sieve is maximal. -/
theorem id_mem_iff_eq_top {C : Type u} [category C] {X : C} {S : sieve X} : coe_fn S X 𝟙 ↔ S = ⊤ :=
  sorry

/-- If an arrow set contains a split epi, it generates the maximal sieve. -/
theorem generate_of_contains_split_epi {C : Type u} [category C] {X : C} {Y : C} {R : presieve X}
    (f : Y ⟶ X) [split_epi f] (hf : R f) : generate R = ⊤ :=
  sorry

@[simp] theorem generate_of_singleton_split_epi {C : Type u} [category C] {X : C} {Y : C}
    (f : Y ⟶ X) [split_epi f] : generate (presieve.singleton f) = ⊤ :=
  generate_of_contains_split_epi f (presieve.singleton_self f)

@[simp] theorem generate_top {C : Type u} [category C] {X : C} : generate ⊤ = ⊤ :=
  generate_of_contains_split_epi 𝟙 True.intro

/-- Given a morphism `h : Y ⟶ X`, send a sieve S on X to a sieve on Y
    as the inverse image of S with `_ ≫ h`.
    That is, `sieve.pullback S h := (≫ h) '⁻¹ S`. -/
def pullback {C : Type u} [category C] {X : C} {Y : C} (h : Y ⟶ X) (S : sieve X) : sieve Y :=
  mk (fun (Y_1 : C) (sl : Y_1 ⟶ Y) => coe_fn S Y_1 (sl ≫ h)) sorry

@[simp] theorem pullback_id {C : Type u} [category C] {X : C} {S : sieve X} : pullback 𝟙 S = S :=
  sorry

@[simp] theorem pullback_top {C : Type u} [category C] {X : C} {Y : C} {f : Y ⟶ X} :
    pullback f ⊤ = ⊤ :=
  top_unique fun (_x : C) (g : _x ⟶ Y) => id

theorem pullback_comp {C : Type u} [category C] {X : C} {Y : C} {Z : C} {f : Y ⟶ X} {g : Z ⟶ Y}
    (S : sieve X) : pullback (g ≫ f) S = pullback g (pullback f S) :=
  sorry

@[simp] theorem pullback_inter {C : Type u} [category C] {X : C} {Y : C} {f : Y ⟶ X} (S : sieve X)
    (R : sieve X) : pullback f (S ⊓ R) = pullback f S ⊓ pullback f R :=
  sorry

theorem pullback_eq_top_iff_mem {C : Type u} [category C] {X : C} {Y : C} {S : sieve X}
    (f : Y ⟶ X) : coe_fn S Y f ↔ pullback f S = ⊤ :=
  sorry

theorem pullback_eq_top_of_mem {C : Type u} [category C] {X : C} {Y : C} (S : sieve X) {f : Y ⟶ X} :
    coe_fn S Y f → pullback f S = ⊤ :=
  iff.mp (pullback_eq_top_iff_mem f)

/--
Push a sieve `R` on `Y` forward along an arrow `f : Y ⟶ X`: `gf : Z ⟶ X` is in the sieve if `gf`
factors through some `g : Z ⟶ Y` which is in `R`.
-/
@[simp] theorem pushforward_apply {C : Type u} [category C] {X : C} {Y : C} (f : Y ⟶ X)
    (R : sieve Y) (Z : C) (gf : Z ⟶ X) :
    coe_fn (pushforward f R) Z gf = ∃ (g : Z ⟶ Y), g ≫ f = gf ∧ coe_fn R Z g :=
  Eq.refl (coe_fn (pushforward f R) Z gf)

theorem pushforward_apply_comp {C : Type u} [category C] {X : C} {Y : C} {R : sieve Y} {Z : C}
    {g : Z ⟶ Y} (hg : coe_fn R Z g) (f : Y ⟶ X) : coe_fn (pushforward f R) Z (g ≫ f) :=
  Exists.intro g { left := rfl, right := hg }

theorem pushforward_comp {C : Type u} [category C] {X : C} {Y : C} {Z : C} {f : Y ⟶ X} {g : Z ⟶ Y}
    (R : sieve Z) : pushforward (g ≫ f) R = pushforward f (pushforward g R) :=
  sorry

theorem galois_connection {C : Type u} [category C] {X : C} {Y : C} (f : Y ⟶ X) :
    galois_connection (pushforward f) (pullback f) :=
  sorry

theorem pullback_monotone {C : Type u} [category C] {X : C} {Y : C} (f : Y ⟶ X) :
    monotone (pullback f) :=
  galois_connection.monotone_u (galois_connection f)

theorem pushforward_monotone {C : Type u} [category C] {X : C} {Y : C} (f : Y ⟶ X) :
    monotone (pushforward f) :=
  galois_connection.monotone_l (galois_connection f)

theorem le_pushforward_pullback {C : Type u} [category C] {X : C} {Y : C} (f : Y ⟶ X)
    (R : sieve Y) : R ≤ pullback f (pushforward f R) :=
  galois_connection.le_u_l (galois_connection f) R

theorem pullback_pushforward_le {C : Type u} [category C] {X : C} {Y : C} (f : Y ⟶ X)
    (R : sieve X) : pushforward f (pullback f R) ≤ R :=
  galois_connection.l_u_le (galois_connection f) R

theorem pushforward_union {C : Type u} [category C] {X : C} {Y : C} {f : Y ⟶ X} (S : sieve Y)
    (R : sieve Y) : pushforward f (S ⊔ R) = pushforward f S ⊔ pushforward f R :=
  galois_connection.l_sup (galois_connection f)

theorem pushforward_le_bind_of_mem {C : Type u} [category C] {X : C} {Y : C} (S : presieve X)
    (R : {Y : C} → {f : Y ⟶ X} → S f → sieve Y) (f : Y ⟶ X) (h : S f) :
    pushforward f (R h) ≤ bind S R :=
  sorry

theorem le_pullback_bind {C : Type u} [category C] {X : C} {Y : C} (S : presieve X)
    (R : {Y : C} → {f : Y ⟶ X} → S f → sieve Y) (f : Y ⟶ X) (h : S f) :
    R h ≤ pullback f (bind S R) :=
  eq.mpr
    (id
      (Eq._oldrec (Eq.refl (R h ≤ pullback f (bind S R)))
        (Eq.symm (propext (galois_connection f (R h) (bind S R))))))
    (pushforward_le_bind_of_mem (fun {Y : C} (f : Y ⟶ X) => S f) R f h)

/-- If `f` is a monomorphism, the pushforward-pullback adjunction on sieves is coreflective. -/
def galois_coinsertion_of_mono {C : Type u} [category C] {X : C} {Y : C} (f : Y ⟶ X) [mono f] :
    galois_coinsertion (pushforward f) (pullback f) :=
  galois_connection.to_galois_coinsertion (galois_connection f) sorry

/-- If `f` is a split epi, the pushforward-pullback adjunction on sieves is reflective. -/
def galois_insertion_of_split_epi {C : Type u} [category C] {X : C} {Y : C} (f : Y ⟶ X)
    [split_epi f] : galois_insertion (pushforward f) (pullback f) :=
  galois_connection.to_galois_insertion (galois_connection f) sorry

/-- A sieve induces a presheaf. -/
@[simp] theorem functor_obj {C : Type u} [category C] {X : C} (S : sieve X) (Y : Cᵒᵖ) :
    functor.obj (functor S) Y =
        Subtype fun (g : opposite.unop Y ⟶ X) => coe_fn S (opposite.unop Y) g :=
  Eq.refl (functor.obj (functor S) Y)

/--
If a sieve S is contained in a sieve T, then we have a morphism of presheaves on their induced
presheaves.
-/
def nat_trans_of_le {C : Type u} [category C] {X : C} {S : sieve X} {T : sieve X} (h : S ≤ T) :
    functor S ⟶ functor T :=
  nat_trans.mk
    fun (Y : Cᵒᵖ) (f : functor.obj (functor S) Y) => { val := subtype.val f, property := sorry }

/-- The natural inclusion from the functor induced by a sieve to the yoneda embedding. -/
@[simp] theorem functor_inclusion_app {C : Type u} [category C] {X : C} (S : sieve X) (Y : Cᵒᵖ)
    (f : functor.obj (functor S) Y) : nat_trans.app (functor_inclusion S) Y f = subtype.val f :=
  Eq.refl (nat_trans.app (functor_inclusion S) Y f)

theorem nat_trans_of_le_comm {C : Type u} [category C] {X : C} {S : sieve X} {T : sieve X}
    (h : S ≤ T) : nat_trans_of_le h ≫ functor_inclusion T = functor_inclusion S :=
  rfl

/-- The presheaf induced by a sieve is a subobject of the yoneda embedding. -/
protected instance functor_inclusion_is_mono {C : Type u} [category C] {X : C} {S : sieve X} :
    mono (functor_inclusion S) :=
  mono.mk
    fun (Z : Cᵒᵖ ⥤ Type v) (f g : Z ⟶ functor S)
      (h : f ≫ functor_inclusion S = g ≫ functor_inclusion S) =>
      nat_trans.ext f g
        (funext
          fun (Y : Cᵒᵖ) =>
            funext fun (y : functor.obj Z Y) => subtype.ext (congr_fun (nat_trans.congr_app h Y) y))

/--
A natural transformation to a representable functor induces a sieve. This is the left inverse of
`functor_inclusion`, shown in `sieve_of_functor_inclusion`.
-/
-- TODO: Show that when `f` is mono, this is right inverse to `functor_inclusion` up to isomorphism.

@[simp] theorem sieve_of_subfunctor_apply {C : Type u} [category C] {X : C} {R : Cᵒᵖ ⥤ Type v}
    (f : R ⟶ functor.obj yoneda X) (Y : C) (g : Y ⟶ X) :
    coe_fn (sieve_of_subfunctor f) Y g =
        ∃ (t : functor.obj R (opposite.op Y)), nat_trans.app f (opposite.op Y) t = g :=
  Eq.refl (coe_fn (sieve_of_subfunctor f) Y g)

theorem sieve_of_subfunctor_functor_inclusion {C : Type u} [category C] {X : C} {S : sieve X} :
    sieve_of_subfunctor (functor_inclusion S) = S :=
  sorry

protected instance functor_inclusion_top_is_iso {C : Type u} [category C] {X : C} :
    is_iso (functor_inclusion ⊤) :=
  is_iso.mk
    (nat_trans.mk
      fun (Y : Cᵒᵖ) (a : functor.obj (functor.obj yoneda X) Y) =>
        { val := a, property := True.intro })

end Mathlib


/-
Copyright (c) 2019 Jean Lo. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Jean Lo, Yury Kudryashov
-/
import analysis.normed_space.basic
import topology.metric_space.hausdorff_distance

/-!
# Applications of the Hausdorff distance in normed spaces

Riesz's lemma, stated for a normed space over a normed field: for any
closed proper subspace `F` of `E`, there is a nonzero `x` such that `∥x - F∥`
is at least `r * ∥x∥` for any `r < 1`. This is `riesz_lemma`.

In a nondiscrete normed field (with an element `c` of norm `> 1`) and any `R > ∥c∥`, one can
guarantee `∥x∥ ≤ R` and `∥x - y∥ ≥ 1` for any `y` in `F`. This is `riesz_lemma_of_norm_lt`.

A further lemma, `metric.closed_ball_inf_dist_compl_subset_closure`, finds a *closed* ball within
the closure of a set `s` of optimal distance from a point in `x` to the frontier of `s`.
-/

open set metric
open_locale topological_space

variables {𝕜 : Type*} [normed_field 𝕜]
variables {E : Type*} [normed_group E] [normed_space 𝕜 E]
variables {F : Type*} [semi_normed_group F] [normed_space ℝ F]

/-- Riesz's lemma, which usually states that it is possible to find a
vector with norm 1 whose distance to a closed proper subspace is
arbitrarily close to 1. The statement here is in terms of multiples of
norms, since in general the existence of an element of norm exactly 1
is not guaranteed. For a variant giving an element with norm in `[1, R]`, see
`riesz_lemma_of_norm_lt`. -/
lemma riesz_lemma {F : subspace 𝕜 E} (hFc : is_closed (F : set E))
  (hF : ∃ x : E, x ∉ F) {r : ℝ} (hr : r < 1) :
  ∃ x₀ : E, x₀ ∉ F ∧ ∀ y ∈ F, r * ∥x₀∥ ≤ ∥x₀ - y∥ :=
begin
  classical,
  obtain ⟨x, hx⟩ : ∃ x : E, x ∉ F := hF,
  let d := metric.inf_dist x F,
  have hFn : (F : set E).nonempty, from ⟨_, F.zero_mem⟩,
  have hdp : 0 < d,
    from lt_of_le_of_ne metric.inf_dist_nonneg (λ heq, hx
    ((hFc.mem_iff_inf_dist_zero hFn).2 heq.symm)),
  let r' := max r 2⁻¹,
  have hr' : r' < 1, by { simp [r', hr], norm_num },
  have hlt : 0 < r' := lt_of_lt_of_le (by norm_num) (le_max_right r 2⁻¹),
  have hdlt : d < d / r', from (lt_div_iff hlt).mpr ((mul_lt_iff_lt_one_right hdp).2 hr'),
  obtain ⟨y₀, hy₀F, hxy₀⟩ : ∃ y ∈ F, dist x y < d / r' := (metric.inf_dist_lt_iff hFn).mp hdlt,
  have x_ne_y₀ : x - y₀ ∉ F,
  { by_contradiction h,
    have : (x - y₀) + y₀ ∈ F, from F.add_mem h hy₀F,
    simp only [neg_add_cancel_right, sub_eq_add_neg] at this,
    exact hx this },
  refine ⟨x - y₀, x_ne_y₀, λy hy, le_of_lt _⟩,
  have hy₀y : y₀ + y ∈ F, from F.add_mem hy₀F hy,
  calc
    r * ∥x - y₀∥ ≤ r' * ∥x - y₀∥ : mul_le_mul_of_nonneg_right (le_max_left _ _) (norm_nonneg _)
    ... < d : by { rw ←dist_eq_norm, exact (lt_div_iff' hlt).1 hxy₀ }
    ... ≤ dist x (y₀ + y) : metric.inf_dist_le_dist_of_mem hy₀y
    ... = ∥x - y₀ - y∥ : by { rw [sub_sub, dist_eq_norm] }
end

/--
A version of Riesz lemma: given a strict closed subspace `F`, one may find an element of norm `≤ R`
which is at distance  at least `1` of every element of `F`. Here, `R` is any given constant
strictly larger than the norm of an element of norm `> 1`. For a version without an `R`, see
`riesz_lemma`.

Since we are considering a general nondiscrete normed field, there may be a gap in possible norms
(for instance no element of norm in `(1,2)`). Hence, we can not allow `R` arbitrarily close to `1`,
and require `R > ∥c∥` for some `c : 𝕜` with norm `> 1`.
-/
lemma riesz_lemma_of_norm_lt
  {c : 𝕜} (hc : 1 < ∥c∥) {R : ℝ} (hR : ∥c∥ < R)
  {F : subspace 𝕜 E} (hFc : is_closed (F : set E)) (hF : ∃ x : E, x ∉ F) :
  ∃ x₀ : E, ∥x₀∥ ≤ R ∧ ∀ y ∈ F, 1 ≤ ∥x₀ - y∥ :=
begin
  have Rpos : 0 < R := (norm_nonneg _).trans_lt hR,
  have : ∥c∥ / R < 1, by { rw div_lt_iff Rpos, simpa using hR },
  rcases riesz_lemma hFc hF this with ⟨x, xF, hx⟩,
  have x0 : x ≠ 0 := λ H, by simpa [H] using xF,
  obtain ⟨d, d0, dxlt, ledx, -⟩ :
    ∃ (d : 𝕜), d ≠ 0 ∧ ∥d • x∥ < R ∧ R / ∥c∥ ≤ ∥d • x∥ ∧ ∥d∥⁻¹ ≤ R⁻¹ * ∥c∥ * ∥x∥ :=
      rescale_to_shell hc Rpos x0,
  refine ⟨d • x, dxlt.le, λ y hy, _⟩,
  set y' := d⁻¹ • y with hy',
  have y'F : y' ∈ F, by simp [hy', submodule.smul_mem _ _ hy],
  have yy' : y = d • y', by simp [hy', smul_smul, mul_inv_cancel d0],
  calc 1 = (∥c∥/R) * (R/∥c∥) : by field_simp [Rpos.ne', (zero_lt_one.trans hc).ne']
  ... ≤ (∥c∥/R) * (∥d • x∥) :
    mul_le_mul_of_nonneg_left ledx (div_nonneg (norm_nonneg _) Rpos.le)
  ... = ∥d∥ * (∥c∥/R * ∥x∥) : by { simp [norm_smul], ring }
  ... ≤ ∥d∥ * ∥x - y'∥ :
    mul_le_mul_of_nonneg_left (hx y' (by simp [hy', submodule.smul_mem _ _ hy])) (norm_nonneg _)
  ... = ∥d • x - y∥ : by simp [yy', ← smul_sub, norm_smul],
end

lemma metric.closed_ball_inf_dist_compl_subset_closure {x : F} {s : set F} (hx : x ∈ s) :
  closed_ball x (inf_dist x sᶜ) ⊆ closure s :=
begin
  cases eq_or_ne (inf_dist x sᶜ) 0 with h₀ h₀,
  { rw [h₀, closed_ball_zero'],
    exact closure_mono (singleton_subset_iff.2 hx) },
  { rw ← closure_ball x h₀,
    apply closure_mono,
    calc ball x (inf_dist x sᶜ) ⊆ sᶜᶜ : disjoint_iff_subset_compl_right.1 disjoint_ball_inf_dist
    ... = s : compl_compl s },
end