/-
Copyright (c) 2020 Bhavik Mehta, E. W. Ayers. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Bhavik Mehta, E. W. Ayers

! This file was ported from Lean 3 source module category_theory.sites.grothendieck
! leanprover-community/mathlib commit 14b69e9f3c16630440a2cbd46f1ddad0d561dee7
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathlib.CategoryTheory.Sites.Sieves
import Mathlib.CategoryTheory.Limits.Shapes.Pullbacks
import Mathlib.CategoryTheory.Limits.Shapes.Multiequalizer
import Mathlib.CategoryTheory.Category.Preorder
import Mathlib.Order.Copy

/-!
# Grothendieck topologies

Definition and lemmas about Grothendieck topologies.
A Grothendieck topology for a category `C` is a set of sieves on each object `X` satisfying
certain closure conditions.

Alternate versions of the axioms (in arrow form) are also described.
Two explicit examples of Grothendieck topologies are given:
* The dense topology
* The atomic topology
as well as the complete lattice structure on Grothendieck topologies (which gives two additional
explicit topologies: the discrete and trivial topologies.)

A pretopology, or a basis for a topology is defined in `Pretopology.lean`. The topology associated
to a topological space is defined in `Spaces.lean`.

## Tags

Grothendieck topology, coverage, pretopology, site

## References

* [nLab, *Grothendieck topology*](https://ncatlab.org/nlab/show/Grothendieck+topology)
* [S. MacLane, I. Moerdijk, *Sheaves in Geometry and Logic*][MM92]

## Implementation notes

We use the definition of [nlab] and [MM92][] (Chapter III, Section 2), where Grothendieck topologies
are saturated collections of morphisms, rather than the notions of the Stacks project (00VG) and
the Elephant, in which topologies are allowed to be unsaturated, and are then completed.
TODO (BM): Add the definition from Stacks, as a pretopology, and complete to a topology.

This is so that we can produce a bijective correspondence between Grothendieck topologies on a
small category and Lawvere-Tierney topologies on its presheaf topos, as well as the equivalence
between Grothendieck topoi and left exact reflective subcategories of presheaf toposes.
-/

universe w v u

namespace CategoryTheory

open CategoryTheory Category

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

/-- The definition of a Grothendieck topology: a set of sieves `J X` on each object `X` satisfying
three axioms:
1. For every object `X`, the maximal sieve is in `J X`.
2. If `S ∈ J X` then its pullback along any `h : Y ⟶ X` is in `J Y`.
3. If `S ∈ J X` and `R` is a sieve on `X`, then provided that the pullback of `R` along any arrow
   `f : Y ⟶ X` in `S` is in `J Y`, we have that `R` itself is in `J X`.

A sieve `S` on `X` is referred to as `J`-covering, (or just covering), if `S ∈ J X`.

See <https://stacks.math.columbia.edu/tag/00Z4>, or [nlab], or [MM92][] Chapter III, Section 2,
Definition 1.
-/
structure GrothendieckTopology where
  /-- A Grothendieck topology on `C` consists of a set of sieves for each object `X`,
    which satisfy some axioms. -/
  sieves : ∀ X : C, Set (Sieve X)
  /-- The sieves associated to each object must contain the top sieve.
    Use `GrothendieckTopology.top_mem`. -/
  top_mem' : ∀ X, ⊤ ∈ sieves X
  /-- Stability under pullback. Use `GrothendieckTopology.pullback_stable`. -/
  pullback_stable' : ∀ ⦃X Y : C⦄ ⦃S : Sieve X⦄ (f : Y ⟶ X), S ∈ sieves X → S.pullback f ∈ sieves Y
  /-- Transitivity of sieves in a Grothendieck topology.
    Use `GrothendieckTopology.transitive`. -/
  transitive' :
    ∀ ⦃X⦄ ⦃S : Sieve X⦄ (_ : S ∈ sieves X) (R : Sieve X),
      (∀ ⦃Y⦄ ⦃f : Y ⟶ X⦄, S f → R.pullback f ∈ sieves Y) → R ∈ sieves X
#align category_theory.grothendieck_topology CategoryTheory.GrothendieckTopology

namespace GrothendieckTopology

instance : CoeFun (GrothendieckTopology C) fun _ => ∀ X : C, Set (Sieve X) :=
  ⟨sieves⟩

variable {C}
variable {X Y : C} {S R : Sieve X}

variable (J : GrothendieckTopology C)

/-- An extensionality lemma in terms of the coercion to a pi-type.
We prove this explicitly rather than deriving it so that it is in terms of the coercion rather than
the projection `.sieves`.
-/
@[ext]
theorem ext {J₁ J₂ : GrothendieckTopology C} (h : (J₁ : ∀ X : C, Set (Sieve X)) = J₂) : J₁ = J₂ :=
  by
    cases J₁
    cases J₂
    congr
#align category_theory.grothendieck_topology.ext CategoryTheory.GrothendieckTopology.ext

/-
Porting note: This is now a syntactic tautology.
@[simp]
theorem mem_sieves_iff_coe : S ∈ J.sieves X ↔ S ∈ J X :=
  Iff.rfl
#align category_theory.grothendieck_topology.mem_sieves_iff_coe CategoryTheory.GrothendieckTopology.mem_sieves_iff_coe
-/

-- Also known as the maximality axiom.
@[simp]
theorem top_mem (X : C) : ⊤ ∈ J X :=
  J.top_mem' X
#align category_theory.grothendieck_topology.top_mem CategoryTheory.GrothendieckTopology.top_mem

-- Also known as the stability axiom.
@[simp]
theorem pullback_stable (f : Y ⟶ X) (hS : S ∈ J X) : S.pullback f ∈ J Y :=
  J.pullback_stable' f hS
#align category_theory.grothendieck_topology.pullback_stable CategoryTheory.GrothendieckTopology.pullback_stable

theorem transitive (hS : S ∈ J X) (R : Sieve X) (h : ∀ ⦃Y⦄ ⦃f : Y ⟶ X⦄, S f → R.pullback f ∈ J Y) :
    R ∈ J X :=
  J.transitive' hS R h
#align category_theory.grothendieck_topology.transitive CategoryTheory.GrothendieckTopology.transitive

theorem covering_of_eq_top : S = ⊤ → S ∈ J X := fun h => h.symm ▸ J.top_mem X
#align category_theory.grothendieck_topology.covering_of_eq_top CategoryTheory.GrothendieckTopology.covering_of_eq_top

/-- If `S` is a subset of `R`, and `S` is covering, then `R` is covering as well.

See <https://stacks.math.columbia.edu/tag/00Z5> (2), or discussion after [MM92] Chapter III,
Section 2, Definition 1.
-/

/-- The intersection of two covering sieves is covering.

See <https://stacks.math.columbia.edu/tag/00Z5> (1), or [MM92] Chapter III,
Section 2, Definition 1 (iv).
-/
theorem intersection_covering (rj : R ∈ J X) (sj : S ∈ J X) : R ⊓ S ∈ J X := by
  apply J.transitive rj _ fun Y f Hf => _
  intros Y f hf
  rw [Sieve.pullback_inter, R.pullback_eq_top_of_mem hf]
  simp [sj]
#align category_theory.grothendieck_topology.intersection_covering CategoryTheory.GrothendieckTopology.intersection_covering

@[simp]
theorem intersection_covering_iff : R ⊓ S ∈ J X ↔ R ∈ J X ∧ S ∈ J X :=
  ⟨fun h => ⟨J.superset_covering inf_le_left h, J.superset_covering inf_le_right h⟩, fun t =>
    intersection_covering _ t.1 t.2⟩
#align category_theory.grothendieck_topology.intersection_covering_iff CategoryTheory.GrothendieckTopology.intersection_covering_iff

theorem bind_covering {S : Sieve X} {R : ∀ ⦃Y : C⦄ ⦃f : Y ⟶ X⦄, S f → Sieve Y} (hS : S ∈ J X)
    (hR : ∀ ⦃Y⦄ ⦃f : Y ⟶ X⦄ (H : S f), R H ∈ J Y) : Sieve.bind S R ∈ J X :=
  J.transitive hS _ fun _ f hf => superset_covering J (Sieve.le_pullback_bind S R f hf) (hR hf)
#align category_theory.grothendieck_topology.bind_covering CategoryTheory.GrothendieckTopology.bind_covering

/-- The sieve `S` on `X` `J`-covers an arrow `f` to `X` if `S.pullback f ∈ J Y`.
This definition is an alternate way of presenting a Grothendieck topology.
-/
def Covers (S : Sieve X) (f : Y ⟶ X) : Prop :=
  S.pullback f ∈ J Y
#align category_theory.grothendieck_topology.covers CategoryTheory.GrothendieckTopology.Covers

theorem covers_iff (S : Sieve X) (f : Y ⟶ X) : J.Covers S f ↔ S.pullback f ∈ J Y :=
  Iff.rfl
#align category_theory.grothendieck_topology.covers_iff CategoryTheory.GrothendieckTopology.covers_iff

theorem covering_iff_covers_id (S : Sieve X) : S ∈ J X ↔ J.Covers S (𝟙 X) := by simp [covers_iff]
#align category_theory.grothendieck_topology.covering_iff_covers_id CategoryTheory.GrothendieckTopology.covering_iff_covers_id

/-- The maximality axiom in 'arrow' form: Any arrow `f` in `S` is covered by `S`. -/
theorem arrow_max (f : Y ⟶ X) (S : Sieve X) (hf : S f) : J.Covers S f := by
  rw [Covers, (Sieve.pullback_eq_top_iff_mem f).1 hf]
  apply J.top_mem
#align category_theory.grothendieck_topology.arrow_max CategoryTheory.GrothendieckTopology.arrow_max

/-- The stability axiom in 'arrow' form: If `S` covers `f` then `S` covers `g ≫ f` for any `g`. -/
theorem arrow_stable (f : Y ⟶ X) (S : Sieve X) (h : J.Covers S f) {Z : C} (g : Z ⟶ Y) :
    J.Covers S (g ≫ f) := by
  rw [covers_iff] at h⊢
  simp [h, Sieve.pullback_comp]
#align category_theory.grothendieck_topology.arrow_stable CategoryTheory.GrothendieckTopology.arrow_stable

/-- The transitivity axiom in 'arrow' form: If `S` covers `f` and every arrow in `S` is covered by
`R`, then `R` covers `f`.
-/
theorem arrow_trans (f : Y ⟶ X) (S R : Sieve X) (h : J.Covers S f) :
    (∀ {Z : C} (g : Z ⟶ X), S g → J.Covers R g) → J.Covers R f := by
  intro k
  apply J.transitive h
  intro Z g hg
  rw [← Sieve.pullback_comp]
  apply k (g ≫ f) hg
#align category_theory.grothendieck_topology.arrow_trans CategoryTheory.GrothendieckTopology.arrow_trans

theorem arrow_intersect (f : Y ⟶ X) (S R : Sieve X) (hS : J.Covers S f) (hR : J.Covers R f) :
    J.Covers (S ⊓ R) f := by simpa [covers_iff] using And.intro hS hR
#align category_theory.grothendieck_topology.arrow_intersect CategoryTheory.GrothendieckTopology.arrow_intersect

variable (C)

/-- The trivial Grothendieck topology, in which only the maximal sieve is covering. This topology is
also known as the indiscrete, coarse, or chaotic topology.

See [MM92] Chapter III, Section 2, example (a), or
https://en.wikipedia.org/wiki/Grothendieck_topology#The_discrete_and_indiscrete_topologies
-/
def trivial : GrothendieckTopology C where
  sieves X := {⊤}
  top_mem' X := rfl
  pullback_stable' X Y S f hf := by
    rw [Set.mem_singleton_iff] at hf⊢
    simp [hf]
  transitive' X S hS R hR :=
    by
    rw [Set.mem_singleton_iff, ← Sieve.id_mem_iff_eq_top] at hS
    simpa using hR hS
#align category_theory.grothendieck_topology.trivial CategoryTheory.GrothendieckTopology.trivial

/-- The discrete Grothendieck topology, in which every sieve is covering.

See https://en.wikipedia.org/wiki/Grothendieck_topology#The_discrete_and_indiscrete_topologies.
-/
def discrete : GrothendieckTopology C
    where
  sieves X := Set.univ
  top_mem' := by simp
  pullback_stable' X Y f := by simp
  transitive' := by simp
#align category_theory.grothendieck_topology.discrete CategoryTheory.GrothendieckTopology.discrete

variable {C}

theorem trivial_covering : S ∈ trivial C X ↔ S = ⊤ :=
  Set.mem_singleton_iff
#align category_theory.grothendieck_topology.trivial_covering CategoryTheory.GrothendieckTopology.trivial_covering

/-- See <https://stacks.math.columbia.edu/tag/00Z6> -/
instance : LE (GrothendieckTopology C)
    where le J₁ J₂ := (J₁ : ∀ X : C, Set (Sieve X)) ≤ (J₂ : ∀ X : C, Set (Sieve X))

theorem le_def {J₁ J₂ : GrothendieckTopology C} : J₁ ≤ J₂ ↔ (J₁ : ∀ X : C, Set (Sieve X)) ≤ J₂ :=
  Iff.rfl
#align category_theory.grothendieck_topology.le_def CategoryTheory.GrothendieckTopology.le_def

/-- See <https://stacks.math.columbia.edu/tag/00Z6> -/
instance : PartialOrder (GrothendieckTopology C) :=
  { instLEGrothendieckTopology with
    le_refl := fun J₁ => le_def.mpr le_rfl
    le_trans := fun J₁ J₂ J₃ h₁₂ h₂₃ => le_def.mpr (le_trans h₁₂ h₂₃)
    le_antisymm := fun J₁ J₂ h₁₂ h₂₁ => GrothendieckTopology.ext (le_antisymm h₁₂ h₂₁) }

/-- See <https://stacks.math.columbia.edu/tag/00Z7> -/
instance : InfSet (GrothendieckTopology C)
    where infₛ T :=
    { sieves := infₛ (sieves '' T)
      top_mem' := by
        rintro X S ⟨⟨_, J, hJ, rfl⟩, rfl⟩
        simp
      pullback_stable' := by
        rintro X Y S hS f _ ⟨⟨_, J, hJ, rfl⟩, rfl⟩
        apply J.pullback_stable _ (f _ ⟨⟨_, _, hJ, rfl⟩, rfl⟩)
      transitive' := by
        rintro X S hS R h _ ⟨⟨_, J, hJ, rfl⟩, rfl⟩
        apply
          J.transitive (hS _ ⟨⟨_, _, hJ, rfl⟩, rfl⟩) _ fun Y f hf => h hf _ ⟨⟨_, _, hJ, rfl⟩, rfl⟩ }

/-- See <https://stacks.math.columbia.edu/tag/00Z7> -/
theorem isGLB_infₛ (s : Set (GrothendieckTopology C)) : IsGLB s (infₛ s) := by
  refine' @IsGLB.of_image _ _ _ _ sieves _ _ _ _
  · intros
    rfl
  · exact _root_.isGLB_infₛ _
#align category_theory.grothendieck_topology.is_glb_Inf CategoryTheory.GrothendieckTopology.isGLB_infₛ

/-- Construct a complete lattice from the `Inf`, but make the trivial and discrete topologies
definitionally equal to the bottom and top respectively.
-/
instance : CompleteLattice (GrothendieckTopology C) :=
  CompleteLattice.copy (completeLatticeOfInf _ isGLB_infₛ) _ rfl (discrete C)
    (by
      apply le_antisymm
      · exact @CompleteLattice.le_top _ (completeLatticeOfInf _ isGLB_infₛ) (discrete C)
      · intro X S _
        apply Set.mem_univ)
    (trivial C)
    (by
      apply le_antisymm
      · intro X S hS
        rw [trivial_covering] at hS
        apply covering_of_eq_top _ hS
      · refine' @CompleteLattice.bot_le _ (completeLatticeOfInf _ isGLB_infₛ) (trivial C))
    _ rfl _ rfl _ rfl infₛ rfl

instance : Inhabited (GrothendieckTopology C) :=
  ⟨⊤⟩

@[simp]
theorem trivial_eq_bot : trivial C = ⊥ :=
  rfl
#align category_theory.grothendieck_topology.trivial_eq_bot CategoryTheory.GrothendieckTopology.trivial_eq_bot

@[simp]
theorem discrete_eq_top : discrete C = ⊤ :=
  rfl
#align category_theory.grothendieck_topology.discrete_eq_top CategoryTheory.GrothendieckTopology.discrete_eq_top

@[simp]
theorem bot_covering : S ∈ (⊥ : GrothendieckTopology C) X ↔ S = ⊤ :=
  trivial_covering
#align category_theory.grothendieck_topology.bot_covering CategoryTheory.GrothendieckTopology.bot_covering

@[simp]
theorem top_covering : S ∈ (⊤ : GrothendieckTopology C) X :=
  ⟨⟩
#align category_theory.grothendieck_topology.top_covering CategoryTheory.GrothendieckTopology.top_covering

theorem bot_covers (S : Sieve X) (f : Y ⟶ X) : (⊥ : GrothendieckTopology C).Covers S f ↔ S f := by
  rw [covers_iff, bot_covering, ← Sieve.pullback_eq_top_iff_mem]
#align category_theory.grothendieck_topology.bot_covers CategoryTheory.GrothendieckTopology.bot_covers

@[simp]
theorem top_covers (S : Sieve X) (f : Y ⟶ X) : (⊤ : GrothendieckTopology C).Covers S f := by
  simp [covers_iff]
#align category_theory.grothendieck_topology.top_covers CategoryTheory.GrothendieckTopology.top_covers

/-- The dense Grothendieck topology.

See https://ncatlab.org/nlab/show/dense+topology, or [MM92] Chapter III, Section 2, example (e).
-/
def dense : GrothendieckTopology C
    where
  sieves X S := ∀ {Y : C} (f : Y ⟶ X), ∃ (Z : _) (g : Z ⟶ Y), S (g ≫ f)
  top_mem' X Y f := ⟨Y, 𝟙 Y, ⟨⟩⟩
  pullback_stable' := by
    intro X Y S h H Z f
    rcases H (f ≫ h) with ⟨W, g, H'⟩
    exact ⟨W, g, by simpa⟩
  transitive' := by
    intro X S H₁ R H₂ Y f
    rcases H₁ f with ⟨Z, g, H₃⟩
    rcases H₂ H₃ (𝟙 Z) with ⟨W, h, H₄⟩
    exact ⟨W, h ≫ g, by simpa using H₄⟩
#align category_theory.grothendieck_topology.dense CategoryTheory.GrothendieckTopology.dense

theorem dense_covering : S ∈ dense X ↔ ∀ {Y} (f : Y ⟶ X), ∃ (Z : _)(g : Z ⟶ Y), S (g ≫ f) :=
  Iff.rfl
#align category_theory.grothendieck_topology.dense_covering CategoryTheory.GrothendieckTopology.dense_covering

/--
A category satisfies the right Ore condition if any span can be completed to a commutative square.
NB. Any category with pullbacks obviously satisfies the right Ore condition, see
`right_ore_of_pullbacks`.
-/
def RightOreCondition (C : Type u) [Category.{v} C] : Prop :=
  ∀ {X Y Z : C} (yx : Y ⟶ X) (zx : Z ⟶ X), ∃ (W : _)(wy : W ⟶ Y)(wz : W ⟶ Z), wy ≫ yx = wz ≫ zx
#align category_theory.grothendieck_topology.right_ore_condition CategoryTheory.GrothendieckTopology.RightOreCondition

theorem right_ore_of_pullbacks [Limits.HasPullbacks C] : RightOreCondition C := fun _ _ =>
  ⟨_, _, _, Limits.pullback.condition⟩
#align category_theory.grothendieck_topology.right_ore_of_pullbacks CategoryTheory.GrothendieckTopology.right_ore_of_pullbacks

/-- The atomic Grothendieck topology: a sieve is covering iff it is nonempty.
For the pullback stability condition, we need the right Ore condition to hold.

See https://ncatlab.org/nlab/show/atomic+site, or [MM92] Chapter III, Section 2, example (f).
-/
def atomic (hro : RightOreCondition C) : GrothendieckTopology C
    where
  sieves X S := ∃ (Y : _)(f : Y ⟶ X), S f
  top_mem' X := ⟨_, 𝟙 _, ⟨⟩⟩
  pullback_stable' := by
    rintro X Y S h ⟨Z, f, hf⟩
    rcases hro h f with ⟨W, g, k, comm⟩
    refine' ⟨_, g, _⟩
    simp [comm, hf]
  transitive' := by
    rintro X S ⟨Y, f, hf⟩ R h
    rcases h hf with ⟨Z, g, hg⟩
    exact ⟨_, _, hg⟩
#align category_theory.grothendieck_topology.atomic CategoryTheory.GrothendieckTopology.atomic

/-- `J.Cover X` denotes the poset of covers of `X` with respect to the
Grothendieck topology `J`. -/
def Cover (X : C) :=
  { S : Sieve X // S ∈ J X } -- deriving Preorder
#align category_theory.grothendieck_topology.cover CategoryTheory.GrothendieckTopology.Cover

-- Porting note: `deriving` didn't work above, so we add the preorder instance manually.
instance (X : C) : Preorder (J.Cover X) :=
  show Preorder {S : Sieve X // S ∈ J X} from inferInstance

namespace Cover

variable {J}

/-
Porting note: Lean complains that this is a dangerous instance.
I'm commenting this out since the `CoeFun` instance below is what we
use 99% of the time anyway.

instance : Coe (J.Cover X) (Sieve X) :=
  ⟨fun S => S.1⟩
-/

/-
Porting note: Added this def as a replacement for the "dangerous" `Coe` above.
-/
/-- The sieve associated to a term of `J.Cover X`.-/
def sieve (S : J.Cover X) : Sieve X := S.1

/-
Porting note: This somehow yields different behavior than the better instance below. Why?!

With this instance, we have to write `S _ f` but with the uncommented one, we can write `S f`
as expected.

instance : CoeFun (J.Cover X) fun _ => ∀ ⦃Y⦄ (_ : Y ⟶ X), Prop :=
  ⟨fun S _ f => (S : Sieve X) f⟩
-/

instance : CoeFun (J.Cover X) fun _ => ∀ ⦃Y⦄ (_ : Y ⟶ X), Prop :=
  ⟨fun S => S.sieve⟩

/-
Porting note: This is now a syntactic tautology.

@[simp]
theorem coe_fun_coe (S : J.Cover X) (f : Y ⟶ X) : S.sieve f = S f :=
  rfl
#align category_theory.grothendieck_topology.cover.coe_fun_coe CategoryTheory.GrothendieckTopology.Cover.coe_fun_coe
-/

theorem condition (S : J.Cover X) : S.sieve ∈ J X :=
  S.2
#align category_theory.grothendieck_topology.cover.condition CategoryTheory.GrothendieckTopology.Cover.condition

@[ext]
theorem ext (S T : J.Cover X) (h : ∀ ⦃Y⦄ (f : Y ⟶ X), S f ↔ T f) : S = T :=
  Subtype.ext <| Sieve.ext h
#align category_theory.grothendieck_topology.cover.ext CategoryTheory.GrothendieckTopology.Cover.ext

instance : OrderTop (J.Cover X) :=
  { (inferInstance : Preorder (J.Cover X)) with
    top := ⟨⊤, J.top_mem _⟩
    le_top := fun S Y f _ => by tauto }

instance : SemilatticeInf (J.Cover X) :=
  { (inferInstance : Preorder _) with
    inf := fun S T => ⟨S.sieve ⊓ T.sieve,
      J.intersection_covering S.condition T.condition⟩
    le_antisymm := fun S T h1 h2 => ext _ _ fun {Y} f => ⟨by apply h1, by apply h2⟩
    inf_le_left := fun S T Y f hf => hf.1
    inf_le_right := fun S T Y f hf => hf.2
    le_inf := fun S T W h1 h2 Y f h => ⟨h1 _ h, h2 _ h⟩ }

instance : Inhabited (J.Cover X) :=
  ⟨⊤⟩

/-- An auxiliary structure, used to define `S.index`. -/
--@[nolint has_nonempty_instance, ext]
@[ext]
structure Arrow (S : J.Cover X) where
  /-- The source of the arrow. -/
  Y : C
  /-- The arrow itself. -/
  f : Y ⟶ X
  /-- The given arrow is contained in the given sieve. -/
  hf : S f
#align category_theory.grothendieck_topology.cover.arrow CategoryTheory.GrothendieckTopology.Cover.Arrow

/-- An auxiliary structure, used to define `S.index`. -/
--@[nolint has_nonempty_instance, ext]
@[ext]
structure Relation (S : J.Cover X) where
  /-- The source of the first arrow. -/
  Y₁ : C
  /-- The source of the second arrow. -/
  Y₂ : C
  /-- The source of the arrows defining the relation. -/
  Z : C
  /-- The first arrow defining the relation. -/
  g₁ : Z ⟶ Y₁
  /-- The second arrow defining the relation. -/
  g₂ : Z ⟶ Y₂
  /-- The first arrow which is part of the relation. -/
  f₁ : Y₁ ⟶ X
  /-- The second arrow which is part of the relation. -/
  f₂ : Y₂ ⟶ X
  /-- The first arrow which is part of the relation is contained in the given sieve. -/
  h₁ : S f₁
  /-- The second arrow which is part of the relation is contained in the given sieve. -/
  h₂ : S f₂
  /-- The relation itself. -/
  w : g₁ ≫ f₁ = g₂ ≫ f₂
#align category_theory.grothendieck_topology.cover.relation CategoryTheory.GrothendieckTopology.Cover.Relation

/-- Map a `Arrow` along a refinement `S ⟶ T`. -/
@[simps]
def Arrow.map {S T : J.Cover X} (I : S.Arrow) (f : S ⟶ T) : T.Arrow :=
  ⟨I.Y, I.f, f.le _ I.hf⟩
#align category_theory.grothendieck_topology.cover.arrow.map CategoryTheory.GrothendieckTopology.Cover.Arrow.map

/-- Map a `Relation` along a refinement `S ⟶ T`. -/
@[simps]
def Relation.map {S T : J.Cover X} (I : S.Relation) (f : S ⟶ T) : T.Relation :=
  ⟨_, _, _, I.g₁, I.g₂, I.f₁, I.f₂, f.le _ I.h₁, f.le _ I.h₂, I.w⟩
#align category_theory.grothendieck_topology.cover.relation.map CategoryTheory.GrothendieckTopology.Cover.Relation.map

/-- The first `Arrow` associated to a `Relation`.
Used in defining `index`. -/
@[simps]
def Relation.fst {S : J.Cover X} (I : S.Relation) : S.Arrow :=
  ⟨I.Y₁, I.f₁, I.h₁⟩
#align category_theory.grothendieck_topology.cover.relation.fst CategoryTheory.GrothendieckTopology.Cover.Relation.fst

/-- The second `Arrow` associated to a `Relation`.
Used in defining `index`. -/
@[simps]
def Relation.snd {S : J.Cover X} (I : S.Relation) : S.Arrow :=
  ⟨I.Y₂, I.f₂, I.h₂⟩
#align category_theory.grothendieck_topology.cover.relation.snd CategoryTheory.GrothendieckTopology.Cover.Relation.snd

@[simp]
theorem Relation.map_fst {S T : J.Cover X} (I : S.Relation) (f : S ⟶ T) :
    I.fst.map f = (I.map f).fst :=
  rfl
#align category_theory.grothendieck_topology.cover.relation.map_fst CategoryTheory.GrothendieckTopology.Cover.Relation.map_fst

@[simp]
theorem Relation.map_snd {S T : J.Cover X} (I : S.Relation) (f : S ⟶ T) :
    I.snd.map f = (I.map f).snd :=
  rfl
#align category_theory.grothendieck_topology.cover.relation.map_snd CategoryTheory.GrothendieckTopology.Cover.Relation.map_snd

/-- Pull back a cover along a morphism. -/
def pullback (S : J.Cover X) (f : Y ⟶ X) : J.Cover Y :=
  ⟨Sieve.pullback f S.sieve, J.pullback_stable _ S.condition⟩
#align category_theory.grothendieck_topology.cover.pullback CategoryTheory.GrothendieckTopology.Cover.pullback

/-- An arrow of `S.pullback f` gives rise to an arrow of `S`. -/
@[simps]
def Arrow.base {f : Y ⟶ X} {S : J.Cover X} (I : (S.pullback f).Arrow) : S.Arrow :=
  ⟨I.Y, I.f ≫ f, I.hf⟩
#align category_theory.grothendieck_topology.cover.arrow.base CategoryTheory.GrothendieckTopology.Cover.Arrow.base

/-- A relation of `S.pullback f` gives rise to a relation of `S`. -/
@[simps]
def Relation.base {f : Y ⟶ X} {S : J.Cover X} (I : (S.pullback f).Relation) : S.Relation :=
  ⟨_, _, _, I.g₁, I.g₂, I.f₁ ≫ f, I.f₂ ≫ f, I.h₁, I.h₂, by simp [reassoc_of% I.w]⟩
#align category_theory.grothendieck_topology.cover.relation.base CategoryTheory.GrothendieckTopology.Cover.Relation.base

@[simp]
theorem Relation.base_fst {f : Y ⟶ X} {S : J.Cover X} (I : (S.pullback f).Relation) :
    I.fst.base = I.base.fst :=
  rfl
#align category_theory.grothendieck_topology.cover.relation.base_fst CategoryTheory.GrothendieckTopology.Cover.Relation.base_fst

@[simp]
theorem Relation.base_snd {f : Y ⟶ X} {S : J.Cover X} (I : (S.pullback f).Relation) :
    I.snd.base = I.base.snd :=
  rfl
#align category_theory.grothendieck_topology.cover.relation.base_snd CategoryTheory.GrothendieckTopology.Cover.Relation.base_snd

@[simp]
theorem coe_pullback {Z : C} (f : Y ⟶ X) (g : Z ⟶ Y) (S : J.Cover X) :
    (S.pullback f) g ↔ S (g ≫ f) :=
  Iff.rfl
#align category_theory.grothendieck_topology.cover.coe_pullback CategoryTheory.GrothendieckTopology.Cover.coe_pullback

/-- The isomorphism between `S` and the pullback of `S` w.r.t. the identity. -/
def pullbackId (S : J.Cover X) : S.pullback (𝟙 X) ≅ S :=
  eqToIso <| Cover.ext _ _ fun Y f => by simp
#align category_theory.grothendieck_topology.cover.pullback_id CategoryTheory.GrothendieckTopology.Cover.pullbackId

/-- Pulling back with respect to a composition is the composition of the pullbacks. -/
def pullbackComp {X Y Z : C} (S : J.Cover X) (f : Z ⟶ Y) (g : Y ⟶ X) :
    S.pullback (f ≫ g) ≅ (S.pullback g).pullback f :=
  eqToIso <| Cover.ext _ _ fun Y f => by simp
#align category_theory.grothendieck_topology.cover.pullback_comp CategoryTheory.GrothendieckTopology.Cover.pullbackComp

/-- Combine a family of covers over a cover. -/
def bind {X : C} (S : J.Cover X) (T : ∀ I : S.Arrow, J.Cover I.Y) : J.Cover X :=
  ⟨Sieve.bind S.sieve fun Y f hf => (T ⟨Y, f, hf⟩).sieve,
    J.bind_covering S.condition fun _ _ _ => (T _).condition⟩
#align category_theory.grothendieck_topology.cover.bind CategoryTheory.GrothendieckTopology.Cover.bind

/-- The canonical moprhism from `S.bind T` to `T`. -/
def bindToBase {X : C} (S : J.Cover X) (T : ∀ I : S.Arrow, J.Cover I.Y) : S.bind T ⟶ S :=
  homOfLE <| by
    rintro Y f ⟨Z, e1, e2, h1, _, h3⟩
    rw [← h3]
    apply Sieve.downward_closed
    exact h1
#align category_theory.grothendieck_topology.cover.bind_to_base CategoryTheory.GrothendieckTopology.Cover.bindToBase

/-- An arrow in bind has the form `A ⟶ B ⟶ X` where `A ⟶ B` is an arrow in `T I` for some `I`.
 and `B ⟶ X` is an arrow of `S`. This is the object `B`. -/
noncomputable def Arrow.middle {X : C} {S : J.Cover X} {T : ∀ I : S.Arrow, J.Cover I.Y}
    (I : (S.bind T).Arrow) : C :=
  I.hf.choose
#align category_theory.grothendieck_topology.cover.arrow.middle CategoryTheory.GrothendieckTopology.Cover.Arrow.middle

/-- An arrow in bind has the form `A ⟶ B ⟶ X` where `A ⟶ B` is an arrow in `T I` for some `I`.
 and `B ⟶ X` is an arrow of `S`. This is the hom `A ⟶ B`. -/
noncomputable def Arrow.toMiddleHom {X : C} {S : J.Cover X} {T : ∀ I : S.Arrow, J.Cover I.Y}
    (I : (S.bind T).Arrow) : I.Y ⟶ I.middle :=
  I.hf.choose_spec.choose
#align category_theory.grothendieck_topology.cover.arrow.to_middle_hom CategoryTheory.GrothendieckTopology.Cover.Arrow.toMiddleHom

/-- An arrow in bind has the form `A ⟶ B ⟶ X` where `A ⟶ B` is an arrow in `T I` for some `I`.
 and `B ⟶ X` is an arrow of `S`. This is the hom `B ⟶ X`. -/
noncomputable def Arrow.fromMiddleHom {X : C} {S : J.Cover X} {T : ∀ I : S.Arrow, J.Cover I.Y}
    (I : (S.bind T).Arrow) : I.middle ⟶ X :=
  I.hf.choose_spec.choose_spec.choose
#align category_theory.grothendieck_topology.cover.arrow.from_middle_hom CategoryTheory.GrothendieckTopology.Cover.Arrow.fromMiddleHom

theorem Arrow.from_middle_condition {X : C} {S : J.Cover X} {T : ∀ I : S.Arrow, J.Cover I.Y}
    (I : (S.bind T).Arrow) : S I.fromMiddleHom :=
  I.hf.choose_spec.choose_spec.choose_spec.choose
#align category_theory.grothendieck_topology.cover.arrow.from_middle_condition CategoryTheory.GrothendieckTopology.Cover.Arrow.from_middle_condition

/-- An arrow in bind has the form `A ⟶ B ⟶ X` where `A ⟶ B` is an arrow in `T I` for some `I`.
 and `B ⟶ X` is an arrow of `S`. This is the hom `B ⟶ X`, as an arrow. -/
noncomputable def Arrow.fromMiddle {X : C} {S : J.Cover X} {T : ∀ I : S.Arrow, J.Cover I.Y}
    (I : (S.bind T).Arrow) : S.Arrow :=
  ⟨_, I.fromMiddleHom, I.from_middle_condition⟩
#align category_theory.grothendieck_topology.cover.arrow.from_middle CategoryTheory.GrothendieckTopology.Cover.Arrow.fromMiddle

theorem Arrow.to_middle_condition {X : C} {S : J.Cover X} {T : ∀ I : S.Arrow, J.Cover I.Y}
    (I : (S.bind T).Arrow) : (T I.fromMiddle) I.toMiddleHom :=
  I.hf.choose_spec.choose_spec.choose_spec.choose_spec.1
#align category_theory.grothendieck_topology.cover.arrow.to_middle_condition CategoryTheory.GrothendieckTopology.Cover.Arrow.to_middle_condition

/-- An arrow in bind has the form `A ⟶ B ⟶ X` where `A ⟶ B` is an arrow in `T I` for some `I`.
 and `B ⟶ X` is an arrow of `S`. This is the hom `A ⟶ B`, as an arrow. -/
noncomputable def Arrow.toMiddle {X : C} {S : J.Cover X} {T : ∀ I : S.Arrow, J.Cover I.Y}
    (I : (S.bind T).Arrow) : (T I.fromMiddle).Arrow :=
  ⟨_, I.toMiddleHom, I.to_middle_condition⟩
#align category_theory.grothendieck_topology.cover.arrow.to_middle CategoryTheory.GrothendieckTopology.Cover.Arrow.toMiddle

theorem Arrow.middle_spec {X : C} {S : J.Cover X} {T : ∀ I : S.Arrow, J.Cover I.Y}
    (I : (S.bind T).Arrow) : I.toMiddleHom ≫ I.fromMiddleHom = I.f :=
  I.hf.choose_spec.choose_spec.choose_spec.choose_spec.2
#align category_theory.grothendieck_topology.cover.arrow.middle_spec CategoryTheory.GrothendieckTopology.Cover.Arrow.middle_spec

-- This is used extensively in `Plus.lean`, etc.
-- We place this definition here as it will be used in `Sheaf.lean` as well.
/-- To every `S : J.Cover X` and presheaf `P`, associate a `MulticospanIndex`. -/
def index {D : Type w} [Category.{max v u} D] (S : J.Cover X) (P : Cᵒᵖ ⥤ D) :
    Limits.MulticospanIndex D where
  L := S.Arrow
  R := S.Relation
  fstTo I := I.fst
  sndTo I := I.snd
  left I := P.obj (Opposite.op I.Y)
  right I := P.obj (Opposite.op I.Z)
  fst I := P.map I.g₁.op
  snd I := P.map I.g₂.op
#align category_theory.grothendieck_topology.cover.index CategoryTheory.GrothendieckTopology.Cover.index

/-- The natural multifork associated to `S : J.Cover X` for a presheaf `P`.
Saying that this multifork is a limit is essentially equivalent to the sheaf condition at the
given object for the given covering sieve. See `Sheaf.lean` for an equivalent sheaf condition
using this.
-/
abbrev multifork {D : Type w} [Category.{max v u} D] (S : J.Cover X) (P : Cᵒᵖ ⥤ D) :
    Limits.Multifork (S.index P) :=
  Limits.Multifork.ofι _ (P.obj (Opposite.op X)) (fun I => P.map I.f.op)
    (by
      intro I
      dsimp [index]
      simp only [← P.map_comp, ← op_comp, I.w])
#align category_theory.grothendieck_topology.cover.multifork CategoryTheory.GrothendieckTopology.Cover.multifork

/-- The canonical map from `P.obj (op X)` to the multiequalizer associated to a covering sieve,
assuming such a multiequalizer exists. This will be used in `Sheaf.lean` to provide an equivalent
sheaf condition in terms of multiequalizers. -/
noncomputable abbrev toMultiequalizer {D : Type w} [Category.{max v u} D] (S : J.Cover X)
    (P : Cᵒᵖ ⥤ D) [Limits.HasMultiequalizer (S.index P)] :
    P.obj (Opposite.op X) ⟶ Limits.multiequalizer (S.index P) :=
  Limits.Multiequalizer.lift _ _ (fun I => P.map I.f.op)
    (by
      intro I
      dsimp only [index, Relation.fst, Relation.snd]
      simp only [← P.map_comp, ← op_comp, I.w])
#align category_theory.grothendieck_topology.cover.to_multiequalizer CategoryTheory.GrothendieckTopology.Cover.toMultiequalizer

end Cover

/-- Pull back a cover along a morphism. -/
@[simps obj]
def pullback (f : Y ⟶ X) : J.Cover X ⥤ J.Cover Y
    where
  obj S := S.pullback f
  -- Porting note: `(Sieve.pullback_monotone _ f.le).hom` causes issues...
  map f := homOfLE (Sieve.pullback_monotone _ f.le)
#align category_theory.grothendieck_topology.pullback CategoryTheory.GrothendieckTopology.pullback

/-- Pulling back along the identity is naturally isomorphic to the identity functor. -/
def pullbackId (X : C) : J.pullback (𝟙 X) ≅ 𝟭 _ :=
  (NatIso.ofComponents fun S => S.pullbackId) <| by aesop_cat
#align category_theory.grothendieck_topology.pullback_id CategoryTheory.GrothendieckTopology.pullbackId

/-- Pulling back along a composition is naturally isomorphic to
the composition of the pullbacks. -/
def pullbackComp {X Y Z : C} (f : X ⟶ Y) (g : Y ⟶ Z) :
    J.pullback (f ≫ g) ≅ J.pullback g ⋙ J.pullback f :=
  (NatIso.ofComponents fun S => S.pullbackComp f g) <| by aesop_cat
#align category_theory.grothendieck_topology.pullback_comp CategoryTheory.GrothendieckTopology.pullbackComp

end GrothendieckTopology

end CategoryTheory


/-
Copyright (c) 2022 Yaël Dillies, Sara Rousta. 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.upper_lower.hom
! leanprover-community/mathlib commit b6da1a0b3e7cd83b1f744c49ce48ef8c6307d2f6
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.Order.UpperLower.Basic
import Mathbin.Order.Hom.CompleteLattice

/-!
# `upper_set.Ici` etc as `sup`/`Sup`/`inf`/`Inf`-homomorphisms

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

In this file we define `upper_set.Ici_sup_hom` etc. These functions are `upper_set.Ici` and
`lower_set.Iic` bundled as `sup_hom`s, `inf_hom`s, `Sup_hom`s, or `Inf_hom`s.
-/

variable {α : Type _}

open OrderDual

namespace UpperSet

section SemilatticeSup

variable [SemilatticeSup α]

/- warning: upper_set.Ici_sup_hom -> UpperSet.iciSupHom is a dubious translation:
lean 3 declaration is
  forall {α : Type.{u1}} [_inst_1 : SemilatticeSup.{u1} α], SupHom.{u1, u1} α (UpperSet.{u1} α (Preorder.toLE.{u1} α (PartialOrder.toPreorder.{u1} α (SemilatticeSup.toPartialOrder.{u1} α _inst_1)))) (SemilatticeSup.toHasSup.{u1} α _inst_1) (UpperSet.hasSup.{u1} α (Preorder.toLE.{u1} α (PartialOrder.toPreorder.{u1} α (SemilatticeSup.toPartialOrder.{u1} α _inst_1))))
but is expected to have type
  forall {α : Type.{u1}} [_inst_1 : SemilatticeSup.{u1} α], SupHom.{u1, u1} α (UpperSet.{u1} α (Preorder.toLE.{u1} α (PartialOrder.toPreorder.{u1} α (SemilatticeSup.toPartialOrder.{u1} α _inst_1)))) (SemilatticeSup.toSup.{u1} α _inst_1) (UpperSet.instSupUpperSet.{u1} α (Preorder.toLE.{u1} α (PartialOrder.toPreorder.{u1} α (SemilatticeSup.toPartialOrder.{u1} α _inst_1))))
Case conversion may be inaccurate. Consider using '#align upper_set.Ici_sup_hom UpperSet.iciSupHomₓ'. -/
/-- `upper_set.Ici` as a `sup_hom`. -/
def iciSupHom : SupHom α (UpperSet α) :=
  ⟨Ici, Ici_sup⟩
#align upper_set.Ici_sup_hom UpperSet.iciSupHom

#print UpperSet.coe_iciSupHom /-
@[simp]
theorem coe_iciSupHom : (iciSupHom : α → UpperSet α) = Ici :=
  rfl
#align upper_set.coe_Ici_sup_hom UpperSet.coe_iciSupHom
-/

#print UpperSet.iciSupHom_apply /-
@[simp]
theorem iciSupHom_apply (a : α) : iciSupHom a = Ici a :=
  rfl
#align upper_set.Ici_sup_hom_apply UpperSet.iciSupHom_apply
-/

end SemilatticeSup

variable [CompleteLattice α]

/-- `upper_set.Ici` as a `Sup_hom`. -/
def iciSupₛHom : SupₛHom α (UpperSet α) :=
  ⟨Ici, fun s => (Ici_supₛ s).trans supₛ_image.symm⟩
#align upper_set.Ici_Sup_hom UpperSet.iciSupₛHomₓ

@[simp]
theorem coe_iciSupₛHom : (iciSupₛHom : α → UpperSet α) = Ici :=
  rfl
#align upper_set.coe_Ici_Sup_hom UpperSet.coe_iciSupₛHomₓ

@[simp]
theorem iciSupₛHom_apply (a : α) : iciSupₛHom a = Ici a :=
  rfl
#align upper_set.Ici_Sup_hom_apply UpperSet.iciSupₛHom_applyₓ

end UpperSet

namespace LowerSet

section SemilatticeInf

variable [SemilatticeInf α]

/- warning: lower_set.Iic_inf_hom -> LowerSet.iicInfHom is a dubious translation:
lean 3 declaration is
  forall {α : Type.{u1}} [_inst_1 : SemilatticeInf.{u1} α], InfHom.{u1, u1} α (LowerSet.{u1} α (Preorder.toLE.{u1} α (PartialOrder.toPreorder.{u1} α (SemilatticeInf.toPartialOrder.{u1} α _inst_1)))) (SemilatticeInf.toHasInf.{u1} α _inst_1) (LowerSet.hasInf.{u1} α (Preorder.toLE.{u1} α (PartialOrder.toPreorder.{u1} α (SemilatticeInf.toPartialOrder.{u1} α _inst_1))))
but is expected to have type
  forall {α : Type.{u1}} [_inst_1 : SemilatticeInf.{u1} α], InfHom.{u1, u1} α (LowerSet.{u1} α (Preorder.toLE.{u1} α (PartialOrder.toPreorder.{u1} α (SemilatticeInf.toPartialOrder.{u1} α _inst_1)))) (SemilatticeInf.toInf.{u1} α _inst_1) (LowerSet.instInfLowerSet.{u1} α (Preorder.toLE.{u1} α (PartialOrder.toPreorder.{u1} α (SemilatticeInf.toPartialOrder.{u1} α _inst_1))))
Case conversion may be inaccurate. Consider using '#align lower_set.Iic_inf_hom LowerSet.iicInfHomₓ'. -/
/-- `lower_set.Iic` as an `inf_hom`. -/
def iicInfHom : InfHom α (LowerSet α) :=
  ⟨Iic, Iic_inf⟩
#align lower_set.Iic_inf_hom LowerSet.iicInfHom

#print LowerSet.coe_iicInfHom /-
@[simp]
theorem coe_iicInfHom : (iicInfHom : α → LowerSet α) = Iic :=
  rfl
#align lower_set.coe_Iic_inf_hom LowerSet.coe_iicInfHom
-/

#print LowerSet.iicInfHom_apply /-
@[simp]
theorem iicInfHom_apply (a : α) : iicInfHom a = Iic a :=
  rfl
#align lower_set.Iic_inf_hom_apply LowerSet.iicInfHom_apply
-/

end SemilatticeInf

variable [CompleteLattice α]

/-- `lower_set.Iic` as an `Inf_hom`. -/
def iicInfₛHom : InfₛHom α (LowerSet α) :=
  ⟨Iic, fun s => (Iic_infₛ s).trans infₛ_image.symm⟩
#align lower_set.Iic_Inf_hom LowerSet.iicInfₛHomₓ

@[simp]
theorem coe_iicInfₛHom : (iicInfₛHom : α → LowerSet α) = Iic :=
  rfl
#align lower_set.coe_Iic_Inf_hom LowerSet.coe_iicInfₛHomₓ

@[simp]
theorem iicInfₛHom_apply (a : α) : iicInfₛHom a = Iic a :=
  rfl
#align lower_set.Iic_Inf_hom_apply LowerSet.iicInfₛHom_applyₓ

end LowerSet


/-
Copyright (c) 2023 Devon Tuma. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Devon Tuma
-/
import computational_monads.support.fin_support

/-!
# Support of Monadic Oracle Constructions

This file defines additional lemmas about `support` applied to constructions
given by a composition of monad operations.
-/

namespace oracle_comp

open oracle_spec

variables {α β γ : Type} {spec : oracle_spec}

section return_bind

variables (a : α) (ob : α → oracle_comp spec β) (y : β)

lemma support_return_bind : (return a >>= ob).support = (ob a).support :=
by simp only [support_bind, mem_support_return_iff, set.Union_Union_eq_left]

lemma mem_support_return_bind_iff : y ∈ (return a >>= ob).support ↔ y ∈ (ob a).support :=
by rw [support_return_bind]

variables [decidable_eq α] [∀ a, decidable (ob a)]

lemma fin_support_return_bind : (return a >>= ob).fin_support = (ob a).fin_support :=
by simp only [fin_support_bind, fin_support_return, finset.singleton_bUnion]

lemma mem_fin_support_return_bind_iff :
  y ∈ (return a >>= ob).fin_support ↔ y ∈ (ob a).fin_support :=
by rw [fin_support_return_bind]

end return_bind

section bind_return

variables (oa : oracle_comp spec α) (f : α → β) (y : β)

@[simp] lemma support_bind_return : (oa >>= λ x, return (f x)).support = f '' oa.support :=
calc (f <$> oa).support = ⋃ x ∈ oa.support, {f x} : rfl
  ... = f '' (⋃ x ∈ oa.support, {x}) : by simp only [set.image_Union, set.image_singleton]
  ... = f '' oa.support : congr_arg (λ _, f '' _) (set.bUnion_of_singleton oa.support)

lemma mem_support_bind_return_iff :
  y ∈ (oa >>= λ x, return (f x)).support ↔ ∃ x ∈ oa.support, f x = y :=
by simp only [support_bind_return, set.mem_image, exists_prop]

@[simp] lemma support_bind_return_id : (oa >>= return).support = oa.support :=
(support_bind_return oa id).trans (set.image_id oa.support)

variables [decidable oa]

@[simp] lemma fin_support_bind_return [decidable_eq β] :
  (oa >>= λ a, return (f a)).fin_support = oa.fin_support.image f :=
by rw [fin_support_eq_iff_support_eq_coe, support_bind_return,
  finset.coe_image, coe_fin_support_eq_support]

lemma mem_fin_support_bind_return_iff [decidable_eq β] :
  y ∈ (oa >>= λ a, return (f a)).fin_support ↔ ∃ x ∈ oa.fin_support, f x = y :=
by simp only [fin_support_bind_return, finset.mem_image]

@[simp] lemma fin_support_bind_return_id [decidable_eq α] :
  (oa >>= return).fin_support = oa.fin_support :=
(fin_support_bind_return oa id).trans finset.image_id

end bind_return

section query_bind

variables (i : spec.ι) (t : spec.domain i) (oa : spec.range i → oracle_comp spec α) (x : α)

lemma support_query_bind : (query i t >>= oa).support = ⋃ u, (oa u).support :=
by simp only [support_bind, set.Union_true]

lemma mem_support_query_bind_iff : x ∈ (query i t >>= oa).support ↔ ∃ t, x ∈ (oa t).support :=
by rw [support_query_bind, set.mem_Union]

variables [decidable_eq α] [∀ u, decidable (oa u)]

lemma fin_support_query_bind : (query i t >>= oa).fin_support =
  finset.bUnion finset.univ (λ u, (oa u).fin_support) :=
by {simp only [fin_support_bind, fin_support_query, finset.top_eq_univ], congr}

lemma mem_fin_support_query_bind_iff :
  x ∈ (query i t >>= oa).fin_support ↔ ∃ t, x ∈ (oa t).fin_support :=
by simp only [fin_support_query_bind, finset.mem_bUnion, finset.mem_univ, exists_true_left]

end query_bind

section map

variables (oa : oracle_comp spec α) (f : α → β)  (y : β)

@[simp] lemma support_map : (f <$> oa).support = f '' oa.support :=
support_bind_return oa f

lemma mem_support_map_iff : y ∈ (f <$> oa).support ↔ ∃ x ∈ oa.support, f x = y :=
mem_support_bind_return_iff oa f y

variables [decidable_eq β] [decidable oa]

@[simp] lemma fin_support_map : (f <$> oa).fin_support = oa.fin_support.image f :=
by rw [fin_support_eq_iff_support_eq_coe, finset.coe_image,
  support_map, coe_fin_support_eq_support]

lemma mem_fin_support_map_iff : y ∈ (f <$> oa).fin_support ↔ ∃ x ∈ oa.fin_support, f x = y :=
by rw [fin_support_map, finset.mem_image]

end map

section map_return

variables (a : α) (f : α → β) (y : β)

lemma support_map_return : (f <$> (return a : oracle_comp spec α)).support = {f a} :=
by simp only [support_map, support_return, set.image_singleton]

lemma mem_support_map_return_iff : y ∈ (f <$> (return a : oracle_comp spec α)).support ↔ y = f a :=
by simp only [support_map, support_return, set.image_singleton, set.mem_singleton_iff]

variables [decidable_eq α] [decidable_eq β]

lemma fin_support_map_return :
  (f <$> (return a : oracle_comp spec α)).fin_support = {f a} :=
by simp only [fin_support_map, fin_support_return, finset.image_singleton]

lemma mem_fin_support_map_return_iff :
  y ∈ (f <$> (return a : oracle_comp spec α)).support ↔ y = f a :=
by simp only [support_map, support_return, set.image_singleton, set.mem_singleton_iff]

end map_return

section map_bind

variables (oa : oracle_comp spec α) (ob : α → oracle_comp spec β) (g : β → γ) (z : γ)

@[simp] lemma support_map_bind : (g <$> (oa >>= ob)).support =
  ⋃ a ∈ oa.support, g '' (ob a).support :=
by simp_rw [support_map, support_bind, set.image_Union]

lemma mem_support_map_bind_iff : z ∈ (g <$> (oa >>= ob)).support ↔
  ∃ x ∈ oa.support, ∃ y ∈ (ob x).support, g y = z :=
by simp only [support_map_bind, set.mem_Union, set.mem_image, exists_prop]

variables [decidable_eq γ] [decidable oa] [∀ x, decidable (ob x)]

@[simp] lemma fin_support_map_bind : (g <$> (oa >>= ob)).fin_support =
  @finset.bUnion α γ (decidable_eq_of_decidable (g <$> (oa >>= ob)))
    oa.fin_support (λ a, (ob a).fin_support.image g) :=
by simp_rw [fin_support_eq_iff_support_eq_coe, finset.coe_bUnion, finset.coe_image,
  coe_fin_support_eq_support, support_map_bind]

lemma mem_fin_support_map_bind_iff : z ∈ (g <$> (oa >>= ob)).fin_support ↔
  ∃ x ∈ oa.fin_support, ∃ y ∈ (ob x).fin_support, g y = z :=
by simp only [fin_support_map_bind, finset.mem_bUnion, finset.mem_image]

end map_bind

section bind_map

variables (oa : oracle_comp spec α) (f : α → β) (oc : β → oracle_comp spec γ) (z : γ)

lemma support_bind_map : ((f <$> oa) >>= oc).support =
  ⋃ x ∈ oa.support, (oc (f x)).support :=
by simp only [support_bind, support_map, set.mem_image,
  set.Union_exists, set.bUnion_and', set.Union_Union_eq_right]

lemma mem_support_bind_map_iff : z ∈ ((f <$> oa) >>= oc).support ↔
  ∃ x ∈ oa.support, z ∈ (oc (f x)).support :=
by simp only [support_bind, set.mem_Union, support_map, set.mem_image,
  set.Union_exists, set.bUnion_and', set.Union_Union_eq_right]

variables [decidable_eq β] [decidable oa] [∀ y, decidable (oc y)]

@[simp] lemma fin_support_bind_map : ((f <$> oa) >>= oc).fin_support = @finset.bUnion α γ
  (decidable_eq_of_decidable ((f <$> oa) >>= oc)) oa.fin_support (λ a, (oc (f a)).fin_support) :=
by simp only [finset.image_bUnion, fin_support_bind, fin_support_map]

lemma mem_fin_support_bind_map_iff : z ∈ ((f <$> oa) >>= oc).fin_support ↔
  ∃ x ∈ oa.fin_support, z ∈ (oc (f x)).fin_support :=
by simp only [fin_support_bind_map, finset.mem_bUnion]

end bind_map

-- TODO: This doesn't really belong in this file
@[simp] lemma support_bind_ite (oa : oracle_comp spec α) (p : α → Prop) [decidable_pred p]
  (f g : α → β) : (oa >>= λ a, return (if p a then f a else g a)).support =
  (f '' {x ∈ oa.support | p x}) ∪ (g '' {x ∈ oa.support | ¬ p x}) :=
begin
  refine set.ext (λ x, _),
  simp only [mem_support_bind_return_iff, set.mem_union,
    set.mem_image, exists_prop, set.mem_sep_iff],
  refine ⟨λ h, _, λ h, _⟩,
  { obtain ⟨x, hx⟩ := h,
    by_cases hpx : p x,
    { rw [if_pos hpx] at hx,
      exact or.inl ⟨x, ⟨hx.1, hpx⟩, hx.2⟩ },
    { rw [if_neg hpx] at hx,
      exact or.inr ⟨x, ⟨hx.1, hpx⟩, hx.2⟩ } },
  { cases h with h h,
    { obtain ⟨x, ⟨hx, hx'⟩, rfl⟩ := h,
      exact ⟨x, hx, if_pos hx'⟩ },
    { obtain ⟨x, ⟨hx, hx'⟩, rfl⟩ := h,
      exact ⟨x, hx, if_neg hx'⟩ } }
end

@[simp] lemma fin_support_bind_ite [decidable_eq β] (oa : oracle_comp spec α) [oa.decidable]
  (p : α → Prop) [decidable_pred p] (f : α → β) (g : α → β) :
  (oa >>= λ a, return (if p a then f a else g a)).fin_support =
    ((oa.fin_support.filter p).image f) ∪ ((oa.fin_support.filter (not ∘ p)).image g) :=
by simp only [fin_support_eq_iff_support_eq_coe, support_bind_ite, finset.coe_union,
  finset.coe_image, finset.coe_filter, coe_fin_support_eq_support]

end oracle_comp


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

! This file was ported from Lean 3 source module order.atoms.finite
! leanprover-community/mathlib commit 327c3c0d9232d80e250dc8f65e7835b82b266ea5
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.Data.Set.Finite
import Mathbin.Order.Atoms

/-!
# Atoms, Coatoms, Simple Lattices, and Finiteness

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

This module contains some results on atoms and simple lattices in the finite context.

## Main results
  * `finite.to_is_atomic`, `finite.to_is_coatomic`: Finite partial orders with bottom resp. top
    are atomic resp. coatomic.

-/

variable {α β : Type _}

namespace IsSimpleOrder

section DecidableEq

/- It is important that `is_simple_order` is the last type-class argument of this instance,
so that type-class inference fails quickly if it doesn't apply. -/
instance (priority := 200) {α} [DecidableEq α] [LE α] [BoundedOrder α] [IsSimpleOrder α] :
    Fintype α :=
  Fintype.ofEquiv Bool equivBool.symm

end DecidableEq

end IsSimpleOrder

namespace Fintype

namespace IsSimpleOrder

variable [PartialOrder α] [BoundedOrder α] [IsSimpleOrder α] [DecidableEq α]

/- warning: fintype.is_simple_order.univ -> Fintype.IsSimpleOrder.univ is a dubious translation:
lean 3 declaration is
  forall {α : Type.{u1}} [_inst_1 : PartialOrder.{u1} α] [_inst_2 : BoundedOrder.{u1} α (Preorder.toLE.{u1} α (PartialOrder.toPreorder.{u1} α _inst_1))] [_inst_3 : IsSimpleOrder.{u1} α (Preorder.toLE.{u1} α (PartialOrder.toPreorder.{u1} α _inst_1)) _inst_2] [_inst_4 : DecidableEq.{succ u1} α], Eq.{succ u1} (Finset.{u1} α) (Finset.univ.{u1} α (IsSimpleOrder.fintype.{u1} α (fun (a : α) (b : α) => _inst_4 a b) (Preorder.toLE.{u1} α (PartialOrder.toPreorder.{u1} α _inst_1)) _inst_2 _inst_3)) (Insert.insert.{u1, u1} α (Finset.{u1} α) (Finset.hasInsert.{u1} α (fun (a : α) (b : α) => _inst_4 a b)) (Top.top.{u1} α (OrderTop.toHasTop.{u1} α (Preorder.toLE.{u1} α (PartialOrder.toPreorder.{u1} α _inst_1)) (BoundedOrder.toOrderTop.{u1} α (Preorder.toLE.{u1} α (PartialOrder.toPreorder.{u1} α _inst_1)) _inst_2))) (Singleton.singleton.{u1, u1} α (Finset.{u1} α) (Finset.hasSingleton.{u1} α) (Bot.bot.{u1} α (OrderBot.toHasBot.{u1} α (Preorder.toLE.{u1} α (PartialOrder.toPreorder.{u1} α _inst_1)) (BoundedOrder.toOrderBot.{u1} α (Preorder.toLE.{u1} α (PartialOrder.toPreorder.{u1} α _inst_1)) _inst_2)))))
but is expected to have type
  forall {α : Type.{u1}} [_inst_1 : PartialOrder.{u1} α] [_inst_2 : BoundedOrder.{u1} α (Preorder.toLE.{u1} α (PartialOrder.toPreorder.{u1} α _inst_1))] [_inst_3 : IsSimpleOrder.{u1} α (Preorder.toLE.{u1} α (PartialOrder.toPreorder.{u1} α _inst_1)) _inst_2] [_inst_4 : DecidableEq.{succ u1} α], Eq.{succ u1} (Finset.{u1} α) (Finset.univ.{u1} α (IsSimpleOrder.instFintype.{u1} α (fun (a : α) (b : α) => _inst_4 a b) (Preorder.toLE.{u1} α (PartialOrder.toPreorder.{u1} α _inst_1)) _inst_2 _inst_3)) (Insert.insert.{u1, u1} α (Finset.{u1} α) (Finset.instInsertFinset.{u1} α (fun (a : α) (b : α) => _inst_4 a b)) (Top.top.{u1} α (OrderTop.toTop.{u1} α (Preorder.toLE.{u1} α (PartialOrder.toPreorder.{u1} α _inst_1)) (BoundedOrder.toOrderTop.{u1} α (Preorder.toLE.{u1} α (PartialOrder.toPreorder.{u1} α _inst_1)) _inst_2))) (Singleton.singleton.{u1, u1} α (Finset.{u1} α) (Finset.instSingletonFinset.{u1} α) (Bot.bot.{u1} α (OrderBot.toBot.{u1} α (Preorder.toLE.{u1} α (PartialOrder.toPreorder.{u1} α _inst_1)) (BoundedOrder.toOrderBot.{u1} α (Preorder.toLE.{u1} α (PartialOrder.toPreorder.{u1} α _inst_1)) _inst_2)))))
Case conversion may be inaccurate. Consider using '#align fintype.is_simple_order.univ Fintype.IsSimpleOrder.univₓ'. -/
theorem univ : (Finset.univ : Finset α) = {⊤, ⊥} :=
  by
  change Finset.map _ (Finset.univ : Finset Bool) = _
  rw [Fintype.univ_bool]
  simp only [Finset.map_insert, Function.Embedding.coeFn_mk, Finset.map_singleton]
  rfl
#align fintype.is_simple_order.univ Fintype.IsSimpleOrder.univ

#print Fintype.IsSimpleOrder.card /-
theorem card : Fintype.card α = 2 :=
  (Fintype.ofEquiv_card _).trans Fintype.card_bool
#align fintype.is_simple_order.card Fintype.IsSimpleOrder.card
-/

end IsSimpleOrder

end Fintype

namespace Bool

instance : IsSimpleOrder Bool :=
  ⟨fun a =>
    by
    rw [← Finset.mem_singleton, or_comm, ← Finset.mem_insert, top_eq_true, bot_eq_false, ←
      Fintype.univ_bool]
    apply Finset.mem_univ⟩

end Bool

section Fintype

open Finset

#print Finite.to_isCoatomic /-
-- see Note [lower instance priority]
instance (priority := 100) Finite.to_isCoatomic [PartialOrder α] [OrderTop α] [Finite α] :
    IsCoatomic α :=
  by
  refine' IsCoatomic.mk fun b => or_iff_not_imp_left.2 fun ht => _
  obtain ⟨c, hc, hmax⟩ :=
    Set.Finite.exists_maximal_wrt id { x : α | b ≤ x ∧ x ≠ ⊤ } (Set.toFinite _) ⟨b, le_rfl, ht⟩
  refine' ⟨c, ⟨hc.2, fun y hcy => _⟩, hc.1⟩
  by_contra hyt
  obtain rfl : c = y := hmax y ⟨hc.1.trans hcy.le, hyt⟩ hcy.le
  exact (lt_self_iff_false _).mp hcy
#align finite.to_is_coatomic Finite.to_isCoatomic
-/

#print Finite.to_isAtomic /-
-- see Note [lower instance priority]
instance (priority := 100) Finite.to_isAtomic [PartialOrder α] [OrderBot α] [Finite α] :
    IsAtomic α :=
  isCoatomic_dual_iff_isAtomic.mp Finite.to_isCoatomic
#align finite.to_is_atomic Finite.to_isAtomic
-/

end Fintype


/-
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.BddLat
import order.category.DistLat

/-!
# The category of bounded distributive lattices

This defines `BddDistLat`, the category of bounded distributive lattices.

Note that this category is sometimes called [`DistLat`](https://ncatlab.org/nlab/show/DistLat) when
being a lattice is understood to entail having a bottom and a top element.
-/

universes u

open category_theory

/-- The category of bounded distributive lattices with bounded lattice morphisms. -/
structure BddDistLat :=
(to_DistLat : DistLat)
[is_bounded_order : bounded_order to_DistLat]

namespace BddDistLat

instance : has_coe_to_sort BddDistLat Type* := ⟨λ X, X.to_DistLat⟩
instance (X : BddDistLat) : distrib_lattice X := X.to_DistLat.str

attribute [instance] BddDistLat.is_bounded_order

/-- Construct a bundled `BddDistLat` from a `bounded_order` `distrib_lattice`. -/
def of (α : Type*) [distrib_lattice α] [bounded_order α] : BddDistLat := ⟨⟨α⟩⟩

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

instance : inhabited BddDistLat := ⟨of punit⟩

/-- Turn a `BddDistLat` into a `BddLat` by forgetting it is distributive. -/
def to_BddLat (X : BddDistLat) : BddLat := BddLat.of X

@[simp] lemma coe_to_BddLat (X : BddDistLat) : ↥X.to_BddLat = ↥X := rfl

instance : large_category.{u} BddDistLat := induced_category.category to_BddLat

instance : concrete_category BddDistLat :=
induced_category.concrete_category to_BddLat

instance has_forget_to_DistLat : has_forget₂ BddDistLat DistLat :=
{ forget₂ := { obj := λ X, ⟨X⟩, map := λ X Y, bounded_lattice_hom.to_lattice_hom } }

instance has_forget_to_BddLat : has_forget₂ BddDistLat BddLat :=
induced_category.has_forget₂ to_BddLat

lemma forget_BddLat_Lat_eq_forget_DistLat_Lat :
  forget₂ BddDistLat BddLat ⋙ forget₂ BddLat Lat =
    forget₂ BddDistLat DistLat ⋙ forget₂ DistLat Lat := rfl

/-- Constructs an equivalence between bounded distributive lattices from an order isomorphism
between them. -/
@[simps] def iso.mk {α β : BddDistLat.{u}} (e : α ≃o β) : α ≅ β :=
{ hom := (e : bounded_lattice_hom α β),
  inv := (e.symm : bounded_lattice_hom β α),
  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 : BddDistLat ⥤ BddDistLat :=
{ obj := λ X, of Xᵒᵈ, map := λ X Y, bounded_lattice_hom.dual }

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

end BddDistLat

lemma BddDistLat_dual_comp_forget_to_DistLat :
  BddDistLat.dual ⋙ forget₂ BddDistLat DistLat =
    forget₂ BddDistLat DistLat ⋙ DistLat.dual := rfl


import main

open_locale classical

-- Example 3: A candidate x defeats a candidate y in P
-- just in case the margin of x over y is (i) positive and
-- (ii) greater than the weakest margin in each majority cycle containing x and y.
def split_cycle_CCR {V X : Type} : CCR V X :=
    λ (P : Prof V X) (x y : X), ∀ [f: fintype V],
    @margin_pos V X f P x y ∧
    ¬ (∃ (c : list X), x ∈ c ∧ y ∈ c ∧
    cycle (λ a b, @margin V X f P x y ≤ @margin V X f P a b) c)

-- Example 4
def split_cycle_VCCR : VCCR := λ V X, split_cycle_CCR

/-def split_cycle_VCCR : VCCR :=
    λ V X (P : Prof V X) (x y : X), ∀ [f : fintype V], @margin_pos V X f P x y ∧ ¬ (∃ (c : list X), x ∈ c ∧ y ∈ c ∧ cycle (λ a b, @margin V X f P x y <= @margin V X f P a b) c)
-/

def split_cycle_VCCR' : VCCR :=
    λ V X (P : Prof V X) (x y : X), ∀ [f : fintype V], @margin_pos V X f P x y ∧ ¬ (∃ (c : list X) (e : c ≠ list.nil), c.nodup ∧ c.nth_le 0 (list.length_pos_of_ne_nil e) = y ∧ c.last e = x ∧ list.chain' (λ a b, @margin V X f P x y <= @margin V X f P a b ) c)

-- Example 5: The Split Cycle voting method is
-- the induced VSCC from the Split Cycle VCCR
def split_cycle : VSCC := max_el_VSCC split_cycle_VCCR

variables {V X : Type}

lemma split_to_margin [fintype V] (P : Prof V X) (x y : X) : split_cycle_VCCR V X P x y → margin_pos P x y :=
begin
    unfold split_cycle_VCCR,
    unfold margin_pos,
    intro p,
    cases p with p_left p_right,
    exact p_left,
end

lemma split_cycle_to_margin_cycle [fintype V] (c : list X) (P : Prof V X) : cycle (split_cycle_VCCR V X P) c → cycle (margin_pos P) c :=
begin
    intro chain,
    unfold cycle at chain,
    cases chain with witness chain,
    use witness,
    refine list.chain_of_chain_map id _ _,
    exact (split_cycle_VCCR V X P),
    intros a b s,
    exact and.left s,
    simp,
    exact chain,
end

lemma nonempty_ico {X : Type} (c : list X) (e : 0 < c.length) : (finset.Ico 0 c.length).nonempty  :=
begin
    fconstructor,
    use 0,
    simp at *,
    omega,
end

lemma lemma1 (x : ℕ) (y : ℕ) : x > 1 →  y < x - 1 → y.succ < x := by omega
lemma lemma2 (x : ℕ) (y : ℕ) : x > 1 →  y.succ < x → y < x - 1 := by omega

lemma split_cycle_VCCR_asymmetric [fintype V] (P : Prof V X) : asymmetric (split_cycle_VCCR V X P) :=
begin
    intros a b,
    unfold split_cycle_VCCR,
    unfold split_cycle_CCR,
    intro w,
    cases w with m _,
    push_neg,
    use _inst_1,
    intro m2,
    unfold margin_pos at *,
    rw margin_antisymmetric at m,
    exfalso,
    rw lt_neg at m,
    rw neg_zero at m,
    exact (not_lt_of_lt m) m2,
end

lemma split_cycle_VCCR_acyclic [fintype V] (P : Prof V X) : acyclic (split_cycle_VCCR V X P) :=
begin
    intros c a,
    have cy := a,
    cases a with e a,
    have f := nonempty_ico c (list.length_pos_of_ne_nil e),
    have b := split_cycle_to_margin_cycle c P cy,
    have x := finset.exists_min_image (finset.Ico 0 c.length) (λ x, (margin P)
        (c.nth_le (x % c.length) (nat.mod_lt x (list.length_pos_of_ne_nil e)))
        (c.nth_le ((x+1) % c.length) (nat.mod_lt (x+1) (list.length_pos_of_ne_nil e)))) f,
    cases x with mini_idx mini_req,
    cases mini_req with bounds mini_req,
    simp at bounds,
    let mini := (c.nth_le mini_idx bounds),
    have mini_mem := list.nth_le_mem c mini_idx bounds,
    have defeats := dominates_of_cycle_index c (split_cycle_VCCR V X P) cy mini_idx bounds,
    cases defeats with defeated defeats,
    simp at mini_req,
    contrapose defeats,
    push_neg,
    use c,
    use mini_mem,
    split,
    exact list.nth_le_mem c ((mini_idx + 1) % c.length) (nat.mod_lt (mini_idx + 1) (list.length_pos_of_ne_nil e)),
    unfold cycle,
    use e,
    rw list.chain_iff_nth_le,
    split,
    intro h,
    specialize mini_req (c.length - 1),
    have o : ∀ (n : ℕ), (0 < n) → n - 1 < n := by omega,
    specialize mini_req (o c.length h),
    have cal : (c.length-1) % c.length = c.length-1,
    apply nat.mod_eq_of_lt,
    exact o c.length h,
    simp_rw cal at mini_req,
    have cal : (c.length - 1 + 1) % c.length = 0,
    rw succ_pred h,
    exact nat.mod_self c.length,
    simp_rw cal at mini_req,
    rw ←list.last_eq_nth_le c e at mini_req,
    have test : (margin P (c.nth_le (mini_idx % c.length) (mini_idx.mod_lt (list.length_pos_of_ne_nil e))) (c.nth_le ((mini_idx + 1) % c.length) ((mini_idx + 1).mod_lt (list.length_pos_of_ne_nil e))) ≤ margin P (c.last e) (c.nth_le 0 (eq.rec ((c.length - 1 + 1).mod_lt (list.length_pos_of_ne_nil e)) cal))) = (margin P (c.nth_le mini_idx bounds) (c.nth_le ((mini_idx + 1) % c.length) ((mini_idx + 1).mod_lt (length_cycle_pos cy))) ≤ margin P (c.last e) (c.nth_le 0 h)),
    congr,
    exact nat.mod_eq_of_lt bounds,
    rw ←test,
    exact mini_req,

    intros i h,
    specialize mini_req i,
    specialize mini_req (nat.lt_of_lt_pred h),
    simp_rw (nat.mod_eq_of_lt bounds) at mini_req,
    simp_rw (nat.mod_eq_of_lt (nat.lt_of_lt_pred h)) at mini_req,
    have o : ∀ i n, i < n - 1 → 0 < n → (i + 1) < n := by omega,
    simp_rw (nat.mod_eq_of_lt (o i c.length h (list.length_pos_of_ne_nil e))) at mini_req,
    exact mini_req,
end

lemma forall_take_while (l : list X) (P) : ∀ a ∈ (l.take_while P), P a :=
begin
    intro a,
    intro a_mem,
    induction l,
    obviously,

    change a ∈ if (P l_hd) then (l_hd :: list.take_while P l_tl) else list.nil at a_mem,
    by_cases (P l_hd),
    have i : ¬ (P l_hd) → list.nil = (l_hd :: list.take_while P l_tl),
    intro contr,
    exfalso,
    exact contr h,
    have test := ite_eq_left_iff.mpr i,
    rw test at a_mem,
    rw list.mem_cons_iff a l_hd (list.take_while P l_tl) at a_mem,
    cases a_mem,
    rw ←a_mem at h,
    exact h,
    exact l_ih a_mem,

    have i : (P l_hd) → (l_hd :: list.take_while P l_tl) = list.nil,
    intro contr,
    exfalso,
    exact h contr,
    have test := ite_eq_right_iff.mpr i,
    rw test at a_mem,
    exfalso,
    exact (list.not_mem_nil a) a_mem,
end

lemma nodup_of_nodup_take_while (X : Type) (l : list X) (P : X → Prop): l.nodup → (l.take_while P).nodup :=
begin
    intro a,
    have b := list.take_while_append_drop P l,
    refine list.nodup_of_nodup_append_left _,
    exact list.drop_while P l,
    rw b,
    exact a,
end

lemma rotate'_ne_nil_of_ne_nil {l : list X} {n : ℕ} : l ≠ list.nil → l.rotate' n ≠ list.nil :=
begin
    intro e,
    apply list.ne_nil_of_length_pos,
    rw list.length_rotate',
    apply list.length_pos_of_ne_nil,
    exact e,
end

theorem split_cycle_definitions : split_cycle_VCCR = split_cycle_VCCR' :=
begin
    ext1 V, ext1 X, ext1 P, ext1 x, ext1 y,
    unfold split_cycle_VCCR, unfold split_cycle_VCCR', unfold split_cycle_CCR,
    simp,
    split,
    intro permissive,
    introI _inst_1,
    split,
    cases permissive with margincond permissive,
    exact margincond,
    intro l,
    cases permissive with margincond permissive,
    specialize permissive l,
    intro nodup,
    intro ne_nil,
    by_contradiction,
    push_neg at h,
    cases h with first h,
    cases h with last h,
    have x_mem : x ∈ l,
    rw ←last,
    apply list.last_mem,
    specialize permissive x_mem,
    have y_mem : y ∈ l,
    rw ← first,
    apply list.nth_le_mem,
    specialize permissive y_mem,
    unfold cycle at permissive,
    push_neg at permissive,
    specialize permissive ne_nil,
    contrapose permissive,
    push_neg,
    rw list.chain_iff_nth_le,
    split,
        {intro h,
        rw last,
        rw first,},

        {intros i e,
        rw list.chain'_iff_nth_le at h,
        specialize h i,
        specialize h e,
        exact h,},

    intro restrictive,
    introI _inst_1,
    cases restrictive with margincond restrictive,
    use margincond,
    intros c x_mem y_mem ne_nil,
    have cy := ne_nil,
    cases ne_nil with ne_nil unused,
    let l₂ := c.rotate' (c.index_of y),
    let l₃ := l₂.take (l₂.index_of x + 1),
    let l := to_path l₃,

    specialize restrictive l,
    specialize restrictive (to_path_nodup l₃),

    have ne_nil2 : l ≠ list.nil,
        {by_contradiction,
        push_neg at h,
        have c_nil := (rotate'_eq_nil_iff X c (list.index_of y c)).mp,
        have l₃_nil : l₃ = list.nil := (to_path_eq_nil_iff l₃).mp h,
        have test := list.length_take (list.index_of x l₂ + 1) l₂,
        rw (list.length_eq_zero).mpr l₃_nil at test,
        have test2 := (min_choice (list.index_of x l₂ + 1) l₂.length),
        rw ←test at test2,
        cases test2,
        change 0 = (list.index_of x l₂).succ at test2,
        have test2 := eq.symm test2,
        exact (nat.succ_ne_zero (list.index_of x l₂)) test2,

        rw list.length_rotate' c (list.index_of y c) at test2,
        have test2 := eq.symm test2,
        exact ne_nil (list.length_eq_zero.mp test2),},

    specialize restrictive ne_nil2,
    contrapose restrictive,
    simp at *,
    split,
        {rw to_path_first_elem,
        rw list.nth_le_take',
        change (c.rotate' (list.index_of y c)).nth_le 0 _ = y,
        simp_rw ←list.rotate_eq_rotate',
        simp [list.rotate],
        rw list.nth_le_append,
        rw list.nth_le_drop',
        simp_rw nat.add_zero,
        simp_rw nat.mod_eq_of_lt (list.index_of_lt_length.mpr y_mem),
        refine list.index_of_nth_le
  (eq.rec
     (eq.rec (nat.add_lt_of_lt_sub_left (list.length_drop (list.index_of y c % list.length c) c ▸ _))
        (list.index_of y c % list.length c).add_zero)
     (nat.mod_eq_of_lt (list.index_of_lt_length.mpr y_mem))),

        rw list.length_drop,
        have o : ∀ (a b : ℕ), a < b → 0 < b - a := by omega,
        exact o (list.index_of y c % c.length) c.length (nat.mod_lt (list.index_of y c) (list.length_pos_of_ne_nil ne_nil)),
        exact (not_iff_not_of_iff (to_path_eq_nil_iff l₃)).mp ne_nil2,},

    split,
        {rw to_path_last_elem,
        rw list.last_eq_nth_le,
        rw list.nth_le_take',
        simp_rw list.length_take,

        have leq : (list.index_of x l₂ + 1) ≤ l₂.length,
        apply nat.lt_iff_add_one_le.mp,
        apply list.index_of_lt_length.mpr,
        change x ∈ c.rotate' (list.index_of y c),
        simp_rw ←list.rotate_eq_rotate',
        apply list.mem_rotate.mpr,
        exact x_mem,

        simp_rw min_eq_left leq,
        simp,
        exact (not_iff_not_of_iff (to_path_eq_nil_iff l₃)).mp ne_nil2,},

    apply to_path_chain'_of_chain',

    have l2_chain := rotate'_cycle_of_cycle ⟨ne_nil, unused⟩,
    cases l2_chain with _ l2_chain,

    exact chain'_take_of_chain (rotate'_ne_nil_of_ne_nil ne_nil) l2_chain,
end

lemma not_defeat_self [fintype V] (x : X) (P : Prof V X) : ¬ split_cycle_VCCR V X P x x :=
begin
    unfold split_cycle_VCCR,
    unfold split_cycle_CCR,
    push_neg,
    use _inst_1,
    intro a,
    exfalso,
    unfold margin_pos at a,
    rw self_margin_zero x P at a,
    linarith,
end


import basic
open IncidencePlane

noncomputable theory
open_locale classical

variables {Ω : Type} [IncidencePlane Ω]
variables {A B C P Q R : Ω}
variables {ℓ r s t : Line Ω}

lemma distinct_lines_of_point_in_difference
(A : Ω) (h1 : A ∈ r) (h2 : A ∉ s) : r ≠ s := by finish

lemma not_between_of_between : (A * B * C) → ¬ B * A * C :=
begin
  intro h,
  have h' := between_of_collinear (collinear_of_between h),
  unfold xor3 at h',
  tauto,
end

lemma distinct_lines_of_points_in_difference (A : Ω) (h1 : A ∈ r) (h1 : A ∉ s) : r ≠ s:= by finish

lemma same_side_symmetric' : same_side ℓ A B → same_side ℓ B A :=
begin
  unfold same_side,
  intro h,
  rw segments_are_symmetric,
  exact h,
end

lemma same_side_symmetric : same_side ℓ A B ↔ same_side ℓ B A :=
begin
  split;
  exact same_side_symmetric',
end

lemma different_side_symmetric : ¬ same_side ℓ A B ↔ ¬ same_side ℓ B A :=
begin
  exact iff.not same_side_symmetric,
end

lemma collinear_iff_on_line_through (h : A ≠ B) : collinear ({A, B, C} : set Ω) ↔ C ∈ line_through A B :=
begin
split,
{
  intro h1,
  rcases h1 with ⟨ℓ, hℓ⟩,
  simp at hℓ,
  rw ←(incidence h hℓ.1 hℓ.2.1),
  exact hℓ.2.2,
},
{
  intro h1,
  use line_through A B,
  simp [h1],
}
end

lemma not_in_line_of_same_side_left (h : same_side ℓ A B) : A ∉ ℓ :=
begin
  by_contradiction h1,
  unfold same_side at h,
  simp at h,
  have h2 : A ∈ pts(A⬝B) ∩ ℓ,
  {
    split;
    simp [h1],
  },
  finish,
end

lemma not_in_line_of_same_side_right (h : same_side ℓ A B) : B ∉ ℓ :=
begin
  by_contradiction h1,
  unfold same_side at h,
  simp at h,
  have h2 : B ∈ pts(A⬝B) ∩ ℓ,
  {
    split;
    simp [h1],
  },
  finish,
end

lemma ne_of_not_share_point  (hPr : P ∈ r)(hPs : P ∉ s): r ≠ s:=
begin
intro h,
apply hPs,
rw ← h,
exact hPr,
end

lemma line_through_from_and (P Q : Ω) (ℓ : Line Ω) (h1 : P ≠ Q)
(h2 : P ∈ ℓ ∧ Q ∈ ℓ) : ℓ = line_through P Q :=
begin
cases h2 with hP hQ,
exact incidence h1 hP hQ,
end

lemma collinear_of_between'' {A B C : Ω} : (A * B * C) → collinear ({A, B, C} : set Ω) :=
begin
intro h,
cases collinear_of_between h with r hr,
use r,
simp,
exact hr,
end

lemma point_in_line_not_point {P Q: Ω} {r : Line Ω} (hP : P ∈ r) (hQ : Q ∉ r): P ≠ Q :=
begin
  intro h1,
  apply hQ,
  rw ← h1,
  exact hP,
end

lemma exists_point_not_in_line (ℓ : Line Ω) : ∃ (P : Ω), P ∉ ℓ :=
begin
rcases (existence Ω) with ⟨A : Ω, B, C, ⟨h1, h2, h3, h4⟩⟩,
by_cases h: line_through A B = ℓ,
{ use C,
  rw ← h,
  exact h4 },
{ by_cases a: A ∈ ℓ, { use B,
    intro p,
    apply h,
    rw incidence h1 a p },
  { use A }, },
end

lemma same_side_trans_of_noncollinear (hCol : ¬ collinear ({A, C, B} : set Ω)):
    same_side ℓ A B → same_side ℓ B C → same_side ℓ A C :=
begin
  have hAC : A ≠ C,
  {
    intro h,
    apply hCol,
    rw h,
    use line_through B C,
    simp,
  },
-- Suppose l meets A·C (proving by contradiction)
-- By Pasch l meets A·B or l meets B·C
    -- If l meeets A·B then A, B on different sides
    -- IF l meets B·C then B, C on different sides
  intros p q,
  by_contradiction,
  unfold same_side at h,
  have h' : ∃ D , D ∈ pts (A⬝C) ∧ D ∈ ℓ,
  {
    simp,
    by_contra h',
    push_neg at h',
    apply h,
    ext,
    split,
    {
      intro h'',
      simp,
      specialize h' x,
      have h''' : A*x*C,
      {
        finish,
      },
      apply h',
      {
        tauto,
      },
      {
        finish,
      },
    },
    {
      tauto,
    },
},

cases h' with P r,
have c : A ∉ ℓ ∧ B ∉ ℓ ∧ C ∉ ℓ,
{
  repeat {split},
  apply not_in_line_of_same_side_left p,
  apply not_in_line_of_same_side_right p,
  apply not_in_line_of_same_side_right q,
},
simp at r,
have x : A*P*C,
{
  have hPA : P ≠ A,
  {
    intro hc,
    apply c.1,
    rw hc at r,
    exact r.2,
  },
  have hPA : P ≠ C,
  {
    intro hcon,
    apply c.2.2,
    rw hcon at r,
    exact r.2,
  },
  tauto,
},
have a1 : B ∉ line_through A C,
{
  rw ← collinear_iff_on_line_through hAC,
  exact hCol,
},

have fact := pasch a1 c.1 c.2.2 c.2.1 r.2 x,
cases fact,
{
unfold same_side at p,
cases fact.1 with E,
simp [set.eq_empty_iff_forall_not_mem] at p,
replace p := p.2.2 E h_1.2,
apply p,
exact h_1.1,
},
unfold same_side at q,
cases fact.1 with F,
simp [set.eq_empty_iff_forall_not_mem] at q,
rw between_symmetric at h_1,
replace q := q.2.2 F h_1.2,
apply q,
exact h_1.1,
end

lemma auxiliary_point (ℓ : Line Ω) (h : collinear ({A, B, C} : set Ω)) (hA : A ∉ ℓ) (hB : B ∉ ℓ)
  (hC : C ∉ ℓ) (hAB : A ≠ B) (hAC : A ≠ C) (hBC : B ≠ C)  :
  ∃ (D E : Ω), D ∈ ℓ ∧ ¬ E ∈ ℓ ∧ same_side ℓ A E ∧ (D * A * E) ∧
  ¬ collinear ({A, B, E} : set Ω) ∧
  ¬ collinear ({E, C, B} : set Ω) ∧
  ¬ collinear ({A, C, E} : set Ω)  :=
begin
    -- define what a b c line is, m
    set m := line_through A B with hm,

    have hAM: A ∈ m,
    exact line_through_left A B,

    have hBM: B ∈ m,
    exact line_through_right A B,

    have hCM:= (collinear_iff_on_line_through hAB).1 h,

    --l is not m
    have lm := ne_of_not_share_point hAM hA,
    --there is point in l, not in m, D
    have hD := point_in_line_difference (ne.symm lm),
    rcases hD with ⟨D, ⟨hD1, hD2⟩⟩,

    have hDA:= point_in_line_not_point hD1 hA,
    rcases (point_on_ray hDA) with ⟨E, hE⟩,
    use D,
    use E,
    split,
    exact hD1,
    have hDnotE := different_of_between hE,
    repeat {split},
    {
      by_contradiction hEL,
      have hDAE := incidence hDnotE.2.1 hD1 hEL,
      have hDAE2 := collinear_of_between hE,
      cases hDAE2 with n,
      have hhh := incidence hDnotE.2.1 hDAE2_h.1 hDAE2_h.2.2,
      rw ← hhh at hDAE,
      rw ← hDAE at hDAE2_h,
      exact hA hDAE2_h.2.1,
    },
    {
      unfold same_side,
      simp [set.eq_empty_iff_forall_not_mem],
      repeat {split},
      {
        exact hA,
      },
      by_contradiction hEL,
      {
        have hDAE := incidence hDnotE.2.1 hD1 hEL,
        have hDAE2 := collinear_of_between hE,
        cases hDAE2 with n,
        have hhh := incidence hDnotE.2.1 hDAE2_h.1 hDAE2_h.2.2,
        rw ← hhh at hDAE,
        rw ← hDAE at hDAE2_h,
        exact hA hDAE2_h.2.1,
      },
      {
        intros P hP hPL,
        rcases (collinear_of_between hP) with ⟨r, hAr, hPr, hEr⟩,
        rcases (collinear_of_between hE) with ⟨s, hDs, hAs, hEs⟩,
        have hAE : A ≠ E := (different_of_between hE).2.2,
        have hrs := equal_lines_of_contain_two_points hAE hAr hAs hEr hEs,
        subst hrs,
        clear hAs hEs,
        have hPD : P ≠ D,
        {
          intro hc,
          subst hc,
          exact not_between_of_between hE hP,
        },
        have hℓr := equal_lines_of_contain_two_points hPD hPL hPr hD1 hDs,
        rw ←hℓr at hAr,
        contradiction,
      },
    },
    {
      exact hE,
    },
    {
      cases hDnotE with hDnotE1 hDnotE2,
      cases hDnotE2 with hDnotE2 hDnotE3,
      intro o1,
      have j1 : line_through A B = line_through A C,
      {
        exact equal_lines_of_contain_two_points hAC (line_through_left A B) (line_through_left A C) hCM (line_through_right A C),
      },
      have oo4 := (collinear_iff_on_line_through hAB).1 o1,
      have j2 : line_through E A = line_through A B,
      {
        exact equal_lines_of_contain_two_points hDnotE3 (line_through_right E A) (line_through_left A B) (line_through_left E A) oo4,
      },
      rw ← hm at oo4,
      have j3 := collinear_of_between hE,
      cases j3 with j31 j32,
      cases j32 with j32 j33,
      cases j33 with j33 j34,
      have j4 : j31 = m,
      {
        have y1:= equal_lines_of_contain_two_points hDnotE3 j33 (line_through_right E A) j34 (line_through_left E A),
        rw j2 at y1,
        rw ← hm at y1,
        exact y1,
      },
      rw j4 at j32,
      apply hD2,
      exact j32,
    },
    {
      cases hDnotE with hDnotE1 hDnotE2,
      cases hDnotE2 with hDnotE2 hDnotE3,
      intro o1,
      set r := line_through D E with hDEs,

      have j1 : line_through A B = line_through A C,
      {
        exact equal_lines_of_contain_two_points hAC (line_through_left A B) (line_through_left A C) hCM (line_through_right A C),
      },
      have g1 : E ≠ C,
      {
        intro g2,
        rw ← hm at hCM,
        have k1 := collinear_of_between hE,
        cases k1 with k1 k2,
        cases k2 with k2 k3,
        cases k3 with k3 k4,
        have km : k1 = m,
        {
          rw g2 at k4,
          exact equal_lines_of_contain_two_points hAC k3 hAM k4 hCM,
        },
        rw km at k2,
        apply hD2,
        exact k2,
      },
      have oo4 := (collinear_iff_on_line_through g1).1 o1,
      have j2 : line_through E C = line_through B C,
      {
        exact equal_lines_of_contain_two_points hBC oo4 (line_through_left B C) (line_through_right E C) (line_through_right B C),
      },
      rw ← hm at hCM,
      have p3 : line_through B C = m,
      {
        exact equal_lines_of_contain_two_points hBC (line_through_left B C) hBM (line_through_right B C) hCM,
      },
      rw j1 at hm,
      rw j2 at oo4,
      have j3 := collinear_of_between hE,
      cases j3 with j31 j32,
      cases j32 with j32 j33,
      cases j33 with j33 j34,
      have hEm : E ∈ m,
      {
        rw ← p3,
        rw ←  collinear_iff_on_line_through hBC,
        rw collinear_of_equal ({B, C, E} : set Ω) ({E, C, B} : set Ω),
        exact o1,
      },
      have j4 : j31 = m,
      {
        have y1:= equal_lines_of_contain_two_points hDnotE3 j33 (line_through_right E A) j34 (line_through_left E A),
        rw ← j2 at oo4,
        rw y1,
        apply equal_lines_of_contain_two_points hDnotE3,
        {
          simp,
        },
        {
          exact hAM,
        },
        {
          simp,
        },
        {
          exact hEm,
        },
      },
      rw j4 at j32,
      apply hD2,
      exact j32,
    },
    {
      cases hDnotE with hDnotE1 hDnotE2,
      cases hDnotE2 with hDnotE2 hDnotE3,
      intro o1,
      have j1 : line_through A B = line_through A C,
      {
        exact equal_lines_of_contain_two_points hAC (line_through_left A B) (line_through_left A C) hCM (line_through_right A C),
      },
      have oo4 := (collinear_iff_on_line_through hAC).1 o1,
      have j2 : line_through E A = line_through A C,
      {
        exact equal_lines_of_contain_two_points hDnotE3 (line_through_right E A) (line_through_left A C) (line_through_left E A) oo4,
      },
      rw j1 at hm,
      rw ← hm at oo4,

      have j3 := collinear_of_between hE,
      cases j3 with j31 j32,
      cases j32 with j32 j33,
      cases j33 with j33 j34,

      have j4 : j31 = m,
      {
        have y1:= equal_lines_of_contain_two_points hDnotE3 j33 (line_through_right E A) j34 (line_through_left E A),
        rw j2 at y1,
        rw ← hm at y1,
        exact y1,
      },
      rw j4 at j32,
      apply hD2,
      exact j32,

    },
end

lemma same_side_trans_of_collinear (h : collinear ({A, C, B} : set Ω)):
    same_side ℓ A B → same_side ℓ B C → same_side ℓ A C :=
begin
  intros h1 h2,
  -- Create hypotheses to satisfy parameters of lemma auxiliary_point
  have hA : A ∉ ℓ,
  {
    exact not_in_line_of_same_side_left h1,
  },
  have hB : B ∉ ℓ,
  {
    exact not_in_line_of_same_side_left h2,
  },
  have hC : C ∉ ℓ,
  {
    exact not_in_line_of_same_side_right h2,
  },
  by_cases hAC: A = C,
  {
    rw hAC,
    unfold same_side,
    simp,
    exact hC,
  },
  by_cases hAB: A = B,
  {
    rw hAB,
    exact h2,
  },
  by_cases hCB: C = B,
  {
    rw hCB,
    exact h1,
  },
  -- With lemma auxiliary_point: ∃ E , same_side ℓ A E
  -- ACE , EBC , ABE non collinear
  have h3 := auxiliary_point ℓ h hA hC hB hAC hAB hCB,
  rcases h3 with ⟨D, E, ⟨hDL, hEL, hAE, hDAE, hACE, hEBC, hABE⟩⟩,
  -- Rewrite hyptoheses to satisfy parameters of lemma same_side_trans_of_noncollinear
  rw collinear_of_equal ({A, B, E} :set Ω)({E, B, A} :set Ω) at hABE,
  rename hABE hEBA,
  have hEA : same_side ℓ E A := same_side_symmetric.mp hAE,
  -- With lemma same_side_trans_of_noncollinear: same_side ℓ E B
  have hEB := same_side_trans_of_noncollinear hEBA hEA h1,
  -- Rewrite hyptoheses to satisfy parameters of lemma same_side_trans_of_noncollinear
  rw collinear_of_equal ({E, B, C} :set Ω)({E, C, B} :set Ω) at hEBC,
  rename hEBC hECB,
  -- With lemma same_side_trans_of_noncollinear: same_side ℓ E C
  have hEC := same_side_trans_of_noncollinear hECB hEB h2,
  -- With lemma same_side_trans_of_noncollinear, same_side ℓ A C
  exact same_side_trans_of_noncollinear hACE hAE hEC,
end

lemma same_side_trans_general : same_side ℓ A B → same_side ℓ B C → same_side ℓ A C :=
begin
  by_cases h : collinear ({A, C, B} : set Ω),
  {
    apply same_side_trans_of_collinear h,
  },
  {
    apply same_side_trans_of_noncollinear h,
  }
end

lemma at_least_two_classes (ℓ : Line Ω):
      ∃ A B : Ω, (A ∉ ℓ) ∧ (B ∉ ℓ) ∧ (¬ same_side ℓ A B) :=
begin
  cases (exists_point_on_line ℓ) with Q hQ,
  cases (exists_point_not_on_line ℓ) with P hP,
  have hPQ:P ≠ Q,
  {
    intro hQQQQ,
    apply hP,
    rw hQQQQ,
    exact hQ,
  },
  cases (point_on_ray hPQ) with R hPQR,
  have hRRQQ: Q ≠ R,
    {
    have fact:=different_of_between hPQR,
    exact fact.2.2,
    },
  have hR: R ∉ ℓ,
  {
    have hPP: P ∈ line_through Q R,
    {
      rw between_symmetric at hPQR,
      have htmp : line_through Q R = line_through R Q,
      {
        apply equal_lines_of_contain_two_points hRRQQ;
        simp,
      },
      rw htmp,
      exact between_points_share_line_v2 (line_through_left R Q) (line_through_right R Q) hPQR,
    },
    intro hr,
    apply hP,
    rw incidence hRRQQ hQ hr,
    exact hPP,
  },
  use P,
  use R,
  split,
  exact hP,
  split,
  exact hR,
  have hhQ: Q ∈ P⬝R,
  {
    simp,
    right,
    right,
    exact hPQR,
  },
  intro h,
  unfold same_side at h,
  have hQQ:Q ∈ pts (P⬝R) ∩ ℓ,
  {
    split,
    exact hhQ,
    exact hQ,
  },
  exact set.eq_empty_iff_forall_not_mem.mp h Q hQQ,
end

lemma not_on_line_iff_not_collinear  (h2 : A≠ B)(h1: ¬ collinear({A,B,C} : set Ω ))
:  C ∉ line_through A B:=
begin
  exact ( iff.not (collinear_iff_on_line_through h2)).mp h1,
end

lemma at_most_two_classes_of_noncollinear (hA : A ∉ ℓ) (hB : B ∉ ℓ) (hC : C ∉ ℓ)
    (hBneqC : B ≠ C) (hAB: ¬ same_side ℓ A B) (hAC: ¬ same_side ℓ A C)
    (h : ¬ collinear ({A, B, C} : set Ω)) : same_side ℓ B C :=
begin
  --Step 1: First, prove that A is not equal to B and A is not equal to C
  have HAB: A≠B,{
  unfold same_side at hAB,
    intro H,
    rw H at hAB,
    simp at hAB,
    apply hB,
    exact hAB,
  },
  have HAC: A≠C,{
    unfold same_side at hAC,
    intro H,
    rw H at hAC,
    simp at hAC,
    apply hC,
    exact hAC,
  },
--Step 1: Done
--Step 2: Prove that there exists a point D that is both on line ℓ and on line AB such that A*D*B
  have HADB: ∃ (D : Ω), D ∈ ℓ ∧ D ∈ line_through A B ∧ A*D*B,
  {
    unfold same_side at hAB,
    simp at hAB,
    by_contra hc,
    apply hAB,
    push_neg at hc,
    ext,
    split,
    {
      intro H,
      exfalso,
      have h1: x ∈ line_through A B,
      {
        cases H with H hxl,
        simp  at H,
        cases H,
          rw H,
          exact line_through_left A B,
        cases H,
          rw H,
          exact line_through_right A B,
        rw ← collinear_iff_on_line_through HAB,
        have H1:= collinear_of_between H,
        cases H1 with r hr,
        use r,
        simp,
        tauto,
      },
      specialize hc x H.2,
      finish,
    },
    tauto,
    },
    -- D POINT CREATED
  -- Repeat the same process for another point E that should lie on line ℓ and line AC
  have HAEC: ∃ (E : Ω), E ∈ ℓ ∧ E ∈ line_through A C ∧ A*E*C,
  {
    unfold same_side at hAC,
    simp at hAC,
    by_contra hc,
    apply hAC,
    push_neg at hc,
    ext,
    split,
    {
      intro H,
      exfalso,
      have h1: x ∈ line_through A C,
      {
        cases H with H hxl,
        simp  at H,
        cases H,
          rw H,
          exact line_through_left A C,
        cases H,
          rw H,
          exact line_through_right A C,
        rw ← collinear_iff_on_line_through HAC,
        have H1:= collinear_of_between H,
        cases H1 with r hr,
        use r,
        simp,
        tauto,
      },
      specialize hc x H.2,
      finish,
    },
    tauto,
    },

  --BOTH E AND D POINTS HAVE BEEN PROVED

  -- WE NEDE TO SHOW THAT C IS NOT IN BETWEEN A and B
  -- USE LEMMA (not_on_line_iff_not_collinear) STATING THAT IF POINTS A B C ARE NOT COLLINEAR AND A≠B,  THEY CANNOT BE IN THE SAME LINE
  cases HADB with D r,
  {
    cases r with l1 r1,
    {
      cases r1 with l2 r2,
      {
        --PASCH AXIOM
        --MAKE PASCH A HYPOTHESIS AND THEN SOLVE THE TWO CASES
        have w := pasch (not_on_line_iff_not_collinear HAB h) hA hB hC l1 r2,
        unfold same_side,
        cases w,
        {
        --FIRST PASCH CASE
          cases w,
          {
              simp,
              ext,
              split,
              {
                intro H,
                exfalso,
                have x1: x∈ line_through B C,
                {
                    cases H with H hxl,
                    simp at H,
                    cases H,
                      rw H,
                      exact line_through_left B C,
                    cases H,
                      rw H,
                      exact line_through_right B C,
                    rw ← collinear_iff_on_line_through hBneqC,
                    have H1:= collinear_of_between H,
                    cases H1 with r0 hr,
                    use r0,
                    simp,
                    tauto,
                },
                simp at H,
                cases H,
                finish,
              },
              {
                intro H,
                exfalso,

                simp at H,
                cases H,
              },
          },
        },
        {
          --SECOND PASCH CASE
          simp,
              ext,
              split,
              {
                intro H,
                exfalso,
                have x1: x∈ line_through B C,
                {
                    cases H with H hxl,
                    simp at H,
                    cases H,
                      rw H,
                      exact line_through_left B C,
                    cases H,
                      rw H,
                      exact line_through_right B C,
                    rw ← collinear_iff_on_line_through hBneqC,
                    have H1:= collinear_of_between H,
                    cases H1 with r0 hr,
                    use r0,
                    simp,
                    tauto,
                },
                simp at H,
                cases H,
                finish,

              },
              {
                intro H,
                exfalso,

                simp at H,
                cases H,
              },
          },
        },
      },
    },
  -- BOTH PASCH CASES SOLVED AND PROOF COMPLETED
end

lemma at_most_two_classes_of_collinear (hA : A ∉ ℓ) (hB : B ∉ ℓ) (hC : C ∉ ℓ)
    (hBneqC : B ≠ C) (hAB: ¬ same_side ℓ A B) (hAC: ¬ same_side ℓ A C)
    (h : collinear ({A, B, C} : set Ω)) : same_side ℓ B C :=
begin
  -- Create and prove hypotheses to satisfy parameters of lemma auxiliary_point
  by_cases hBneqA: B = A,
  {
    exfalso,
    apply hAB,
    rw hBneqA,
    unfold same_side,
    simp,
    exact hA,
  },
  by_cases hCneqA: C = A,
  {
    exfalso,
    apply hAC,
    rw hCneqA,
    unfold same_side,
    simp,
    exact hA,
  },
  rw collinear_of_equal ({A, B, C} :set Ω)({B, C, A} :set Ω) at h,
  -- Use lemma auxiliary_point
  -- ∃ E , same_side ℓ B E , BCE,EAC,BAE non collinear
  have h1 := auxiliary_point ℓ h hB hC hA hBneqC hBneqA hCneqA,
  rcases h1 with ⟨D, E, ⟨hD, hE, hBE, hDBE, hBCE, hEAC, hBAE⟩⟩,
  -- Create and prove hyptoheses to satisfy parameters of lemma same_side_trans_of_noncollinear
  -- Use lemma same_side_trans_of_noncollinear to prove that ¬ same_side ℓ E A by contradiction
  have hEA : ¬ same_side ℓ E A,
  {
    by_contradiction hEA,
    rw collinear_of_equal ({B, A, E} :set Ω)({A, B, E} :set Ω) at hBAE,
    rename hBAE hABE,
    have hAE : same_side ℓ A E := same_side_symmetric.mp hEA,
    have hEB : same_side ℓ E B := same_side_symmetric.mp hBE,
    have hAB := same_side_trans_of_noncollinear hABE hAE hEB,
    finish,
  },
  have hAE : ¬ same_side ℓ A E := different_side_symmetric.mp hEA,
  have hEneqC: E ≠ C,
  {
    intro hEeqC,
    rw hEeqC at hBCE,
    apply hBCE,
    use line_through B C,
    simp,
  },
  rw collinear_of_equal ({E, A, C} :set Ω)({A, E, C} :set Ω) at hEAC,
  rename hEAC hAEC,
  -- Use lemma at_most_two_classes_of_noncollinear to prove that same_side ℓ E C
  have hEC := at_most_two_classes_of_noncollinear hA hE hC hEneqC hAE hAC hAEC,
  -- Use lemma same_side_trans_of_noncollinear to prove that same_side ℓ B C
  exact same_side_trans_of_noncollinear hBCE hBE hEC,
end

lemma at_most_two_classes_general (hA : A ∉ ℓ) (hB : B ∉ ℓ) (hC : C ∉ ℓ)
    (hBneqC : B ≠ C) (hAB: ¬ same_side ℓ A B) (hAC: ¬ same_side ℓ A C): same_side ℓ B C :=
begin
  by_cases h : collinear ({A, B, C} : set Ω),
  {
    apply at_most_two_classes_of_collinear hA hB hC hBneqC hAB hAC h,
  },
  {
    apply at_most_two_classes_of_noncollinear hA hB hC hBneqC hAB hAC h,
  }
end