/-
Copyright (c) 2017 Johannes Hölzl. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Johannes Hölzl
-/
import logic.relator

/-!
# Quotient types

This module extends the core library's treatment of quotient types (`init.data.quot`).

## Tags

quotient
-/

variables {α : Sort*} {β : Sort*}

namespace setoid

lemma ext {α : Sort*} :
  ∀{s t : setoid α}, (∀a b, @setoid.r α s a b ↔ @setoid.r α t a b) → s = t
| ⟨r, _⟩ ⟨p, _⟩ eq :=
  have r = p, from funext $ assume a, funext $ assume b, propext $ eq a b,
  by subst this

end setoid

namespace quot
variables {ra : α → α → Prop} {rb : β → β → Prop} {φ : quot ra → quot rb → Sort*}
local notation `⟦`:max a `⟧` := quot.mk _ a

instance [inhabited α] : inhabited (quot ra) := ⟨⟦default⟧⟩

instance [subsingleton α] : subsingleton (quot ra) :=
⟨λ x, quot.induction_on x (λ y, quot.ind (λ b, congr_arg _ (subsingleton.elim _ _)))⟩

/-- Recursion on two `quotient` arguments `a` and `b`, result type depends on `⟦a⟧` and `⟦b⟧`. -/
protected def hrec_on₂ (qa : quot ra) (qb : quot rb) (f : Π a b, φ ⟦a⟧ ⟦b⟧)
  (ca : ∀ {b a₁ a₂}, ra a₁ a₂ → f a₁ b == f a₂ b)
  (cb : ∀ {a b₁ b₂}, rb b₁ b₂ → f a b₁ == f a b₂) : φ qa qb :=
quot.hrec_on qa (λ a, quot.hrec_on qb (f a) (λ b₁ b₂ pb, cb pb)) $ λ a₁ a₂ pa,
  quot.induction_on qb $ λ b,
    calc @quot.hrec_on _ _ (φ _) ⟦b⟧ (f a₁) (@cb _)
          == f a₁ b                                     : by simp [heq_self_iff_true]
      ... == f a₂ b                                     : ca pa
      ... == @quot.hrec_on _ _ (φ _) ⟦b⟧ (f a₂) (@cb _) : by simp [heq_self_iff_true]

/-- Map a function `f : α → β` such that `ra x y` implies `rb (f x) (f y)`
to a map `quot ra → quot rb`. -/
protected def map (f : α → β) (h : (ra ⇒ rb) f f) : quot ra → quot rb :=
quot.lift (λ x, ⟦f x⟧) $ assume x y (h₁ : ra x y), quot.sound $ h h₁

/-- If `ra` is a subrelation of `ra'`, then we have a natural map `quot ra → quot ra'`. -/
protected def map_right {ra' : α → α → Prop} (h : ∀a₁ a₂, ra a₁ a₂ → ra' a₁ a₂) :
  quot ra → quot ra' :=
quot.map id h

/-- weaken the relation of a quotient -/
def factor {α : Type*} (r s : α → α → Prop) (h : ∀ x y, r x y → s x y) :
  quot r → quot s :=
quot.lift (quot.mk s) (λ x y rxy, quot.sound (h x y rxy))

lemma factor_mk_eq {α : Type*} (r s : α → α → Prop) (h : ∀ x y, r x y → s x y) :
  factor r s h ∘ quot.mk _ = quot.mk _ := rfl

variables {γ : Sort*} {r : α → α → Prop} {s : β → β → Prop}

/-- **Alias** of `quot.lift_beta`. -/
lemma lift_mk (f : α → γ) (h : ∀ a₁ a₂, r a₁ a₂ → f a₁ = f a₂) (a : α) :
  quot.lift f h (quot.mk r a) = f a := quot.lift_beta f h a

@[simp]
lemma lift_on_mk (a : α) (f : α → γ) (h : ∀ a₁ a₂, r a₁ a₂ → f a₁ = f a₂) :
  quot.lift_on (quot.mk r a) f h = f a := rfl

/-- Descends a function `f : α → β → γ` to quotients of `α` and `β`. -/
attribute [reducible, elab_as_eliminator]
protected def lift₂
  (f : α → β → γ)
  (hr : ∀ a b₁ b₂, s b₁ b₂ → f a b₁ = f a b₂)
  (hs : ∀ a₁ a₂ b, r a₁ a₂ → f a₁ b = f a₂ b)
  (q₁ : quot r) (q₂ : quot s) : γ :=
quot.lift (λ a, quot.lift (f a) (hr a))
(λ a₁ a₂ ha, funext (λ q, quot.induction_on q (λ b, hs a₁ a₂ b ha)))
q₁ q₂

@[simp]
lemma lift₂_mk (f : α → β → γ)
  (hr : ∀ a b₁ b₂, s b₁ b₂ → f a b₁ = f a b₂)
  (hs : ∀ a₁ a₂ b, r a₁ a₂ → f a₁ b = f a₂ b) (a : α) (b : β) :
  quot.lift₂ f hr hs (quot.mk r a) (quot.mk s b) = f a b := rfl

/-- Descends a function `f : α → β → γ` to quotients of `α` and `β` and applies it. -/
attribute [reducible, elab_as_eliminator]
protected def lift_on₂ (p : quot r) (q : quot s) (f : α → β → γ)
  (hr : ∀ a b₁ b₂, s b₁ b₂ → f a b₁ = f a b₂)
  (hs : ∀ a₁ a₂ b, r a₁ a₂ → f a₁ b = f a₂ b) : γ := quot.lift₂ f hr hs p q

@[simp]
lemma lift_on₂_mk (a : α) (b : β) (f : α → β → γ)
  (hr : ∀ a b₁ b₂, s b₁ b₂ → f a b₁ = f a b₂)
  (hs : ∀ a₁ a₂ b, r a₁ a₂ → f a₁ b = f a₂ b) :
  quot.lift_on₂ (quot.mk r a) (quot.mk s b) f hr hs = f a b := rfl

variables {t : γ → γ → Prop}

/-- Descends a function `f : α → β → γ` to quotients of `α` and `β` wih values in a quotient of
`γ`. -/
protected def map₂ (f : α → β → γ)
  (hr : ∀ a b₁ b₂, s b₁ b₂ → t (f a b₁) (f a b₂))
  (hs : ∀ a₁ a₂ b, r a₁ a₂ → t (f a₁ b) (f a₂ b))
  (q₁ : quot r) (q₂ : quot s) : quot t :=
quot.lift₂ (λ a b, quot.mk t $ f a b) (λ a b₁ b₂ hb, quot.sound (hr a b₁ b₂ hb))
(λ a₁ a₂ b ha, quot.sound (hs a₁ a₂ b ha)) q₁ q₂

@[simp]
lemma map₂_mk (f : α → β → γ)
  (hr : ∀ a b₁ b₂, s b₁ b₂ → t (f a b₁) (f a b₂))
  (hs : ∀ a₁ a₂ b, r a₁ a₂ → t (f a₁ b) (f a₂ b))
  (a : α) (b : β) : quot.map₂ f hr hs (quot.mk r a) (quot.mk s b) = quot.mk t (f a b) := rfl

attribute [elab_as_eliminator]
protected lemma induction_on₂
  {δ : quot r → quot s → Prop} (q₁ : quot r) (q₂ : quot s)
  (h : ∀ a b, δ (quot.mk r a) (quot.mk s b)) : δ q₁ q₂ :=
quot.ind (λ a₁, quot.ind (λ a₂, h a₁ a₂) q₂) q₁

attribute [elab_as_eliminator]
protected lemma induction_on₃
  {δ : quot r → quot s → quot t → Prop} (q₁ : quot r) (q₂ : quot s) (q₃ : quot t)
  (h : ∀ a b c, δ (quot.mk r a) (quot.mk s b) (quot.mk t c)) : δ q₁ q₂ q₃ :=
quot.ind (λ a₁, quot.ind (λ a₂, quot.ind (λ a₃, h a₁ a₂ a₃) q₃) q₂) q₁

end quot

namespace quotient
variables [sa : setoid α] [sb : setoid β]
variables {φ : quotient sa → quotient sb → Sort*}

instance [inhabited α] : inhabited (quotient sa) := ⟨⟦default⟧⟩

instance (s : setoid α) [subsingleton α] : subsingleton (quotient s) :=
quot.subsingleton

/-- Induction on two `quotient` arguments `a` and `b`, result type depends on `⟦a⟧` and `⟦b⟧`. -/
protected def hrec_on₂ (qa : quotient sa) (qb : quotient sb) (f : Π a b, φ ⟦a⟧ ⟦b⟧)
  (c : ∀ a₁ b₁ a₂ b₂, a₁ ≈ a₂ → b₁ ≈ b₂ → f a₁ b₁ == f a₂ b₂) : φ qa qb :=
quot.hrec_on₂ qa qb f
  (λ _ _ _ p, c _ _ _ _ p (setoid.refl _))
  (λ _ _ _ p, c _ _ _ _ (setoid.refl _) p)

/-- Map a function `f : α → β` that sends equivalent elements to equivalent elements
to a function `quotient sa → quotient sb`. Useful to define unary operations on quotients. -/
protected def map (f : α → β) (h : ((≈) ⇒ (≈)) f f) : quotient sa → quotient sb :=
quot.map f h

@[simp] lemma map_mk (f : α → β) (h : ((≈) ⇒ (≈)) f f) (x : α) :
  quotient.map f h (⟦x⟧ : quotient sa) = (⟦f x⟧ : quotient sb) :=
rfl

variables {γ : Sort*} [sc : setoid γ]

/-- Map a function `f : α → β → γ` that sends equivalent elements to equivalent elements
to a function `f : quotient sa → quotient sb → quotient sc`.
Useful to define binary operations on quotients. -/
protected def map₂ (f : α → β → γ) (h : ((≈) ⇒ (≈) ⇒ (≈)) f f) :
  quotient sa → quotient sb → quotient sc :=
quotient.lift₂ (λ x y, ⟦f x y⟧) (λ x₁ y₁ x₂ y₂ h₁ h₂, quot.sound $ h h₁ h₂)

@[simp] lemma map₂_mk (f : α → β → γ) (h : ((≈) ⇒ (≈) ⇒ (≈)) f f) (x : α) (y : β) :
  quotient.map₂ f h (⟦x⟧ : quotient sa) (⟦y⟧ : quotient sb) = (⟦f x y⟧ : quotient sc) := rfl

end quotient

lemma quot.eq {α : Type*} {r : α → α → Prop} {x y : α} :
  quot.mk r x = quot.mk r y ↔ eqv_gen r x y :=
⟨quot.exact r, quot.eqv_gen_sound⟩

@[simp] theorem quotient.eq [r : setoid α] {x y : α} : ⟦x⟧ = ⟦y⟧ ↔ x ≈ y :=
⟨quotient.exact, quotient.sound⟩

theorem forall_quotient_iff {α : Type*} [r : setoid α] {p : quotient r → Prop} :
  (∀a:quotient r, p a) ↔ (∀a:α, p ⟦a⟧) :=
⟨assume h x, h _, assume h a, a.induction_on h⟩

@[simp] lemma quotient.lift_mk [s : setoid α] (f : α → β) (h : ∀ (a b : α), a ≈ b → f a = f b)
  (x : α) :
  quotient.lift f h (quotient.mk x) = f x := rfl

@[simp] lemma quotient.lift₂_mk {α : Sort*} {β : Sort*} {γ : Sort*} [setoid α] [setoid β]
  (f : α → β → γ)
  (h : ∀ (a₁ : α) (a₂ : β) (b₁ : α) (b₂ : β), a₁ ≈ b₁ → a₂ ≈ b₂ → f a₁ a₂ = f b₁ b₂)
  (a : α) (b : β) :
  quotient.lift₂ f h (quotient.mk a) (quotient.mk b) = f a b := rfl

@[simp] lemma quotient.lift_on_mk [s : setoid α] (f : α → β) (h : ∀ (a b : α), a ≈ b → f a = f b)
  (x : α) :
  quotient.lift_on (quotient.mk x) f h = f x := rfl

@[simp] theorem quotient.lift_on₂_mk {α : Sort*} {β : Sort*} [setoid α] (f : α → α → β)
  (h : ∀ (a₁ a₂ b₁ b₂ : α), a₁ ≈ b₁ → a₂ ≈ b₂ → f a₁ a₂ = f b₁ b₂) (x y : α) :
  quotient.lift_on₂ (quotient.mk x) (quotient.mk y) f h = f x y := rfl

/-- `quot.mk r` is a surjective function. -/
lemma surjective_quot_mk (r : α → α → Prop) : function.surjective (quot.mk r) :=
quot.exists_rep

/-- `quotient.mk` is a surjective function. -/
lemma surjective_quotient_mk (α : Sort*) [s : setoid α] :
  function.surjective (quotient.mk : α → quotient s) :=
quot.exists_rep

/-- Choose an element of the equivalence class using the axiom of choice.
  Sound but noncomputable. -/
noncomputable def quot.out {r : α → α → Prop} (q : quot r) : α :=
classical.some (quot.exists_rep q)

/-- Unwrap the VM representation of a quotient to obtain an element of the equivalence class.
  Computable but unsound. -/
meta def quot.unquot {r : α → α → Prop} : quot r → α := unchecked_cast

@[simp] theorem quot.out_eq {r : α → α → Prop} (q : quot r) : quot.mk r q.out = q :=
classical.some_spec (quot.exists_rep q)

/-- Choose an element of the equivalence class using the axiom of choice.
  Sound but noncomputable. -/
noncomputable def quotient.out [s : setoid α] : quotient s → α := quot.out

@[simp] theorem quotient.out_eq [s : setoid α] (q : quotient s) : ⟦q.out⟧ = q := q.out_eq

theorem quotient.mk_out [s : setoid α] (a : α) : ⟦a⟧.out ≈ a :=
quotient.exact (quotient.out_eq _)

lemma quotient.mk_eq_iff_out [s : setoid α] {x : α} {y : quotient s} :
  ⟦x⟧ = y ↔ x ≈ quotient.out y :=
begin
  refine iff.trans _ quotient.eq,
  rw quotient.out_eq y,
end

lemma quotient.eq_mk_iff_out [s : setoid α] {x : quotient s} {y : α} :
  x = ⟦y⟧ ↔ quotient.out x ≈ y  :=
begin
  refine iff.trans _ quotient.eq,
  rw quotient.out_eq x,
end

@[simp] lemma quotient.out_equiv_out [s : setoid α] {x y : quotient s} :
  x.out ≈ y.out ↔ x = y :=
by rw [← quotient.eq_mk_iff_out, quotient.out_eq]

@[simp] lemma quotient.out_inj [s : setoid α] {x y : quotient s} :
  x.out = y.out ↔ x = y :=
⟨λ h, quotient.out_equiv_out.1 $ h ▸ setoid.refl _, λ h, h ▸ rfl⟩

section pi

instance pi_setoid {ι : Sort*} {α : ι → Sort*} [∀ i, setoid (α i)] : setoid (Π i, α i) :=
{ r := λ a b, ∀ i, a i ≈ b i,
  iseqv := ⟨
    λ a i, setoid.refl _,
    λ a b h i, setoid.symm (h _),
    λ a b c h₁ h₂ i, setoid.trans (h₁ _) (h₂ _)⟩ }

/-- Given a function `f : Π i, quotient (S i)`, returns the class of functions `Π i, α i` sending
each `i` to an element of the class `f i`. -/
noncomputable def quotient.choice {ι : Type*} {α : ι → Type*} [S : Π i, setoid (α i)]
  (f : Π i, quotient (S i)) : @quotient (Π i, α i) (by apply_instance) :=
⟦λ i, (f i).out⟧

@[simp] theorem quotient.choice_eq {ι : Type*} {α : ι → Type*} [Π i, setoid (α i)]
  (f : Π i, α i) : quotient.choice (λ i, ⟦f i⟧) = ⟦f⟧ :=
quotient.sound $ λ i, quotient.mk_out _

@[elab_as_eliminator] lemma quotient.induction_on_pi
   {ι : Type*} {α : ι → Sort*} [s : ∀ i, setoid (α i)]
   {p : (Π i, quotient (s i)) → Prop} (f : Π i, quotient (s i))
   (h : ∀ a : Π i, α i, p (λ i, ⟦a i⟧)) : p f :=
begin
  rw ← (funext (λ i, quotient.out_eq (f i)) : (λ i,  ⟦(f i).out⟧) = f),
  apply h,
end

end pi

lemma nonempty_quotient_iff (s : setoid α) : nonempty (quotient s) ↔ nonempty α :=
⟨assume ⟨a⟩, quotient.induction_on a nonempty.intro, assume ⟨a⟩, ⟨⟦a⟧⟩⟩

/-- `trunc α` is the quotient of `α` by the always-true relation. This
  is related to the propositional truncation in HoTT, and is similar
  in effect to `nonempty α`, but unlike `nonempty α`, `trunc α` is data,
  so the VM representation is the same as `α`, and so this can be used to
  maintain computability. -/
def {u} trunc (α : Sort u) : Sort u := @quot α (λ _ _, true)

theorem true_equivalence : @equivalence α (λ _ _, true) :=
⟨λ _, trivial, λ _ _ _, trivial, λ _ _ _ _ _, trivial⟩

namespace trunc

/-- Constructor for `trunc α` -/
def mk (a : α) : trunc α := quot.mk _ a

instance [inhabited α] : inhabited (trunc α) := ⟨mk default⟩

/-- Any constant function lifts to a function out of the truncation -/
def lift (f : α → β) (c : ∀ a b : α, f a = f b) : trunc α → β :=
quot.lift f (λ a b _, c a b)

theorem ind {β : trunc α → Prop} : (∀ a : α, β (mk a)) → ∀ q : trunc α, β q := quot.ind

protected theorem lift_mk (f : α → β) (c) (a : α) : lift f c (mk a) = f a := rfl

/-- Lift a constant function on `q : trunc α`. -/
@[reducible, elab_as_eliminator]
protected def lift_on (q : trunc α) (f : α → β)
  (c : ∀ a b : α, f a = f b) : β := lift f c q

@[elab_as_eliminator]
protected theorem induction_on {β : trunc α → Prop} (q : trunc α)
  (h : ∀ a, β (mk a)) : β q := ind h q

theorem exists_rep (q : trunc α) : ∃ a : α, mk a = q := quot.exists_rep q

attribute [elab_as_eliminator]
protected theorem induction_on₂ {C : trunc α → trunc β → Prop} (q₁ : trunc α) (q₂ : trunc β)
  (h : ∀ a b, C (mk a) (mk b)) : C q₁ q₂ :=
trunc.induction_on q₁ $ λ a₁, trunc.induction_on q₂ (h a₁)

protected theorem eq (a b : trunc α) : a = b :=
trunc.induction_on₂ a b (λ x y, quot.sound trivial)

instance : subsingleton (trunc α) := ⟨trunc.eq⟩

/-- The `bind` operator for the `trunc` monad. -/
def bind (q : trunc α) (f : α → trunc β) : trunc β :=
trunc.lift_on q f (λ a b, trunc.eq _ _)

/-- A function `f : α → β` defines a function `map f : trunc α → trunc β`. -/
def map (f : α → β) (q : trunc α) : trunc β := bind q (trunc.mk ∘ f)

instance : monad trunc :=
{ pure := @trunc.mk,
  bind := @trunc.bind }

instance : is_lawful_monad trunc :=
{ id_map := λ α q, trunc.eq _ _,
  pure_bind := λ α β q f, rfl,
  bind_assoc := λ α β γ x f g, trunc.eq _ _ }

variable {C : trunc α → Sort*}

/-- Recursion/induction principle for `trunc`. -/
@[reducible, elab_as_eliminator]
protected def rec
   (f : Π a, C (mk a)) (h : ∀ (a b : α), (eq.rec (f a) (trunc.eq (mk a) (mk b)) : C (mk b)) = f b)
   (q : trunc α) : C q :=
quot.rec f (λ a b _, h a b) q

/-- A version of `trunc.rec` taking `q : trunc α` as the first argument. -/
@[reducible, elab_as_eliminator]
protected def rec_on (q : trunc α) (f : Π a, C (mk a))
  (h : ∀ (a b : α), (eq.rec (f a) (trunc.eq (mk a) (mk b)) : C (mk b)) = f b) : C q :=
trunc.rec f h q

/-- A version of `trunc.rec_on` assuming the codomain is a `subsingleton`. -/
@[reducible, elab_as_eliminator]
protected def rec_on_subsingleton
   [∀ a, subsingleton (C (mk a))] (q : trunc α) (f : Π a, C (mk a)) : C q :=
trunc.rec f (λ a b, subsingleton.elim _ (f b)) q

/-- Noncomputably extract a representative of `trunc α` (using the axiom of choice). -/
noncomputable def out : trunc α → α := quot.out

@[simp] theorem out_eq (q : trunc α) : mk q.out = q := trunc.eq _ _

protected theorem nonempty (q : trunc α) : nonempty α :=
nonempty_of_exists q.exists_rep

end trunc

namespace quotient
variables {γ : Sort*} {φ : Sort*}
  {s₁ : setoid α} {s₂ : setoid β} {s₃ : setoid γ}

/-! Versions of quotient definitions and lemmas ending in `'` use unification instead
of typeclass inference for inferring the `setoid` argument. This is useful when there are
several different quotient relations on a type, for example quotient groups, rings and modules. -/

/-- A version of `quotient.mk` taking `{s : setoid α}` as an implicit argument instead of an
instance argument. -/
protected def mk' (a : α) : quotient s₁ := quot.mk s₁.1 a

/-- `quotient.mk'` is a surjective function. -/
lemma surjective_quotient_mk' : function.surjective (quotient.mk' : α → quotient s₁) :=
quot.exists_rep

/-- A version of `quotient.lift_on` taking `{s : setoid α}` as an implicit argument instead of an
instance argument. -/
@[elab_as_eliminator, reducible]
protected def lift_on' (q : quotient s₁) (f : α → φ)
  (h : ∀ a b, @setoid.r α s₁ a b → f a = f b) : φ := quotient.lift_on q f h

@[simp]
protected lemma lift_on'_mk' (f : α → φ) (h) (x : α) :
  quotient.lift_on' (@quotient.mk' _ s₁ x) f h = f x := rfl

/-- A version of `quotient.lift_on₂` taking `{s₁ : setoid α} {s₂ : setoid β}` as implicit arguments
instead of instance arguments. -/
@[elab_as_eliminator, reducible]
protected def lift_on₂' (q₁ : quotient s₁) (q₂ : quotient s₂) (f : α → β → γ)
  (h : ∀ a₁ a₂ b₁ b₂, @setoid.r α s₁ a₁ b₁ → @setoid.r β s₂ a₂ b₂ → f a₁ a₂ = f b₁ b₂) : γ :=
quotient.lift_on₂ q₁ q₂ f h

@[simp]
protected lemma lift_on₂'_mk' (f : α → β → γ) (h) (a : α) (b : β) :
  quotient.lift_on₂' (@quotient.mk' _ s₁ a) (@quotient.mk' _ s₂ b) f h = f a b := rfl

/-- A version of `quotient.ind` taking `{s : setoid α}` as an implicit argument instead of an
instance argument. -/
@[elab_as_eliminator]
protected lemma ind' {p : quotient s₁ → Prop}
  (h : ∀ a, p (quotient.mk' a)) (q : quotient s₁) : p q :=
quotient.ind h q

/-- A version of `quotient.ind₂` taking `{s₁ : setoid α} {s₂ : setoid β}` as implicit arguments
instead of instance arguments. -/
@[elab_as_eliminator]
protected lemma ind₂' {p : quotient s₁ → quotient s₂ → Prop}
  (h : ∀ a₁ a₂, p (quotient.mk' a₁) (quotient.mk' a₂))
  (q₁ : quotient s₁) (q₂ : quotient s₂) : p q₁ q₂ :=
quotient.ind₂ h q₁ q₂

/-- A version of `quotient.induction_on` taking `{s : setoid α}` as an implicit argument instead
of an instance argument. -/
@[elab_as_eliminator]
protected lemma induction_on' {p : quotient s₁ → Prop} (q : quotient s₁)
  (h : ∀ a, p (quotient.mk' a)) : p q := quotient.induction_on q h

/-- A version of `quotient.induction_on₂` taking `{s₁ : setoid α} {s₂ : setoid β}` as implicit
arguments instead of instance arguments. -/
@[elab_as_eliminator]
protected lemma induction_on₂' {p : quotient s₁ → quotient s₂ → Prop} (q₁ : quotient s₁)
  (q₂ : quotient s₂) (h : ∀ a₁ a₂, p (quotient.mk' a₁) (quotient.mk' a₂)) : p q₁ q₂ :=
quotient.induction_on₂ q₁ q₂ h

/-- A version of `quotient.induction_on₃` taking `{s₁ : setoid α} {s₂ : setoid β} {s₃ : setoid γ}`
as implicit arguments instead of instance arguments. -/
@[elab_as_eliminator]
protected lemma induction_on₃' {p : quotient s₁ → quotient s₂ → quotient s₃ → Prop}
  (q₁ : quotient s₁) (q₂ : quotient s₂) (q₃ : quotient s₃)
  (h : ∀ a₁ a₂ a₃, p (quotient.mk' a₁) (quotient.mk' a₂) (quotient.mk' a₃)) : p q₁ q₂ q₃ :=
quotient.induction_on₃ q₁ q₂ q₃ h

/-- A version of `quotient.rec_on_subsingleton` taking `{s₁ : setoid α}` as an implicit argument
instead of an instance argument. -/
@[elab_as_eliminator]
protected def rec_on_subsingleton' {φ : quotient s₁ → Sort*}
  [h : ∀ a, subsingleton (φ ⟦a⟧)] (q : quotient s₁) (f : Π a, φ (quotient.mk' a)) : φ q :=
quotient.rec_on_subsingleton q f

/-- A version of `quotient.rec_on_subsingleton₂` taking `{s₁ : setoid α} {s₂ : setoid α}`
as implicit arguments instead of instance arguments. -/
attribute [reducible, elab_as_eliminator]
protected def rec_on_subsingleton₂'
   {φ : quotient s₁ → quotient s₂ → Sort*} [h : ∀ a b, subsingleton (φ ⟦a⟧ ⟦b⟧)]
   (q₁ : quotient s₁) (q₂ : quotient s₂) (f : Π a₁ a₂, φ (quotient.mk' a₁) (quotient.mk' a₂)) :
   φ q₁ q₂ :=
quotient.rec_on_subsingleton₂ q₁ q₂ f

/-- Recursion on a `quotient` argument `a`, result type depends on `⟦a⟧`. -/
protected def hrec_on' {φ : quotient s₁ → Sort*} (qa : quotient s₁) (f : Π a, φ (quotient.mk' a))
  (c : ∀ a₁ a₂, a₁ ≈ a₂ → f a₁ == f a₂) : φ qa :=
quot.hrec_on qa f c

@[simp]

/-- Recursion on two `quotient` arguments `a` and `b`, result type depends on `⟦a⟧` and `⟦b⟧`. -/
protected def hrec_on₂' {φ : quotient s₁ → quotient s₂ → Sort*} (qa : quotient s₁)
  (qb : quotient s₂) (f : ∀ a b, φ (quotient.mk' a) (quotient.mk' b))
  (c : ∀ a₁ b₁ a₂ b₂, a₁ ≈ a₂ → b₁ ≈ b₂ → f a₁ b₁ == f a₂ b₂) : φ qa qb :=
quotient.hrec_on₂ qa qb f c

@[simp] lemma hrec_on₂'_mk' {φ : quotient s₁ → quotient s₂ → Sort*}
  (f : ∀ a b, φ (quotient.mk' a) (quotient.mk' b))
  (c : ∀ a₁ b₁ a₂ b₂, a₁ ≈ a₂ → b₁ ≈ b₂ → f a₁ b₁ == f a₂ b₂) (x : α) (qb : quotient s₂) :
  (quotient.mk' x).hrec_on₂' qb f c = qb.hrec_on' (f x) (λ b₁ b₂, c _ _ _ _ (setoid.refl _)) :=
rfl

/-- Map a function `f : α → β` that sends equivalent elements to equivalent elements
to a function `quotient sa → quotient sb`. Useful to define unary operations on quotients. -/
protected def map' (f : α → β) (h : ((≈) ⇒ (≈)) f f) :
  quotient s₁ → quotient s₂ :=
quot.map f h

@[simp] lemma map'_mk' (f : α → β) (h) (x : α) :
  (quotient.mk' x : quotient s₁).map' f h = (quotient.mk' (f x) : quotient s₂) :=
rfl

/-- A version of `quotient.map₂` using curly braces and unification. -/
protected def map₂' (f : α → β → γ) (h : ((≈) ⇒ (≈) ⇒ (≈)) f f) :
  quotient s₁ → quotient s₂ → quotient s₃ :=
quotient.map₂ f h

@[simp] lemma map₂'_mk' (f : α → β → γ) (h) (x : α) :
  (quotient.mk' x : quotient s₁).map₂' f h =
    (quotient.map' (f x) (h (setoid.refl x)) : quotient s₂ → quotient s₃) :=
rfl

lemma exact' {a b : α} :
  (quotient.mk' a : quotient s₁) = quotient.mk' b → @setoid.r _ s₁ a b :=
quotient.exact

lemma sound' {a b : α} : @setoid.r _ s₁ a b → @quotient.mk' α s₁ a = quotient.mk' b :=
quotient.sound

@[simp]
protected lemma eq' {a b : α} : @quotient.mk' α s₁ a = quotient.mk' b ↔ @setoid.r _ s₁ a b :=
quotient.eq

/-- A version of `quotient.out` taking `{s₁ : setoid α}` as an implicit argument instead of an
instance argument. -/
noncomputable def out' (a : quotient s₁) : α := quotient.out a

@[simp] theorem out_eq' (q : quotient s₁) : quotient.mk' q.out' = q := q.out_eq

theorem mk_out' (a : α) : @setoid.r α s₁ (quotient.mk' a : quotient s₁).out' a :=
quotient.exact (quotient.out_eq _)

end quotient


/-
Copyright (c) 2019 Johannes Hölzl. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Johannes Hölzl
-/
import measure_theory.integral.lebesgue

/-!
# The Giry monad

Let X be a measurable space. The collection of all measures on X again
forms a measurable space. This construction forms a monad on
measurable spaces and measurable functions, called the Giry monad.

Note that most sources use the term "Giry monad" for the restriction
to *probability* measures. Here we include all measures on X.

See also `measure_theory/category/Meas.lean`, containing an upgrade of the type-level
monad to an honest monad of the functor `Measure : Meas ⥤ Meas`.

## References

* <https://ncatlab.org/nlab/show/Giry+monad>

## Tags

giry monad
-/

noncomputable theory
open_locale classical big_operators ennreal

open classical set filter

variables {α β : Type*}

namespace measure_theory

namespace measure

variables [measurable_space α] [measurable_space β]

/-- Measurability structure on `measure`: Measures are measurable w.r.t. all projections -/
instance : measurable_space (measure α) :=
⨆ (s : set α) (hs : measurable_set s), (borel ℝ≥0∞).comap (λ μ, μ s)

lemma measurable_coe {s : set α} (hs : measurable_set s) : measurable (λ μ : measure α, μ s) :=
measurable.of_comap_le $ le_supr_of_le s $ le_supr_of_le hs $ le_rfl

lemma measurable_of_measurable_coe (f : β → measure α)
  (h : ∀ (s : set α) (hs : measurable_set s), measurable (λ b, f b s)) :
  measurable f :=
measurable.of_le_map $ supr₂_le $ assume s hs, measurable_space.comap_le_iff_le_map.2 $
  by rw [measurable_space.map_comp]; exact h s hs

instance {α : Type*} {m : measurable_space α} : has_measurable_add₂ (measure α) :=
begin
  refine ⟨measure.measurable_of_measurable_coe _ (λ s hs, _)⟩,
  simp_rw [measure.coe_add, pi.add_apply],
  refine measurable.add _ _,
  { exact (measure.measurable_coe hs).comp measurable_fst, },
  { exact (measure.measurable_coe hs).comp measurable_snd, },
end

lemma measurable_measure {μ : α → measure β} :
  measurable μ ↔ ∀ (s : set β) (hs : measurable_set s), measurable (λ b, μ b s) :=
⟨λ hμ s hs, (measurable_coe hs).comp hμ, measurable_of_measurable_coe μ⟩

lemma measurable_map (f : α → β) (hf : measurable f) :
  measurable (λ μ : measure α, map f μ) :=
begin
  refine measurable_of_measurable_coe _ (λ s hs, _),
  simp_rw map_apply hf hs,
  exact measurable_coe (hf hs),
end

lemma measurable_dirac : measurable (measure.dirac : α → measure α) :=
begin
  refine measurable_of_measurable_coe _ (λ s hs, _),
  simp_rw [dirac_apply' _ hs],
  exact measurable_one.indicator hs
end

lemma measurable_lintegral {f : α → ℝ≥0∞} (hf : measurable f) :
  measurable (λ μ : measure α, ∫⁻ x, f x ∂μ) :=
begin
  simp only [lintegral_eq_supr_eapprox_lintegral, hf, simple_func.lintegral],
  refine measurable_supr (λ n, finset.measurable_sum _ (λ i _, _)),
  refine measurable.const_mul _ _,
  exact measurable_coe ((simple_func.eapprox f n).measurable_set_preimage _)
end

/-- Monadic join on `measure` in the category of measurable spaces and measurable
functions. -/
def join (m : measure (measure α)) : measure α :=
measure.of_measurable
  (λ s hs, ∫⁻ μ, μ s ∂m)
  (by simp only [measure_empty, lintegral_const, zero_mul])
  begin
    assume f hf h,
    simp_rw [measure_Union h hf],
    apply lintegral_tsum,
    assume i, exact (measurable_coe (hf i)).ae_measurable
  end

@[simp] lemma join_apply {m : measure (measure α)} {s : set α} (hs : measurable_set s) :
  join m s = ∫⁻ μ, μ s ∂m :=
measure.of_measurable_apply s hs

@[simp] lemma join_zero : (0 : measure (measure α)).join = 0 :=
by { ext1 s hs, simp only [hs, join_apply, lintegral_zero_measure, coe_zero, pi.zero_apply], }

lemma measurable_join : measurable (join : measure (measure α) → measure α) :=
measurable_of_measurable_coe _ $ assume s hs,
  by simp only [join_apply hs]; exact measurable_lintegral (measurable_coe hs)

lemma lintegral_join {m : measure (measure α)} {f : α → ℝ≥0∞} (hf : measurable f) :
  ∫⁻ x, f x ∂(join m) = ∫⁻ μ, ∫⁻ x, f x ∂μ ∂m :=
begin
  simp_rw [lintegral_eq_supr_eapprox_lintegral hf,
    simple_func.lintegral, join_apply (simple_func.measurable_set_preimage _ _)],
  suffices : ∀ (s : ℕ → finset ℝ≥0∞) (f : ℕ → ℝ≥0∞ → measure α → ℝ≥0∞)
    (hf : ∀ n r, measurable (f n r)) (hm : monotone (λ n μ, ∑ r in s n, r * f n r μ)),
    (⨆ n, ∑ r in s n, r * ∫⁻ μ, f n r μ ∂m) = ∫⁻ μ, ⨆ n, ∑ r in s n, r * f n r μ ∂m,
  { refine this (λ n, simple_func.range (simple_func.eapprox f n))
      (λ n r μ, μ (simple_func.eapprox f n ⁻¹' {r})) _ _,
    { exact λ n r, measurable_coe (simple_func.measurable_set_preimage _ _), },
    { exact λ n m h μ, simple_func.lintegral_mono (simple_func.monotone_eapprox _ h) le_rfl, }, },
  intros s f hf hm,
  rw lintegral_supr _ hm,
  swap, { exact λ n, finset.measurable_sum _ (λ r _, (hf _ _).const_mul _) },
  congr,
  funext n,
  rw lintegral_finset_sum (s n),
  { simp_rw lintegral_const_mul _ (hf _ _), },
  { exact λ r _, (hf _ _).const_mul _ },
end

/-- Monadic bind on `measure`, only works in the category of measurable spaces and measurable
functions. When the function `f` is not measurable the result is not well defined. -/
def bind (m : measure α) (f : α → measure β) : measure β := join (map f m)

@[simp] lemma bind_zero_left (f : α → measure β) : bind 0 f = 0 :=
by simp [bind]

@[simp] lemma bind_zero_right (m : measure α) :
  bind m (0 : α → measure β) = 0 :=
begin
  ext1 s hs,
  simp only [bind, hs, join_apply, coe_zero, pi.zero_apply],
  rw [lintegral_map (measurable_coe hs) measurable_zero],
  simp only [pi.zero_apply, coe_zero, lintegral_const, zero_mul],
end

@[simp] lemma bind_zero_right' (m : measure α) :
  bind m (λ _, 0 : α → measure β) = 0 :=
bind_zero_right m

@[simp] lemma bind_apply {m : measure α} {f : α → measure β} {s : set β}
  (hs : measurable_set s) (hf : measurable f) :
  bind m f s = ∫⁻ a, f a s ∂m :=
by rw [bind, join_apply hs, lintegral_map (measurable_coe hs) hf]

lemma measurable_bind' {g : α → measure β} (hg : measurable g) : measurable (λ m, bind m g) :=
measurable_join.comp (measurable_map _ hg)

lemma lintegral_bind {m : measure α} {μ : α → measure β} {f : β → ℝ≥0∞}
  (hμ : measurable μ) (hf : measurable f) :
  ∫⁻ x, f x ∂ (bind m μ) = ∫⁻ a, ∫⁻ x, f x ∂(μ a) ∂m :=
(lintegral_join hf).trans (lintegral_map (measurable_lintegral hf) hμ)

lemma bind_bind {γ} [measurable_space γ] {m : measure α} {f : α → measure β} {g : β → measure γ}
  (hf : measurable f) (hg : measurable g) :
  bind (bind m f) g = bind m (λ a, bind (f a) g) :=
begin
  ext1 s hs,
  simp_rw [bind_apply hs hg, bind_apply hs ((measurable_bind' hg).comp hf),
    lintegral_bind hf ((measurable_coe hs).comp hg), (bind_apply hs hg)],
end

lemma bind_dirac {f : α → measure β} (hf : measurable f) (a : α) : bind (dirac a) f = f a :=
by { ext1 s hs, rw [bind_apply hs hf, lintegral_dirac' a ((measurable_coe hs).comp hf)], }

lemma dirac_bind {m : measure α} : bind m dirac = m :=
begin
  ext1 s hs,
  simp only [bind_apply hs measurable_dirac, dirac_apply' _ hs, lintegral_indicator 1 hs,
    pi.one_apply, lintegral_one, restrict_apply, measurable_set.univ, univ_inter],
end

lemma join_eq_bind (μ : measure (measure α)) : join μ = bind μ id :=
by rw [bind, map_id]

lemma join_map_map {f : α → β} (hf : measurable f) (μ : measure (measure α)) :
  join (map (map f) μ) = map f (join μ) :=
begin
  ext1 s hs,
  rw [join_apply hs, map_apply hf hs, join_apply (hf hs),
    lintegral_map (measurable_coe hs) (measurable_map f hf)],
  simp_rw map_apply hf hs,
end

lemma join_map_join (μ : measure (measure (measure α))) :
  join (map join μ) = join (join μ) :=
begin
  show bind μ join = join (join μ),
  rw [join_eq_bind, join_eq_bind, bind_bind measurable_id measurable_id],
  apply congr_arg (bind μ),
  funext ν,
  exact join_eq_bind ν
end

lemma join_map_dirac (μ : measure α) : join (map dirac μ) = μ :=
dirac_bind

lemma join_dirac (μ : measure α) : join (dirac μ) = μ :=
(join_eq_bind (dirac μ)).trans (bind_dirac measurable_id _)

end measure

end measure_theory


/-
Copyright (c) 2017 Mario Carneiro. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Sébastien Gouëzel, Floris van Doorn, Mario Carneiro, Martin Dvorak
-/
import data.list.big_operators.basic

/-!
# Join of a list of lists

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

This file proves basic properties of `list.join`, which concatenates a list of lists. It is defined
in [`data.list.defs`](./defs).
-/

variables {α β : Type*}

namespace list

attribute [simp] join

@[simp] lemma join_singleton (l : list α) : [l].join = l :=
by rw [join, join, append_nil]

@[simp] lemma join_eq_nil : ∀ {L : list (list α)}, join L = [] ↔ ∀ l ∈ L, l = []
| []       := iff_of_true rfl (forall_mem_nil _)
| (l :: L) := by simp only [join, append_eq_nil, join_eq_nil, forall_mem_cons]

@[simp] lemma join_append (L₁ L₂ : list (list α)) : join (L₁ ++ L₂) = join L₁ ++ join L₂ :=
by induction L₁; [refl, simp only [*, join, cons_append, append_assoc]]

lemma join_concat (L : list (list α)) (l : list α) : join (L.concat l) = join L ++ l :=
by simp

@[simp] lemma join_filter_empty_eq_ff [decidable_pred (λ l : list α, l.empty = ff)] :
  ∀ {L : list (list α)}, join (L.filter (λ l, l.empty = ff)) = L.join
| []              := rfl
| ([] :: L)       := by simp [@join_filter_empty_eq_ff L]
| ((a :: l) :: L) := by simp [@join_filter_empty_eq_ff L]

@[simp] lemma join_filter_ne_nil [decidable_pred (λ l : list α, l ≠ [])] {L : list (list α)} :
  join (L.filter (λ l, l ≠ [])) = L.join :=
by simp [join_filter_empty_eq_ff, ← empty_iff_eq_nil]

lemma join_join (l : list (list (list α))) : l.join.join = (l.map join).join :=
by { induction l, simp, simp [l_ih] }

@[simp] lemma length_join (L : list (list α)) : length (join L) = sum (map length L) :=
by induction L; [refl, simp only [*, join, map, sum_cons, length_append]]

@[simp] lemma length_bind (l : list α) (f : α → list β) :
  length (list.bind l f) = sum (map (length ∘ f) l) :=
by rw [list.bind, length_join, map_map]

@[simp] lemma bind_eq_nil {l : list α} {f : α → list β} :
  list.bind l f = [] ↔ ∀ x ∈ l, f x = [] :=
join_eq_nil.trans $ by simp only [mem_map, forall_exists_index, and_imp, forall_apply_eq_imp_iff₂]

/-- In a join, taking the first elements up to an index which is the sum of the lengths of the
first `i` sublists, is the same as taking the join of the first `i` sublists. -/
lemma take_sum_join (L : list (list α)) (i : ℕ) :
  L.join.take ((L.map length).take i).sum = (L.take i).join :=
begin
  induction L generalizing i, { simp },
  cases i, { simp },
  simp [take_append, L_ih]
end

/-- In a join, dropping all the elements up to an index which is the sum of the lengths of the
first `i` sublists, is the same as taking the join after dropping the first `i` sublists. -/
lemma drop_sum_join (L : list (list α)) (i : ℕ) :
  L.join.drop ((L.map length).take i).sum = (L.drop i).join :=
begin
  induction L generalizing i, { simp },
  cases i, { simp },
  simp [drop_append, L_ih],
end

/-- Taking only the first `i+1` elements in a list, and then dropping the first `i` ones, one is
left with a list of length `1` made of the `i`-th element of the original list. -/
lemma drop_take_succ_eq_cons_nth_le (L : list α) {i : ℕ} (hi : i < L.length) :
  (L.take (i+1)).drop i = [nth_le L i hi] :=
begin
  induction L generalizing i,
  { simp only [length] at hi, exact (nat.not_succ_le_zero i hi).elim },
  cases i, { simp },
  have : i < L_tl.length,
  { simp at hi,
    exact nat.lt_of_succ_lt_succ hi },
  simp [L_ih this],
  refl
end

/-- In a join of sublists, taking the slice between the indices `A` and `B - 1` gives back the
original sublist of index `i` if `A` is the sum of the lenghts of sublists of index `< i`, and
`B` is the sum of the lengths of sublists of index `≤ i`. -/
lemma drop_take_succ_join_eq_nth_le (L : list (list α)) {i : ℕ} (hi : i < L.length) :
  (L.join.take ((L.map length).take (i+1)).sum).drop ((L.map length).take i).sum = nth_le L i hi :=
begin
  have : (L.map length).take i = ((L.take (i+1)).map length).take i, by simp [map_take, take_take],
  simp [take_sum_join, this, drop_sum_join, drop_take_succ_eq_cons_nth_le _ hi]
end

/-- Auxiliary lemma to control elements in a join. -/
lemma sum_take_map_length_lt1 (L : list (list α)) {i j : ℕ}
  (hi : i < L.length) (hj : j < (nth_le L i hi).length) :
  ((L.map length).take i).sum + j < ((L.map length).take (i+1)).sum :=
by simp [hi, sum_take_succ, hj]

/-- Auxiliary lemma to control elements in a join. -/
lemma sum_take_map_length_lt2 (L : list (list α)) {i j : ℕ}
  (hi : i < L.length) (hj : j < (nth_le L i hi).length) :
  ((L.map length).take i).sum + j < L.join.length :=
begin
  convert lt_of_lt_of_le (sum_take_map_length_lt1 L hi hj) (monotone_sum_take _ hi),
  have : L.length = (L.map length).length, by simp,
  simp [this, -length_map]
end

/-- The `n`-th element in a join of sublists is the `j`-th element of the `i`th sublist,
where `n` can be obtained in terms of `i` and `j` by adding the lengths of all the sublists
of index `< i`, and adding `j`. -/
lemma nth_le_join (L : list (list α)) {i j : ℕ}
  (hi : i < L.length) (hj : j < (nth_le L i hi).length) :
  nth_le L.join (((L.map length).take i).sum + j) (sum_take_map_length_lt2 L hi hj) =
  nth_le (nth_le L i hi) j hj :=
by rw [nth_le_take L.join (sum_take_map_length_lt2 L hi hj) (sum_take_map_length_lt1 L hi hj),
  nth_le_drop, nth_le_of_eq (drop_take_succ_join_eq_nth_le L hi)]

/-- Two lists of sublists are equal iff their joins coincide, as well as the lengths of the
sublists. -/
theorem eq_iff_join_eq (L L' : list (list α)) :
  L = L' ↔ L.join = L'.join ∧ map length L = map length L' :=
begin
  refine ⟨λ H, by simp [H], _⟩,
  rintros ⟨join_eq, length_eq⟩,
  apply ext_le,
  { have : length (map length L) = length (map length L'), by rw length_eq,
    simpa using this },
  { assume n h₁ h₂,
    rw [← drop_take_succ_join_eq_nth_le, ← drop_take_succ_join_eq_nth_le, join_eq, length_eq] }
end

lemma join_drop_length_sub_one {L : list (list α)} (h : L ≠ []) :
  (L.drop (L.length - 1)).join = L.last h :=
begin
  induction L using list.reverse_rec_on,
  { cases h rfl },
  { simp },
end

/-- We can rebracket `x ++ (l₁ ++ x) ++ (l₂ ++ x) ++ ... ++ (lₙ ++ x)` to
`(x ++ l₁) ++ (x ++ l₂) ++ ... ++ (x ++ lₙ) ++ x` where `L = [l₁, l₂, ..., lₙ]`. -/
lemma append_join_map_append (L : list (list α)) (x : list α) :
  x ++ (list.map (λ l, l ++ x) L).join = (list.map (λ l, x ++ l) L).join ++ x :=
begin
  induction L,
  { rw [map_nil, join, append_nil, map_nil, join, nil_append] },
  { rw [map_cons, join, map_cons, join, append_assoc, L_ih, append_assoc, append_assoc] },
end

/-- Reversing a join is the same as reversing the order of parts and reversing all parts. -/
lemma reverse_join (L : list (list α)) :
  L.join.reverse = (list.map list.reverse L).reverse.join :=
begin
  induction L,
  { refl },
  { rw [join, reverse_append, L_ih, map_cons, reverse_cons', join_concat] },
end

/-- Joining a reverse is the same as reversing all parts and reversing the joined result. -/
lemma join_reverse (L : list (list α)) :
  L.reverse.join = (list.map list.reverse L).join.reverse :=
by simpa [reverse_reverse] using congr_arg list.reverse (reverse_join L.reverse)

end list


/-
Copyright (c) 2018 Johannes Hölzl. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Johannes Hölzl, Floris van Doorn, Mario Carneiro, Reid Barton, Johan Commelin
-/

import Mathlib.Util.Tactic
import Mathlib.Logic.Function.Basic

/-!
# `choose` tactic
Performs Skolemization, that is, given `h : ∀ a:α, ∃ b:β, p a b |- G` produces
`f : α → β, hf: ∀ a, p a (f a) |- G`.

TODO: switch to `rcases` syntax: `choose ⟨i, j, h₁ -⟩ := expr`.
-/

open Lean Meta Elab Tactic

namespace Mathlib.Tactic.Choose

/-- Given `α : Sort u`, `nonemp : Nonempty α`, `p : α → Prop`, a context of free variables
`ctx`, and a pair of an element `val : α` and `spec : p val`,
`mk_sometimes u α nonemp p ctx (val, spec)` produces another pair `val', spec'`
such that `val'` does not have any free variables from elements of `ctx` whose types are
propositions. This is done by applying `Function.sometimes` to abstract over all the propositional
arguments. -/
def mk_sometimes (u : Level) (α nonemp p : Expr) :
  List Expr → Expr × Expr → MetaM (Expr × Expr)
| [], (val, spec) => pure (val, spec)
| (e :: ctx), (val, spec) => do
  let (val, spec) ← mk_sometimes u α nonemp p ctx (val, spec)
  let t ← inferType e
  let b ← isProp t
  if b then do
    let val' ← mkLambdaFVars #[e] val
    pure
      (mkApp4 (Expr.const ``Function.sometimes [Level.zero, u]) t α nonemp val',
      mkApp7 (Expr.const ``Function.sometimes_spec [u]) t α nonemp p val' e spec)
  else pure (val, spec)

/-- Results of searching for nonempty instances,
to eliminate dependencies on propositions (`choose!`).
`success` means we found at least one instance;
`failure ts` means we didn't find instances for any `t ∈ ts`.
(`failure []` means we didn't look for instances at all.)

Rationale:
`choose!` means we are expected to succeed at least once
in eliminating dependencies on propositions.
-/
inductive ElimStatus
| success
| failure (ts : List Expr)

/-- Combine two statuses, keeping a success from either side
or merging the failures. -/
def ElimStatus.merge : ElimStatus → ElimStatus → ElimStatus
| success, _ => success
| _, success => success
| failure ts₁, failure ts₂ => failure (ts₁ ++ ts₂)

/-- `mkFreshNameFrom orig base` returns `mkFreshUserName base` if ``orig = `_``
and `orig` otherwise. -/
def mkFreshNameFrom (orig base : Name) : CoreM Name :=
  if orig = `_ then mkFreshUserName base else pure orig

/-- Changes `(h : ∀xs, ∃a:α, p a) ⊢ g` to `(d : ∀xs, a) ⊢ (s : ∀xs, p (d xs)) → g` and
`(h : ∀xs, p xs ∧ q xs) ⊢ g` to `(d : ∀xs, p xs) ⊢ (s : ∀xs, q xs) → g`.
`choose1` returns a tuple of

- the error result (see `ElimStatus`)
- the data new free variable that was "chosen"
- the new goal (which contains the spec of the data as domain of an arrow type)

If `nondep` is true and `α` is inhabited, then it will remove the dependency of `d` on
all propositional assumptions in `xs`. For example if `ys` are propositions then
`(h : ∀xs ys, ∃a:α, p a) ⊢ g` becomes `(d : ∀xs, a) (s : ∀xs ys, p (d xs)) ⊢ g`. -/
def choose1 (g : MVarId) (nondep : Bool) (h : Option Expr) (data : Name) :
  MetaM (ElimStatus × Expr × MVarId) := do
  let (g, h) ← match h with
  | some e => pure (g, e)
  | none   => do
    let (e, g) ← g.intro1P
    pure (g, .fvar e)
  g.withContext do
    let h ← instantiateMVars h
    let t ← inferType h
    forallTelescopeReducing t fun ctx t ↦ do
      (← withTransparency .all (whnf t)).withApp fun
      | .const ``Exists [u], #[α, p] => do
        let data ← mkFreshNameFrom data ((← p.getBinderName).getD `h)
        let ((neFail : ElimStatus), (nonemp : Option Expr)) ← if nondep then
          let ne := (Expr.const ``Nonempty [u]).app α
          let m ← mkFreshExprMVar ne
          let mut g' := m.mvarId!
          for e in ctx do
            if (← isProof e) then continue
            let ty ← whnf (← inferType e)
            let nety := (Expr.const ``Nonempty [u]).app ty
            let neval := mkApp2 (Expr.const ``Nonempty.intro [u]) ty e
            g' ← g'.assert .anonymous nety neval
          (_, g') ← g'.intros
          g'.withContext do
            match ← synthInstance? (← g'.getType) with
            | some e => do
              g'.assign e
              let m ← instantiateMVars m
              pure (.success, some m)
            | none => pure (.failure [ne], none)
        else pure (.failure [], none)
        let ctx' ← if nonemp.isSome then ctx.filterM (not <$> isProof ·) else pure ctx
        let dataTy ← mkForallFVars ctx' α
        let mut dataVal := mkApp3 (.const ``Classical.choose [u]) α p (mkAppN h ctx)
        let mut specVal := mkApp3 (.const ``Classical.choose_spec [u]) α p (mkAppN h ctx)
        if let some nonemp := nonemp then
          (dataVal, specVal) ← mk_sometimes u α nonemp p ctx.toList (dataVal, specVal)
        dataVal ← mkLambdaFVars ctx' dataVal
        specVal ← mkLambdaFVars ctx specVal
        let (fvar, g) ← withLocalDeclD .anonymous dataTy fun d ↦ do
          let specTy ← mkForallFVars ctx (p.app (mkAppN d ctx')).headBeta
          g.withContext <| withLocalDeclD data dataTy fun d' ↦ do
            let mvarTy ← mkArrow (specTy.replaceFVar d d') (← g.getType)
            let newMVar ← mkFreshExprSyntheticOpaqueMVar mvarTy (← g.getTag)
            g.assign <| mkApp2 (← mkLambdaFVars #[d'] newMVar) dataVal specVal
            pure (d', newMVar.mvarId!)
        let g ← match h with
        | .fvar v => g.clear v
        | _ => pure g
        return (neFail, fvar, g)
      | .const ``And _, #[p, q] => do
        let data ← mkFreshNameFrom data `h
        let e1 ← mkLambdaFVars ctx $ mkApp3 (.const ``And.left  []) p q (mkAppN h ctx)
        let e2 ← mkLambdaFVars ctx $ mkApp3 (.const ``And.right []) p q (mkAppN h ctx)
        let t1 ← inferType e1
        let t2 ← inferType e2
        let (fvar, g) ← (← (← g.assert .anonymous t2 e2).assert data t1 e1).intro1P
        let g ← match h with
        | .fvar v => g.clear v
        | _ => pure g
        return (.success, .fvar fvar, g)
      -- TODO: support Σ, ×, or even any inductive type with 1 constructor ?
      | _, _ => throwError "expected a term of the shape `∀xs, ∃a, p xs a` or `∀xs, p xs ∧ q xs`"

/-- A wrapper around `choose1` that parses identifiers and adds variable info to new variables. -/
def choose1WithInfo (g : MVarId) (nondep : Bool) (h : Option Expr) (data : TSyntax ``binderIdent) :
  TermElabM (ElimStatus × MVarId) := do
  let n := if let `(binderIdent| $n:ident) := data then n.getId else `_
  let (status, fvar, g) ← choose1 g nondep h n
  g.withContext <| fvar.addLocalVarInfoForBinderIdent data
  pure (status, g)

/-- A loop around `choose1`. The main entry point for the `choose` tactic. -/
def elabChoose (nondep : Bool) (h : Option Expr) :
  List (TSyntax ``binderIdent) → ElimStatus → MVarId → TermElabM MVarId
| [], _, _ => throwError "expect list of variables"
| [n], status, g =>
  match nondep, status with
  | true, .failure tys => do -- We expected some elimination, but it didn't happen.
    let mut msg := m!"choose!: failed to synthesize any nonempty instances"
    for ty in tys do
      msg := msg ++ m!"{(← mkFreshExprMVar ty).mvarId!}"
    throwError msg
  | _, _ => do
    let (fvar, g) ← match n with
    | `(binderIdent| $n:ident) => g.intro n.getId
    | _ => g.intro1
    g.withContext <| (Expr.fvar fvar).addLocalVarInfoForBinderIdent n
    return g
| n::ns, status, g => do
  let (status', g) ← choose1WithInfo g nondep h n
  elabChoose nondep none ns (status.merge status') g

/--
* `choose a b h h' using hyp` takes a hypothesis `hyp` of the form
  `∀ (x : X) (y : Y), ∃ (a : A) (b : B), P x y a b ∧ Q x y a b`
  for some `P Q : X → Y → A → B → Prop` and outputs
  into context a function `a : X → Y → A`, `b : X → Y → B` and two assumptions:
  `h : ∀ (x : X) (y : Y), P x y (a x y) (b x y)` and
  `h' : ∀ (x : X) (y : Y), Q x y (a x y) (b x y)`. It also works with dependent versions.

* `choose! a b h h' using hyp` does the same, except that it will remove dependency of
  the functions on propositional arguments if possible. For example if `Y` is a proposition
  and `A` and `B` are nonempty in the above example then we will instead get
  `a : X → A`, `b : X → B`, and the assumptions
  `h : ∀ (x : X) (y : Y), P x y (a x) (b x)` and
  `h' : ∀ (x : X) (y : Y), Q x y (a x) (b x)`.

The `using hyp` part can be ommited,
which will effectively cause `choose` to start with an `intro hyp`.

Examples:

```
example (h : ∀ n m : ℕ, ∃ i j, m = n + i ∨ m + j = n) : True := by
  choose i j h using h
  guard_hyp i : ℕ → ℕ → ℕ
  guard_hyp j : ℕ → ℕ → ℕ
  guard_hyp h : ∀ (n m : ℕ), m = n + i n m ∨ m + j n m = n
  trivial
```

```
example (h : ∀ i : ℕ, i < 7 → ∃ j, i < j ∧ j < i+i) : True := by
  choose! f h h' using h
  guard_hyp f : ℕ → ℕ
  guard_hyp h : ∀ (i : ℕ), i < 7 → i < f i
  guard_hyp h' : ∀ (i : ℕ), i < 7 → f i < i + i
  trivial
```
-/
syntax (name := choose) "choose" "!"? (colGt binderIdent)+ (" using " term)? : tactic
elab_rules : tactic
| `(tactic| choose $[!%$b]? $[$ids]* $[using $h]?) => withMainContext do
  let h ← h.mapM (Elab.Tactic.elabTerm · none)
  let g ← elabChoose b.isSome h ids.toList (.failure []) (← getMainGoal)
  replaceMainGoal [g]

@[inherit_doc choose]
syntax "choose!" (colGt binderIdent)+ (" using " term)? : tactic
macro_rules
  | `(tactic| choose! $[$ids]* $[using $h]?) => `(tactic| choose ! $[$ids]* $[using $h]?)


/-
Copyright (c) 2017 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Stephen Morgan, Scott Morrison, Floris van Doorn

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

/-!
# Discrete categories

We define `Discrete α` as a structure containing a term `a : α` for any type `α`,
and use this type alias to provide a `SmallCategory` instance
whose only morphisms are the identities.

There is an annoying technical difficulty that it has turned out to be inconvenient
to allow categories with morphisms living in `Prop`,
so instead of defining `X ⟶ Y` in `Discrete α` as `X = Y`,
one might define it as `PLift (X = Y)`.
In fact, to allow `Discrete α` to be a `SmallCategory`
(i.e. with morphisms in the same universe as the objects),
we actually define the hom type `X ⟶ Y` as `ULift (PLift (X = Y))`.

`Discrete.functor` promotes a function `f : I → C` (for any category `C`) to a functor
`Discrete.functor f : Discrete I ⥤ C`.

Similarly, `Discrete.natTrans` and `Discrete.natIso` promote `I`-indexed families of morphisms,
or `I`-indexed families of isomorphisms to natural transformations or natural isomorphism.

We show equivalences of types are the same as (categorical) equivalences of the corresponding
discrete categories.
-/

namespace CategoryTheory

-- morphism levels before object levels. See note [CategoryTheory universes].
universe v₁ v₂ v₃ u₁ u₁' u₂ u₃

-- This is intentionally a structure rather than a type synonym
-- to enforce using `DiscreteEquiv` (or `Discrete.mk` and `Discrete.as`) to move between
-- `Discrete α` and `α`. Otherwise there is too much API leakage.
/-- A wrapper for promoting any type to a category,
with the only morphisms being equalities.
-/
@[ext]
structure Discrete (α : Type u₁) where
  /-- A wrapper for promoting any type to a category,
  with the only morphisms being equalities.
  -/
  as : α
#align category_theory.discrete CategoryTheory.Discrete

@[simp]
theorem Discrete.mk_as {α : Type u₁} (X : Discrete α) : Discrete.mk X.as = X := by
  ext
  rfl
#align category_theory.discrete.mk_as CategoryTheory.Discrete.mk_as

/-- `Discrete α` is equivalent to the original type `α`.-/
@[simps]
def discreteEquiv {α : Type u₁} : Discrete α ≃ α where
  toFun := Discrete.as
  invFun := Discrete.mk
  left_inv := by aesop_cat
  right_inv := by aesop_cat
#align category_theory.discrete_equiv CategoryTheory.discreteEquiv

instance {α : Type u₁} [DecidableEq α] : DecidableEq (Discrete α) :=
  discreteEquiv.decidableEq

/-- The "Discrete" category on a type, whose morphisms are equalities.

Because we do not allow morphisms in `Prop` (only in `Type`),
somewhat annoyingly we have to define `X ⟶ Y` as `ULift (PLift (X = Y))`.

See <https://stacks.math.columbia.edu/tag/001A>
-/
instance discreteCategory (α : Type u₁) : SmallCategory (Discrete α) where
  Hom X Y := ULift (PLift (X.as = Y.as))
  id X := ULift.up (PLift.up rfl)
  comp {X Y Z} g f := by
    cases X
    cases Y
    cases Z
    rcases f with ⟨⟨⟨⟩⟩⟩
    exact g
#align category_theory.discrete_category CategoryTheory.discreteCategory

namespace Discrete

variable {α : Type u₁}

instance [Inhabited α] : Inhabited (Discrete α) :=
  ⟨⟨default⟩⟩

instance [Subsingleton α] : Subsingleton (Discrete α) :=
  ⟨by
    intros
    ext
    apply Subsingleton.elim⟩

instance (X Y : Discrete α) : Subsingleton (X ⟶ Y) :=
  show Subsingleton (ULift (PLift _)) from inferInstance

/-
Porting note: It seems that `aesop` currently has no way to add lemmas locally.

attribute [local tidy] tactic.discrete_cases
`[cases_matching* [discrete _, (_ : discrete _) ⟶ (_ : discrete _), PLift _]]
-/

/- Porting note: rewrote `discrete_cases` tactic -/
/-- A simple tactic to run `cases` on any `discrete α` hypotheses. -/
macro "discrete_cases": tactic =>
  `(tactic|casesm* Discrete _, (_ : Discrete _) ⟶ (_ : Discrete _), PLift _)

instance [Unique α] : Unique (Discrete α) :=
  Unique.mk' (Discrete α)

/-- Extract the equation from a morphism in a discrete category. -/
theorem eq_of_hom {X Y : Discrete α} (i : X ⟶ Y) : X.as = Y.as :=
  i.down.down
#align category_theory.discrete.eq_of_hom CategoryTheory.Discrete.eq_of_hom

/-- Promote an equation between the wrapped terms in `X Y : Discrete α` to a morphism `X ⟶ Y`
in the discrete category. -/
protected abbrev eqToHom {X Y : Discrete α} (h : X.as = Y.as) : X ⟶ Y :=
  eqToHom
    (by
      ext
      exact h)
#align category_theory.discrete.eq_to_hom CategoryTheory.Discrete.eqToHom

/-- Promote an equation between the wrapped terms in `X Y : Discrete α` to an isomorphism `X ≅ Y`
in the discrete category. -/
protected abbrev eqToIso {X Y : Discrete α} (h : X.as = Y.as) : X ≅ Y :=
  eqToIso
    (by
      ext
      exact h)
#align category_theory.discrete.eq_to_iso CategoryTheory.Discrete.eqToIso

/-- A variant of `eqToHom` that lifts terms to the discrete category. -/
abbrev eqToHom' {a b : α} (h : a = b) : Discrete.mk a ⟶ Discrete.mk b :=
  Discrete.eqToHom h
#align category_theory.discrete.eq_to_hom' CategoryTheory.Discrete.eqToHom'

/-- A variant of `eqToIso` that lifts terms to the discrete category. -/
abbrev eqToIso' {a b : α} (h : a = b) : Discrete.mk a ≅ Discrete.mk b :=
  Discrete.eqToIso h
#align category_theory.discrete.eq_to_iso' CategoryTheory.Discrete.eqToIso'

@[simp]
theorem id_def (X : Discrete α) : ULift.up (PLift.up (Eq.refl X.as)) = 𝟙 X :=
  rfl
#align category_theory.discrete.id_def CategoryTheory.Discrete.id_def

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

instance {I : Type u₁} {i j : Discrete I} (f : i ⟶ j) : IsIso f :=
  ⟨⟨Discrete.eqToHom (eq_of_hom f).symm, by aesop_cat⟩⟩

/-- Any function `I → C` gives a functor `Discrete I ⥤ C`.-/
def functor {I : Type u₁} (F : I → C) : Discrete I ⥤ C where
  obj := F ∘ Discrete.as
  map {X Y} f := by
    dsimp
    rcases f with ⟨⟨h⟩⟩
    exact eqToHom (congrArg _ h)
  map_id := by aesop_cat
  map_comp := fun {X Y Z} f g => by
    discrete_cases
    aesop_cat
#align category_theory.discrete.functor CategoryTheory.Discrete.functor

@[simp]
theorem functor_obj {I : Type u₁} (F : I → C) (i : I) :
    (Discrete.functor F).obj (Discrete.mk i) = F i :=
  rfl
#align category_theory.discrete.functor_obj CategoryTheory.Discrete.functor_obj

theorem functor_map {I : Type u₁} (F : I → C) {i : Discrete I} (f : i ⟶ i) :
    (Discrete.functor F).map f = 𝟙 (F i.as) := by aesop_cat
#align category_theory.discrete.functor_map CategoryTheory.Discrete.functor_map

/-- The discrete functor induced by a composition of maps can be written as a
composition of two discrete functors.
-/
@[simps!]
def functorComp {I : Type u₁} {J : Type u₁'} (f : J → C) (g : I → J) :
    Discrete.functor (f ∘ g) ≅ Discrete.functor (Discrete.mk ∘ g) ⋙ Discrete.functor f :=
  NatIso.ofComponents (fun X => Iso.refl _) (by aesop_cat)
#align category_theory.discrete.functor_comp CategoryTheory.Discrete.functorComp

/-- For functors out of a discrete category,
a natural transformation is just a collection of maps,
as the naturality squares are trivial.
-/
@[simps]
def natTrans {I : Type u₁} {F G : Discrete I ⥤ C} (f : ∀ i : Discrete I, F.obj i ⟶ G.obj i) : F ⟶ G
    where
  app := f
  naturality := fun {X Y} ⟨⟨g⟩⟩ => by
    discrete_cases
    rcases g
    change F.map (𝟙 _) ≫ _ = _ ≫ G.map (𝟙 _)
    simp
#align category_theory.discrete.nat_trans CategoryTheory.Discrete.natTrans

/-- For functors out of a discrete category,
a natural isomorphism is just a collection of isomorphisms,
as the naturality squares are trivial.
-/
@[simps!]
def natIso {I : Type u₁} {F G : Discrete I ⥤ C} (f : ∀ i : Discrete I, F.obj i ≅ G.obj i) : F ≅ G :=
  NatIso.ofComponents f fun ⟨⟨g⟩⟩ => by
    discrete_cases
    rcases g
    change F.map (𝟙 _) ≫ _ = _ ≫ G.map (𝟙 _)
    simp
#align category_theory.discrete.nat_iso CategoryTheory.Discrete.natIso

@[simp]
theorem natIso_app {I : Type u₁} {F G : Discrete I ⥤ C} (f : ∀ i : Discrete I, F.obj i ≅ G.obj i)
    (i : Discrete I) : (Discrete.natIso f).app i = f i := by aesop_cat
#align category_theory.discrete.nat_iso_app CategoryTheory.Discrete.natIso_app

/-- Every functor `F` from a discrete category is naturally isomorphic (actually, equal) to
  `discrete.functor (F.obj)`. -/
@[simp]
def natIsoFunctor {I : Type u₁} {F : Discrete I ⥤ C} : F ≅ Discrete.functor (F.obj ∘ Discrete.mk) :=
  natIso fun _ => Iso.refl _
#align category_theory.discrete.nat_iso_functor CategoryTheory.Discrete.natIsoFunctor

/-- Composing `discrete.functor F` with another functor `G` amounts to composing `F` with `G.obj` -/
@[simp]
def compNatIsoDiscrete {I : Type u₁} {D : Type u₃} [Category.{v₃} D] (F : I → C) (G : C ⥤ D) :
    Discrete.functor F ⋙ G ≅ Discrete.functor (G.obj ∘ F) :=
  natIso fun _ => Iso.refl _
#align category_theory.discrete.comp_nat_iso_discrete CategoryTheory.Discrete.compNatIsoDiscrete

/-- We can promote a type-level `Equiv` to
an equivalence between the corresponding `discrete` categories.
-/
@[simps]
def equivalence {I : Type u₁} {J : Type u₂} (e : I ≃ J) : Discrete I ≌ Discrete J where
  functor := Discrete.functor (Discrete.mk ∘ (e : I → J))
  inverse := Discrete.functor (Discrete.mk ∘ (e.symm : J → I))
  unitIso :=
    Discrete.natIso fun i =>
      eqToIso
        (by
          discrete_cases
          simp)
  counitIso :=
    Discrete.natIso fun j =>
      eqToIso
        (by
          discrete_cases
          simp)
#align category_theory.discrete.equivalence CategoryTheory.Discrete.equivalence

/-- We can convert an equivalence of `discrete` categories to a type-level `Equiv`. -/
@[simps]
def equivOfEquivalence {α : Type u₁} {β : Type u₂} (h : Discrete α ≌ Discrete β) : α ≃ β where
  toFun := Discrete.as ∘ h.functor.obj ∘ Discrete.mk
  invFun := Discrete.as ∘ h.inverse.obj ∘ Discrete.mk
  left_inv a := by simpa using eq_of_hom (h.unitIso.app (Discrete.mk a)).2
  right_inv a := by simpa using eq_of_hom (h.counitIso.app (Discrete.mk a)).1
#align category_theory.discrete.equiv_of_equivalence CategoryTheory.Discrete.equivOfEquivalence

end Discrete

namespace Discrete

variable {J : Type v₁}

open Opposite

/-- A discrete category is equivalent to its opposite category. -/
@[simps! functor_obj_as inverse_obj]
protected def opposite (α : Type u₁) : (Discrete α)ᵒᵖ ≌ Discrete α :=
  let F : Discrete α ⥤ (Discrete α)ᵒᵖ := Discrete.functor fun x => op (Discrete.mk x)
  Equivalence.mk F.leftOp F
  (NatIso.ofComponents (fun ⟨X⟩ => Iso.refl _) <| fun {X Y} ⟨⟨f⟩⟩ => by
      induction X using Opposite.rec
      induction Y using Opposite.rec
      discrete_cases
      rcases f
      aesop_cat)
  (Discrete.natIso <| fun ⟨X⟩ => Iso.refl _)

/-
  Porting note:
  The following is what was generated by mathport:

  refine'
    Equivalence.mk (F.leftOp) F _
      (Discrete.natIso fun X =>
        by
          discrete_cases
          rfl)
  refine'
    NatIso.ofComponents
      (fun X =>
        by
        discrete_cases
        induction X using Opposite.rec
        discrete_cases
        exact Iso.refl _)
-/

#align category_theory.discrete.opposite CategoryTheory.Discrete.opposite

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

@[simp]
theorem functor_map_id (F : Discrete J ⥤ C) {j : Discrete J} (f : j ⟶ j) : F.map f = 𝟙 (F.obj j) :=
  by
  have h : f = 𝟙 j := by
    rcases f with ⟨⟨f⟩⟩
    rfl
  rw [h]
  simp
#align category_theory.discrete.functor_map_id CategoryTheory.Discrete.functor_map_id

end Discrete

end CategoryTheory


import lib.list.defs

variables {α : Type*} {R : α → α → α → Prop}

namespace list

theorem chain3_split {a b c d : α} {l1 l2 : list α} :
  chain3 R a b (l1 ++ c :: d :: l2) ↔
  chain3 R a b (l1 ++ [c, d]) ∧ chain3 R c d l2 :=
by induction l1 with x l1 IH generalizing a b;
  simp only [*, nil_append, cons_append, chain3.nil, chain3_cons, and_true, and_assoc]

@[simp] theorem chain3_append_cons3 {a b c d e : α} {l1 l2 : list α} :
  chain3 R a b (l1 ++ c :: d :: e :: l2) ↔
  chain3 R a b (l1 ++ [c, d]) ∧ R c d e ∧
  chain3 R d e l2 :=
by rw [chain3_split, chain3_cons]

@[simp] theorem chain3'_nil : chain3' R [] := trivial

@[simp] theorem chain3'_singleton (a : α) : chain3' R [a] := trivial

@[simp] theorem chain3'_pair (a b : α) : chain3' R [a, b] := chain3.nil

@[simp] theorem chain3'_cons {x y z l} :
  chain3' R (x :: y :: z :: l) ↔ R x y z ∧ chain3' R (y :: z :: l) :=
chain3_cons

theorem chain3'_split {a b : α}: ∀ {l1 l2 : list α},
  chain3' R (l1 ++ a :: b :: l2) ↔
  chain3' R (l1 ++ [a, b]) ∧ chain3' R (a :: b :: l2)
| [] l2 := (and_iff_right (chain3'_pair a b)).symm
| [c] l2 := by simp -- todo
| (c :: d :: l1) l2 := chain3_split

@[simp] theorem chain3'_append_cons3 {a b c : α} {l1 l2 : list α} :
  chain3' R (l1 ++ a :: b :: c :: l2) ↔
  chain3' R (l1 ++ [a, b]) ∧ R a b c ∧
  chain3' R (b :: c :: l2) :=
by rw [chain3'_split, chain3'_cons]

theorem chain3'.left_of_append {l1 l2 : list α}
  (h : chain3' R (l1 ++ l2)) : chain3' R l1 :=
begin
  induction l1 with a l1 ih, simp,
  cases l1 with b l1, simp,
  cases l1 with c l1, simp,
  simp at ⊢ h, tauto,
end

theorem chain3'.right_of_append {l1 l2 : list α}
  (h : chain3' R (l1 ++ l2)) : chain3' R l2 :=
begin
  revert l2,
  induction l1 with a l1 ih, intros l2 h', exact h',
  intros l2 h',
  cases l1 with b l1,
  { cases l2 with c l2, simp,
    cases l2 with d l2, simp,
    simp at h', exact h'.right, },
  cases l1 with c l1,
  { cases l2 with d l2, simp,
    cases l2 with e l2, simp,
    simp at h', exact h'.right.right, },
  apply ih, simp at ⊢ h', exact h'.right,
end

theorem chain3'.infix {l₁ l : list α }
  (h : chain3' R l) (h' : l₁ <:+: l) : chain3' R l₁ :=
by { rcases h' with ⟨l₂, l₃, rfl⟩, exact h.left_of_append.right_of_append }

theorem chain3'.suffix
  {l₁ l : list α} (h : chain3' R l) (h' : l₁ <:+ l) : chain3' R l₁ :=
  h.infix h'.is_infix

theorem chain3'.prefix
  {l₁ l : list α} (h : chain3' R l) (h' : l₁ <+: l) : chain3' R l₁ :=
  h.infix h'.is_infix

theorem chain3'.drop
  {l : list α} (h : chain3' R l) (n : ℕ) : chain3' R (drop n l) :=
  h.suffix (drop_suffix _ _)

theorem chain3'.init
  {l : list α} (h : chain3' R l) : chain3' R l.init :=
  h.prefix l.init_prefix

theorem chain3'.take
  {l : list α} (h : chain3' R l) (n : ℕ) : chain3' R (take n l) :=
  h.prefix (take_prefix _ _)

theorem chain3'.tail
  {l : list α} (h : chain3' R l) : chain3' R l.tail :=
begin
  cases l with a l, simp,
  cases l with b l, simp,
  cases l with c l, simp,
  simp at ⊢ h, exact h.right,
end

theorem chain3'_mirror [linear_order α] {l : list α} :
  chain3' (mirror3 R) l.mirror ↔ chain3' R l :=
begin
  induction l with a l ih, simp,
  cases l with b l, simp,
  cases l with c l,
  rw list.mirror, simp,
  rw list.mirror, simp,
  simp [list.mirror] at ih, rw ←ih,
  rw mirror3, simp, exact and.comm
end

end list


import tactic

universes u

@[notation_class] class has_succ (α : Sort*) := (succ : α → α)

prefix `Succ `:85 := has_succ.succ

def numeral {α : Type*} [has_zero α] [has_succ α] : ℕ → α
| 0       := 0
| (n + 1) := Succ (numeral n)

instance numeral_has_one {α : Type*} [has_zero α] [has_succ α] : has_one α := ⟨Succ 0⟩

lemma numeral_one_def  {α : Type*} [has_zero α] [has_succ α] : (1 : α) = Succ 0 := rfl

@[notation_class] class has_eq (α : out_param (Sort*)) (β : Sort*) := (eq : α → α → β)

@[notation_class] class has_prec (α : out_param (Sort*)) (β : Sort*) := (prec : α → α → β)

@[notation_class] class has_preceq (α : out_param (Sort*)) (β : Sort*) := (preceq : α → α → β)

@[notation_class] class has_elem (α : out_param (Sort*)) (β : Sort*) := (elem : α → α → β)

@[notation_class] class has_negation (α : Sort*) := (neg : α → α)

@[notation_class] class has_arrow (α : Sort*) := (arrow : α → α → α)

@[notation_class] class has_univ_quantifier (α : Sort*) := (univ : α → α)

@[notation_class] class has_exists_quantifier (α : Sort*) := (ex : α → α)

@[notation_class] class has_univ_quantifier' (α : ℕ → Sort*) := (univ : Π {n}, α (n + 1) → α n)

@[notation_class] class has_exists_quantifier' (α : ℕ → Sort*) := (ex : Π {n}, α (n + 1) → α n)

localized "infix (name := has_eq.eq) ` =' `:50 := has_eq.eq" in logic_symbol
localized "infix (name := has_prec.prec) ` ≺ `:50 := has_prec.prec" in logic_symbol
localized "infix (name := has_preceq.preceq) ` ≼ `:50 := has_preceq.preceq" in logic_symbol
localized "infix (name := has_elem.elem) ` ∊ `:50 := has_elem.elem" in logic_symbol
localized "prefix (name := has_negation.neg) `∼`:75 := has_negation.neg" in logic_symbol
localized "infixr (name := has_arrow.arrow) ` ⟶ `:60 := has_arrow.arrow" in logic_symbol
localized "prefix (name := has_univ_quantifier.univ) `∀.`:64 := has_univ_quantifier.univ" in logic_symbol
localized "prefix (name := has_exists_quantifier.ex) `∃.`:64 := has_exists_quantifier.ex" in logic_symbol
localized "prefix (name := has_univ_quantifier'.univ) `∀'`:64 := has_univ_quantifier'.univ" in logic_symbol
localized "prefix (name := has_exists_quantifier'.ex) `∃'`:64 := has_exists_quantifier'.ex" in logic_symbol
open_locale logic_symbol

section has_univ_quantifier'
variables  {α : ℕ → Sort*} [has_univ_quantifier' α]

def nforall {n} : Π (k), α (n + k) → α n
| 0     a := a
| (k+1) a := nforall _ ∀'a

@[simp] def universal_closure : Π {n}, α n → α 0
| 0     a := a
| (k+1) a := universal_closure ∀'a

localized "notation (name := universal_closure) `∀'*`:64 := universal_closure" in logic_symbol

end has_univ_quantifier'

section has_exists_quantifier'
variables {α : ℕ → Sort*} [has_exists_quantifier' α]

def nexists {n} : Π (k), α (n + k) → α n
| 0     a := a
| (k+1) a := nexists _ ∃'a

@[simp] def exists_close : Π {n}, α n → α 0
| 0     a := a
| (k+1) a := exists_close ∃'a

localized "notation (name := exists_close) `∃'*`:64 := exists_close" in logic_symbol

end has_exists_quantifier'

@[reducible] def has_eq.ineq {α : out_param (Sort*)} {β : Sort*}
  [has_eq α β] [has_negation β] (a b : α) : β := ∼(a =' b)

localized "infix (name := has_eq.ineq) ` ≠' `:50 := has_eq.ineq" in logic_symbol

@[notation_class] class has_turnstile (α : Sort*) := (turnstile : set α → α → Prop)

infix ` ⊢ `:45 := has_turnstile.turnstile
notation T ` ⊢{`:45 β `} `:45 p := has_turnstile.turnstile T β p

namespace has_turnstile
variables {α : Type*} [has_turnstile α]

def turnstile_set (T : set α) (Γ : set α) : Prop := ∀ p ∈ Γ, T ⊢ p

infix ` ⊢* `:45 := turnstile_set

end has_turnstile

@[notation_class] class has_Longarrow (α : Sort*) := (Longarrow : set α → α → Type u)

infix ` ⟹ `:45 := has_Longarrow.Longarrow

def has_arrow.lrarrow {α : Type*} [has_arrow α] [has_inf α] (a b : α) : α := (a ⟶ b) ⊓ (b ⟶ a)

localized "infix (name := has_arrow.lrarrow) ` ⟷ `:59 := has_arrow.lrarrow" in logic_symbol

lemma lrarrow_def {α : Type*} [has_arrow α] [has_inf α] (a b : α) : a ⟷ b = (a ⟶ b) ⊓ (b ⟶ a) := rfl

@[notation_class] class has_double_turnstile (α : Sort*) (β : Sort*) := (double_turnstile : α → β → Prop)

infix ` ⊧ ` :55 := has_double_turnstile.double_turnstile

namespace has_double_turnstile
variables {α : Type*} {β : Type*} [has_double_turnstile α β]

def double_turnstile_set (T : α) (S : set β) : Prop := ∀ p ∈ S, T ⊧ p

infix ` ⊧* `:45 := double_turnstile_set

end has_double_turnstile

class has_logic_symbol (F : Sort*)
  extends has_negation F, has_arrow F, has_inf F, has_sup F, has_top F, has_bot F

section
variables (F : Type*) (top : F) (neg : F → F) (imply : F → F → F)

def logic_simbol_default (F : Type*) (top : F) (neg : F → F) (imply : F → F → F) : has_logic_symbol F :=
{ bot := neg top,
  top := top,
  sup := λ p q, imply (neg p) q,
  inf := λ p q, neg (imply p (neg q)),
  arrow := imply,
  neg := neg }

lemma default_bot_def :
  @has_bot.bot F (@has_logic_symbol.to_has_bot F (logic_simbol_default F top neg imply)) =
  @has_negation.neg F (@has_logic_symbol.to_has_negation F (logic_simbol_default F top neg imply))
    (@has_top.top F (@has_logic_symbol.to_has_top F (logic_simbol_default F top neg imply))) := rfl

lemma default_top_def :
  @has_top.top F (@has_logic_symbol.to_has_top F (logic_simbol_default F top neg imply)) = top := rfl

lemma default_or_def (p q : F) :
  @has_sup.sup F (@has_logic_symbol.to_has_sup F (logic_simbol_default F top neg imply)) p q =
  @has_arrow.arrow F (@has_logic_symbol.to_has_arrow F (logic_simbol_default F top neg imply))
    (@has_negation.neg F (@has_logic_symbol.to_has_negation F (logic_simbol_default F top neg imply)) p) q := rfl

lemma default_and_def (p q : F) :
  @has_inf.inf F (@has_logic_symbol.to_has_inf F (logic_simbol_default F top neg imply)) p q =
  @has_negation.neg F (@has_logic_symbol.to_has_negation F (logic_simbol_default F top neg imply))
    (@has_arrow.arrow F (@has_logic_symbol.to_has_arrow F (logic_simbol_default F top neg imply))
      p (@has_negation.neg F (@has_logic_symbol.to_has_negation F (logic_simbol_default F top neg imply)) q)) := rfl

lemma default_imply_def (p q : F) :
  @has_arrow.arrow F (@has_logic_symbol.to_has_arrow F (logic_simbol_default F top neg imply)) p q = imply p q := rfl

lemma default_neg_def (p : F) :
  @has_negation.neg F (@has_logic_symbol.to_has_negation F (logic_simbol_default F top neg imply)) p = neg p := rfl

end

-- Tait formula
namespace Tait

variables (F : Type*) (top : F) (bot : F) (neg : F → F) (and : F → F → F) (or : F → F → F)

@[reducible] def logic_simbol_default : has_logic_symbol F :=
{ bot := bot,
  top := top,
  sup := or,
  inf := and,
  arrow := λ p q, or (neg p) q,
  neg := neg }

lemma default_imply_def (p q) :
  @has_arrow.arrow F (@has_logic_symbol.to_has_arrow F (logic_simbol_default F top bot neg and or)) p q =
  @has_sup.sup F (@has_logic_symbol.to_has_sup F (logic_simbol_default F top bot neg and or))
    (@has_negation.neg F (@has_logic_symbol.to_has_negation F (logic_simbol_default F top bot neg and or)) p)
    q := rfl

end Tait


/-
Copyright (c) 2018 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Scott Morrison
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.category_theory.natural_isomorphism
import Mathlib.PostPort

universes u₁ u₂ u₃ v₁ v₂ v₃ u₄ v₄ u₅ v₅

namespace Mathlib

namespace category_theory

/--
If `α : G ⟶ H` then
`whisker_left F α : (F ⋙ G) ⟶ (F ⋙ H)` has components `α.app (F.obj X)`.
-/
@[simp] theorem whisker_left_app {C : Type u₁} [category C] {D : Type u₂} [category D] {E : Type u₃} [category E] (F : C ⥤ D) {G : D ⥤ E} {H : D ⥤ E} (α : G ⟶ H) (X : C) : nat_trans.app (whisker_left F α) X = nat_trans.app α (functor.obj F X) :=
  Eq.refl (nat_trans.app (whisker_left F α) X)

/--
If `α : G ⟶ H` then
`whisker_right α F : (G ⋙ F) ⟶ (G ⋙ F)` has components `F.map (α.app X)`.
-/
def whisker_right {C : Type u₁} [category C] {D : Type u₂} [category D] {E : Type u₃} [category E] {G : C ⥤ D} {H : C ⥤ D} (α : G ⟶ H) (F : D ⥤ E) : G ⋙ F ⟶ H ⋙ F :=
  nat_trans.mk fun (X : C) => functor.map F (nat_trans.app α X)

/--
Left-composition gives a functor `(C ⥤ D) ⥤ ((D ⥤ E) ⥤ (C ⥤ E))`.

`(whiskering_lift.obj F).obj G` is `F ⋙ G`, and
`(whiskering_lift.obj F).map α` is `whisker_left F α`.
-/
def whiskering_left (C : Type u₁) [category C] (D : Type u₂) [category D] (E : Type u₃) [category E] : (C ⥤ D) ⥤ (D ⥤ E) ⥤ C ⥤ E :=
  functor.mk (fun (F : C ⥤ D) => functor.mk (fun (G : D ⥤ E) => F ⋙ G) fun (G H : D ⥤ E) (α : G ⟶ H) => whisker_left F α)
    fun (F G : C ⥤ D) (τ : F ⟶ G) =>
      nat_trans.mk fun (H : D ⥤ E) => nat_trans.mk fun (c : C) => functor.map H (nat_trans.app τ c)

/--
Right-composition gives a functor `(D ⥤ E) ⥤ ((C ⥤ D) ⥤ (C ⥤ E))`.

`(whiskering_right.obj H).obj F` is `F ⋙ H`, and
`(whiskering_right.obj H).map α` is `whisker_right α H`.
-/
@[simp] theorem whiskering_right_obj_map (C : Type u₁) [category C] (D : Type u₂) [category D] (E : Type u₃) [category E] (H : D ⥤ E) (_x : C ⥤ D) : ∀ (_x_1 : C ⥤ D) (α : _x ⟶ _x_1), functor.map (functor.obj (whiskering_right C D E) H) α = whisker_right α H :=
  fun (_x_1 : C ⥤ D) (α : _x ⟶ _x_1) => Eq.refl (functor.map (functor.obj (whiskering_right C D E) H) α)

@[simp] theorem whisker_left_id {C : Type u₁} [category C] {D : Type u₂} [category D] {E : Type u₃} [category E] (F : C ⥤ D) {G : D ⥤ E} : whisker_left F (nat_trans.id G) = nat_trans.id (F ⋙ G) :=
  rfl

@[simp] theorem whisker_left_id' {C : Type u₁} [category C] {D : Type u₂} [category D] {E : Type u₃} [category E] (F : C ⥤ D) {G : D ⥤ E} : whisker_left F 𝟙 = 𝟙 :=
  rfl

@[simp] theorem whisker_right_id {C : Type u₁} [category C] {D : Type u₂} [category D] {E : Type u₃} [category E] {G : C ⥤ D} (F : D ⥤ E) : whisker_right (nat_trans.id G) F = nat_trans.id (G ⋙ F) :=
  functor.map_id (functor.obj (whiskering_right C D E) F) G

@[simp] theorem whisker_right_id' {C : Type u₁} [category C] {D : Type u₂} [category D] {E : Type u₃} [category E] {G : C ⥤ D} (F : D ⥤ E) : whisker_right 𝟙 F = 𝟙 :=
  functor.map_id (functor.obj (whiskering_right C D E) F) G

@[simp] theorem whisker_left_comp {C : Type u₁} [category C] {D : Type u₂} [category D] {E : Type u₃} [category E] (F : C ⥤ D) {G : D ⥤ E} {H : D ⥤ E} {K : D ⥤ E} (α : G ⟶ H) (β : H ⟶ K) : whisker_left F (α ≫ β) = whisker_left F α ≫ whisker_left F β :=
  rfl

@[simp] theorem whisker_right_comp {C : Type u₁} [category C] {D : Type u₂} [category D] {E : Type u₃} [category E] {G : C ⥤ D} {H : C ⥤ D} {K : C ⥤ D} (α : G ⟶ H) (β : H ⟶ K) (F : D ⥤ E) : whisker_right (α ≫ β) F = whisker_right α F ≫ whisker_right β F :=
  functor.map_comp (functor.obj (whiskering_right C D E) F) α β

/--
If `α : G ≅ H` is a natural isomorphism then
`iso_whisker_left F α : (F ⋙ G) ≅ (F ⋙ H)` has components `α.app (F.obj X)`.
-/
def iso_whisker_left {C : Type u₁} [category C] {D : Type u₂} [category D] {E : Type u₃} [category E] (F : C ⥤ D) {G : D ⥤ E} {H : D ⥤ E} (α : G ≅ H) : F ⋙ G ≅ F ⋙ H :=
  functor.map_iso (functor.obj (whiskering_left C D E) F) α

@[simp] theorem iso_whisker_left_hom {C : Type u₁} [category C] {D : Type u₂} [category D] {E : Type u₃} [category E] (F : C ⥤ D) {G : D ⥤ E} {H : D ⥤ E} (α : G ≅ H) : iso.hom (iso_whisker_left F α) = whisker_left F (iso.hom α) :=
  rfl

@[simp] theorem iso_whisker_left_inv {C : Type u₁} [category C] {D : Type u₂} [category D] {E : Type u₃} [category E] (F : C ⥤ D) {G : D ⥤ E} {H : D ⥤ E} (α : G ≅ H) : iso.inv (iso_whisker_left F α) = whisker_left F (iso.inv α) :=
  rfl

/--
If `α : G ≅ H` then
`iso_whisker_right α F : (G ⋙ F) ≅ (G ⋙ F)` has components `F.map_iso (α.app X)`.
-/
def iso_whisker_right {C : Type u₁} [category C] {D : Type u₂} [category D] {E : Type u₃} [category E] {G : C ⥤ D} {H : C ⥤ D} (α : G ≅ H) (F : D ⥤ E) : G ⋙ F ≅ H ⋙ F :=
  functor.map_iso (functor.obj (whiskering_right C D E) F) α

@[simp] theorem iso_whisker_right_hom {C : Type u₁} [category C] {D : Type u₂} [category D] {E : Type u₃} [category E] {G : C ⥤ D} {H : C ⥤ D} (α : G ≅ H) (F : D ⥤ E) : iso.hom (iso_whisker_right α F) = whisker_right (iso.hom α) F :=
  rfl

@[simp] theorem iso_whisker_right_inv {C : Type u₁} [category C] {D : Type u₂} [category D] {E : Type u₃} [category E] {G : C ⥤ D} {H : C ⥤ D} (α : G ≅ H) (F : D ⥤ E) : iso.inv (iso_whisker_right α F) = whisker_right (iso.inv α) F :=
  rfl

protected instance is_iso_whisker_left {C : Type u₁} [category C] {D : Type u₂} [category D] {E : Type u₃} [category E] (F : C ⥤ D) {G : D ⥤ E} {H : D ⥤ E} (α : G ⟶ H) [is_iso α] : is_iso (whisker_left F α) :=
  is_iso.mk (iso.inv (iso_whisker_left F (as_iso α)))

protected instance is_iso_whisker_right {C : Type u₁} [category C] {D : Type u₂} [category D] {E : Type u₃} [category E] {G : C ⥤ D} {H : C ⥤ D} (α : G ⟶ H) (F : D ⥤ E) [is_iso α] : is_iso (whisker_right α F) :=
  is_iso.mk (iso.inv (iso_whisker_right (as_iso α) F))

@[simp] theorem whisker_left_twice {C : Type u₁} [category C] {D : Type u₂} [category D] {E : Type u₃} [category E] {B : Type u₄} [category B] (F : B ⥤ C) (G : C ⥤ D) {H : D ⥤ E} {K : D ⥤ E} (α : H ⟶ K) : whisker_left F (whisker_left G α) = whisker_left (F ⋙ G) α :=
  rfl

@[simp] theorem whisker_right_twice {C : Type u₁} [category C] {D : Type u₂} [category D] {E : Type u₃} [category E] {B : Type u₄} [category B] {H : B ⥤ C} {K : B ⥤ C} (F : C ⥤ D) (G : D ⥤ E) (α : H ⟶ K) : whisker_right (whisker_right α F) G = whisker_right α (F ⋙ G) :=
  rfl

theorem whisker_right_left {C : Type u₁} [category C] {D : Type u₂} [category D] {E : Type u₃} [category E] {B : Type u₄} [category B] (F : B ⥤ C) {G : C ⥤ D} {H : C ⥤ D} (α : G ⟶ H) (K : D ⥤ E) : whisker_right (whisker_left F α) K = whisker_left F (whisker_right α K) :=
  rfl

namespace functor

/--
The left unitor, a natural isomorphism `((𝟭 _) ⋙ F) ≅ F`.
-/
@[simp] theorem left_unitor_hom_app {A : Type u₁} [category A] {B : Type u₂} [category B] (F : A ⥤ B) (X : A) : nat_trans.app (iso.hom (left_unitor F)) X = 𝟙 :=
  Eq.refl (nat_trans.app (iso.hom (left_unitor F)) X)

/--
The right unitor, a natural isomorphism `(F ⋙ (𝟭 B)) ≅ F`.
-/
@[simp] theorem right_unitor_hom_app {A : Type u₁} [category A] {B : Type u₂} [category B] (F : A ⥤ B) (X : A) : nat_trans.app (iso.hom (right_unitor F)) X = 𝟙 :=
  Eq.refl (nat_trans.app (iso.hom (right_unitor F)) X)

/--
The associator for functors, a natural isomorphism `((F ⋙ G) ⋙ H) ≅ (F ⋙ (G ⋙ H))`.

(In fact, `iso.refl _` will work here, but it tends to make Lean slow later,
and it's usually best to insert explicit associators.)
-/
@[simp] theorem associator_inv_app {A : Type u₁} [category A] {B : Type u₂} [category B] {C : Type u₃} [category C] {D : Type u₄} [category D] (F : A ⥤ B) (G : B ⥤ C) (H : C ⥤ D) (_x : A) : nat_trans.app (iso.inv (associator F G H)) _x = 𝟙 :=
  Eq.refl (nat_trans.app (iso.inv (associator F G H)) _x)

theorem triangle {A : Type u₁} [category A] {B : Type u₂} [category B] {C : Type u₃} [category C] (F : A ⥤ B) (G : B ⥤ C) : iso.hom (associator F 𝟭 G) ≫ whisker_left F (iso.hom (left_unitor G)) = whisker_right (iso.hom (right_unitor F)) G := sorry

theorem pentagon {A : Type u₁} [category A] {B : Type u₂} [category B] {C : Type u₃} [category C] {D : Type u₄} [category D] {E : Type u₅} [category E] (F : A ⥤ B) (G : B ⥤ C) (H : C ⥤ D) (K : D ⥤ E) : whisker_right (iso.hom (associator F G H)) K ≫
    iso.hom (associator F (G ⋙ H) K) ≫ whisker_left F (iso.hom (associator G H K)) =
  iso.hom (associator (F ⋙ G) H K) ≫ iso.hom (associator F G (H ⋙ K)) := sorry


import tactic order.zorn

namespace tukey
variables {α : Type*} {F : set α → Prop}

def finite_charactor (P : set α → Prop) : Prop := ∀ a, P a ↔ (∀ s ⊆ a, s.finite → P s)

lemma of_ss (H : finite_charactor F) {a} (ha : F a) {b} (ss : b ⊆ a) : F b :=
begin
  have : ∀ s ⊆ a, s.finite → F s, from (H a).mp ha,
  have : ∀ s ⊆ b, s.finite → F s,
  { intros s hs s_fin, exact this s (set.subset.trans hs ss) s_fin },
  exact (H b).mpr this
end

lemma empty_of_nonempty (H : finite_charactor F) {a} (ha : F a) : F ∅ :=
of_ss H ha (by simp)

lemma finite_chain_sup (H : finite_charactor F) {c : set (set α)} (ch : is_chain has_subset.subset c) :
  ∀ {d : set (set α)} (hs : d.finite) (nemp : d.nonempty) (ss : d ⊆ c), ∃ m ∈ d, ⋃₀d ⊆ m :=
begin
  intros d d_fin,
  refine set.finite.induction_on d_fin (by simp) _,
  intros a s ha s_fin IH _ ss,
  by_cases nemp : s.nonempty,
  { have : ∃ (m ∈ s), ⋃₀ s ⊆ m, from IH nemp (set.subset.trans (by simp) ss),
    rcases this with ⟨m, mem, hs⟩,
    have : m ⊆ a ∨ a ⊆ m, from is_chain.total ch (show m ∈ c, from ss (by simp[mem])) (show a ∈ c, from ss (by simp)),
    rcases this,
    { refine ⟨a, by simp, _⟩,
      simp at hs ⊢, refine ⟨by refl, λ t ht, set.subset.trans (hs t ht) this⟩ },
    { refine ⟨m, by simp[mem], _⟩,
      simp at hs ⊢, refine ⟨this, hs⟩ } },
  { have : s = ∅, from set.not_nonempty_iff_eq_empty.mp nemp, rcases this with rfl,
    refine ⟨a, by simp⟩ }
end

theorem exists_maximum (H : finite_charactor F) (a : set α) (ha : F a) :
  ∃ m, F m ∧ a ⊆ m ∧ ∀ s, F s → m ⊆ s → s = m :=
begin
  suffices : ∃ (m : set α) (H : m ∈ {x : set α | F x}),
  a ⊆ m ∧ ∀ (a : set α), a ∈ {x : set α | F x} → m ⊆ a → a = m,
  { simp at this, exact this },
  refine zorn_subset_nonempty {x | F x} _ a ha, simp,
  rintros c hF hc nemp,
  have : F (⋃₀ c),
  { have : ∀ s ⊆ ⋃₀ c, s.finite → F s,
    { rw[set.sUnion_eq_Union], intros s s_ss s_fin,
      have : ∃ (d : set (set α)), d ⊆ c ∧ d.finite ∧ s ⊆ ⋃₀ d,
      { rcases set.finite_subset_Union s_fin s_ss with ⟨I, I_fin, s_ss⟩,  simp at s_ss,
        refine ⟨coe '' I, by simp, set.finite.image coe I_fin, by simpa using s_ss⟩ },
      rcases this with ⟨d, d_ss, d_fin, hs⟩,
      by_cases d_nemp : d.nonempty,
      { have : ∃ m ∈ d, ⋃₀d ⊆ m, from finite_chain_sup H hc d_fin d_nemp d_ss,
        rcases this with ⟨m, m_mem, ss_m⟩,
        exact of_ss H (show F m, from hF (d_ss m_mem)) (show s ⊆ m, from set.subset.trans hs ss_m) },
      { have : d = ∅, from set.not_nonempty_iff_eq_empty.mp d_nemp, rcases this with rfl,
        simp at hs, have : s = ∅, exact set.subset_eq_empty hs rfl, rcases this with rfl,
        rcases set.nonempty_def.mp nemp with ⟨x, hx⟩, refine empty_of_nonempty H (hF hx) } },
    refine (H (⋃₀ c)).mpr this },
  refine ⟨⋃₀ c, this, λ _, set.subset_sUnion_of_mem⟩
end

end tukey


import condensed.top_comparison
import condensed.filtered_colimits
import condensed.adjunctions
import for_mathlib.pow_functor
import for_mathlib.nat_trans

open category_theory
open category_theory.limits

namespace CondensedSet

universes u

variables {J K : Type (u+1)} [small_category J] [small_category K]
  [fin_category K] (F : K ⥤ J ⥤ CondensedSet.{u})

noncomputable
def colim_to_lim :
  colimit (limit F) ⟶ limit (colimit F.flip) :=
colimit.desc (limit F) ⟨limit (colimit F.flip),
{ app := λ j, limit.lift (colimit F.flip) ⟨(limit F).obj j,
  { app := λ k, (limit.π F k).app j ≫ (colimit.ι F.flip j).app k,
    naturality' := λ X Y f, by begin
      erw [functor.const_obj_map, category.id_comp, category.assoc],
      rw [← nat_trans.naturality, ← category.assoc],
      simp only [functor.flip_obj_map, ← nat_trans.comp_app, limit.w],
    end }⟩,
  naturality' := λ X Y f, begin
    erw [functor.const_obj_map, category.comp_id],
    apply limit.hom_ext, intro k,
    simp only [category.assoc, limit.lift_π, nat_trans.naturality_assoc],
    simp only [← functor.flip_map_app, ← nat_trans.comp_app, colimit.w],
  end }⟩

noncomputable
instance preserves_filtered_colimits :
  preserves_filtered_colimits CondensedSet_to_presheaf.{u} :=
begin
  constructor, introsI J _ _, constructor, intros F,
  apply preserves_colimit_of_preserves_colimit_cocone
    (filtered_cocone_is_colimit F),
  let e : CondensedSet_to_presheaf.map_cocone (filtered_cocone F) ≅ colimit.cocone _ :=
    cocones.ext (iso.refl _) _,
  swap,
  { intros j, dsimp, simpa },
  apply is_colimit.of_iso_colimit _ e.symm,
  exact colimit.is_colimit _,
end

instance full_CondesensedSet_to_presheaf :
  full CondensedSet_to_presheaf :=
show full (Sheaf_to_presheaf _ _), by apply_instance

instance faithful_CondesensedSet_to_presheaf :
  faithful CondensedSet_to_presheaf :=
show faithful (Sheaf_to_presheaf _ _), by apply_instance

noncomputable
instance preserves_limits_CondesensedSet_to_presheaf :
  preserves_limits CondensedSet_to_presheaf :=
adjunction.right_adjoint_preserves_limits CondensedSet_presheaf_adjunction

section

noncomputable theory

-- set_option pp.universes true

def _root_.category_theory.functor.map_limit {C D J : Type*}
  [category C] [category D] [small_category J]
  (G : C ⥤ D) (F : J ⥤ C)
  [has_limit F] [has_limit (F ⋙ G)] [preserves_limit F G] :
  G.obj (limit F) ≅ limit (F ⋙ G) :=
is_limit.cone_point_unique_up_to_iso
  (is_limit_of_preserves G (limit.is_limit _))
  (limit.is_limit _)

@[simp, reassoc]
lemma _root_.category_theory.functor.map_limit_hom_π {J C D : Type*}
  [small_category J] [category C] [category D]
  (G : C ⥤ D) (F : J ⥤ C)
  [has_limit F] [has_limit (F ⋙ G)] [preserves_limit F G]
  (j : J) :
  (G.map_limit F).hom ≫ limit.π (F ⋙ G) j = G.map (limit.π F j) :=
by simp only [category_theory.functor.map_limit, functor.map_cone_π_app,
    limit.cone_point_unique_up_to_iso_hom_comp, limit.cone_π]

def _root_.category_theory.functor.map_colimit {J C D : Type*}
  [small_category J] [category C] [category D]
  (G : C ⥤ D) (F : J ⥤ C)
  [has_colimit F] [has_colimit (F ⋙ G)] [preserves_colimit F G] :
  G.obj (colimit F) ≅ colimit (F ⋙ G) :=
is_colimit.cocone_point_unique_up_to_iso
  (is_colimit_of_preserves G (colimit.is_colimit _))
  (colimit.is_colimit _)

@[simp, reassoc]
lemma _root_.category_theory.functor.ι_map_colimit_inv {J C D : Type*}
  [small_category J] [category C] [category D]
  (G : C ⥤ D) (F : J ⥤ C)
  [has_colimit F] [has_colimit (F ⋙ G)] [preserves_colimit F G]
  (j : J) :
  colimit.ι (F ⋙ G) j ≫ (G.map_colimit F).inv = G.map (colimit.ι F j) :=
by simp only [category_theory.functor.map_colimit, functor.map_cocone_ι_app,
    colimit.comp_cocone_point_unique_up_to_iso_inv, colimit.cocone_ι]

def limit_comp_iso {J K C D : Type*} [small_category J] [small_category K]
  [category C] [category D] [has_limits_of_shape J C] [has_limits_of_shape J D]
  (F : J ⥤ K ⥤ C) (G : C ⥤ D) [has_limit F]
  [H : ∀ k, has_limit (F.flip.obj k)] [∀ k, preserves_limit (F.flip.obj k) G]
  [∀ k, preserves_limit F ((category_theory.evaluation K C).obj k)] :
  limit F ⋙ G ≅ F.flip ⋙ ((whiskering_right _ _ _).obj G) ⋙ lim :=
begin
  refine nat_iso.of_components _ _,
  { intro k,
    refine G.map_iso _ ≪≫ G.map_limit _,
    letI : has_limit (F ⋙ (category_theory.evaluation K C).obj k) := H k,
    refine ((category_theory.evaluation _ _).obj k).map_limit _ ≪≫ _,
    refine limits.lim.map_iso _,
    exact iso.refl _ },
  { intros k₁ k₂ f,
    ext j,
    dsimp,
    simp only [functor.map_comp, category_theory.functor.map_limit_hom_π, category.assoc,
      lim_map_π, whisker_right_app, functor.flip_map_app,
      category_theory.functor.map_limit_hom_π_assoc],
    simp only [← functor.map_comp, category.assoc], congr' 1,
    simp only [lim_map_π, lim_map_π_assoc, category_theory.functor.map_limit_hom_π_assoc,
      category_theory.functor.map_limit_hom_π],
    erw [← evaluation_map_app K C, ← category.assoc, ← nat_trans.naturality],
    erw [nat_trans.id_app, nat_trans.id_app, category.comp_id, category.id_comp],
    refl }
end
.

def colimit_comp_iso {J K C D : Type*} [small_category J] [small_category K]
  [category C] [category D] [has_colimits_of_shape J C] [has_colimits_of_shape J D]
  (F : J ⥤ K ⥤ C) (G : C ⥤ D) [has_colimit F]
  [H : ∀ k, has_colimit (F.flip.obj k)] [∀ k, preserves_colimit (F.flip.obj k) G]
  [∀ k, preserves_colimit F ((category_theory.evaluation K C).obj k)] :
  colimit F ⋙ G ≅ F.flip ⋙ ((whiskering_right _ _ _).obj G) ⋙ colim :=
begin
  refine nat_iso.of_components _ _,
  { intro k,
    refine G.map_iso _ ≪≫ G.map_colimit _,
    letI : has_colimit (F ⋙ (category_theory.evaluation K C).obj k) := H k,
    refine ((category_theory.evaluation _ _).obj k).map_colimit _ ≪≫ _,
    refine colim.map_iso _,
    exact iso.refl _ },
  { intros k₁ k₂ f,
    rw [← iso.inv_comp_eq, ← category.assoc, ← iso.eq_comp_inv],
    ext j,
    dsimp,
    simp only [category.assoc, category_theory.functor.ι_map_colimit_inv_assoc, colimit.ι_map_assoc,
      whisker_right_app, functor.flip_map_app],
    simp only [← functor.map_comp, category.assoc], congr' 1,
    simp only [colimit.ι_map_assoc, category_theory.functor.ι_map_colimit_inv_assoc,
      category_theory.functor.ι_map_colimit_inv],
    rw [← evaluation_map_app K C, nat_trans.naturality],
    erw [nat_trans.id_app, nat_trans.id_app, category.id_comp, category.id_comp],
    refl }
end
.

variables [is_filtered J]

def is_iso_colim_to_lim_component_e₁ (S : Profinite.{u}ᵒᵖ) :
  (colimit (limit F)).val.obj S ≅ colimit (curry.obj (category_theory.prod.swap J K ⋙
    (uncurry.{u+1 u+1}.obj F ⋙
    (CondensedSet_to_presheaf.{u} ⋙ (category_theory.evaluation.{u u+1 u+1 u+2} Profinite.{u}ᵒᵖ (Type (u+1))).obj S))) ⋙ lim) :=
begin
  let VS := CondensedSet_to_presheaf.{u} ⋙ (category_theory.evaluation.{u u+1 u+1 u+2} Profinite.{u}ᵒᵖ (Type (u+1))).obj S,
  refine VS.map_colimit (limit F) ≪≫ _,
  refine colim.map_iso _,
  refine limit_comp_iso _ _ ≪≫ _,
  refine (functor.associator _ _ _).symm ≪≫ _,
  refine ((whiskering_right _ _ _).obj lim).map_iso _,
  refine nat_iso.of_components _ _,
  { intro k, refine nat_iso.of_components (λ j, iso.refl _) _,
    intros i j f, dsimp,
    simp only [category.id_comp, category.comp_id, (F.obj j).map_id, nat_trans.id_app, Sheaf.hom.id_val], },
  { intros k l f, ext j : 2, dsimp,
    simp only [category.id_comp, category.comp_id, F.map_id, nat_trans.id_app, Sheaf.hom.id_val], }
end
.

def is_iso_colim_to_lim_component_e₂ (S : Profinite.{u}ᵒᵖ) :
  (limit (colimit F.flip)).val.obj S ≅
  limit (curry.obj (uncurry.{u+1 u+1}.obj F ⋙
    (CondensedSet_to_presheaf.{u} ⋙ (category_theory.evaluation.{u u+1 u+1 u+2} Profinite.{u}ᵒᵖ (Type (u+1))).obj S)) ⋙ colim) :=
begin
  let VS := CondensedSet_to_presheaf.{u} ⋙ (category_theory.evaluation.{u u+1 u+1 u+2} Profinite.{u}ᵒᵖ (Type (u+1))).obj S,
  refine VS.map_limit (colimit F.flip) ≪≫ _,
  refine limits.lim.map_iso _,
  refine colimit_comp_iso _ _ ≪≫ _,
  refine (functor.associator _ _ _).symm ≪≫ _,
  refine ((whiskering_right _ _ _).obj colim).map_iso _,
  refine nat_iso.of_components _ _,
  { intro k, refine nat_iso.of_components (λ j, iso.refl _) _,
    intros i j f, dsimp,
    simp only [category.id_comp, category.comp_id, F.map_id, nat_trans.id_app, Sheaf.hom.id_val], },
  { intros k l f, ext j : 2, dsimp,
    simp only [category.id_comp, category.comp_id, (F.obj l).map_id, nat_trans.id_app, Sheaf.hom.id_val], }
end
.

local attribute [reassoc] Sheaf.hom.comp_val

lemma is_iso_colim_to_lim_component (S : Profinite.{u}ᵒᵖ) :
  is_iso ((colim_to_lim F).val.app S) :=
begin
  /-
  The forgetful functor to presheaves preserves filtered colimits and all limits,
  while the same holds for evaluation, hence this morphism should be isomorphic to
  `colimit_limit_to_limit_colimit` which is an isomorphism.
  -/
  suffices : (colim_to_lim F).val.app S =
    (is_iso_colim_to_lim_component_e₁ F S).hom ≫ colimit_limit_to_limit_colimit _ ≫ (is_iso_colim_to_lim_component_e₂ F S).inv,
  { rw [this, is_iso_iff_is_iso_comp_left, is_iso_iff_is_iso_comp_right], apply_instance },
  rw [← iso.inv_comp_eq, iso.eq_comp_inv, category.assoc],
  ext j k : 2,
  dsimp [colimit_limit_to_limit_colimit, is_iso_colim_to_lim_component_e₁, is_iso_colim_to_lim_component_e₂],
  simp only [category.assoc, limit.lift_π, colimit.ι_desc, colimit.ι_map_assoc,
    category_theory.functor.ι_map_colimit_inv_assoc,
    category_theory.functor.map_limit_hom_π_assoc,
    lim_map_π, nat_trans.comp_app, whisker_right_app, category.id_comp,
    functor.associator_hom_app, functor.associator_inv_app,
    limit_comp_iso, colimit_comp_iso, iso.trans_hom, iso.trans_inv,
    nat_iso.of_components_hom_app, nat_iso.of_components_inv_app,
    functor.map_iso_hom, functor.map_iso_inv,
    functor.comp_map, CondensedSet_to_presheaf_map, evaluation_obj_map],
  simp only [← functor.map_iso_hom, ← functor.map_iso_inv, iso.inv_comp_eq],
  simp only [← category.assoc, ← iso.eq_comp_inv],
  simp only [category.assoc, functor.map_iso_hom, functor.map_iso_inv,
    colimit.ι_map_assoc, lim_map_eq_lim_map, lim_map_π_assoc,
    nat_iso.of_components_hom_app, nat_iso.of_components_inv_app],
  conv_rhs
  { erw [category_theory.functor.ι_map_colimit_inv,
      category_theory.functor.map_limit_hom_π_assoc,
      iso.refl_hom, iso.refl_inv, category.id_comp, category.id_comp], },
  simp only [← nat_trans.comp_app, ← Sheaf.hom.comp_val,
    CondensedSet_to_presheaf_map, evaluation_obj_map, functor.comp_map,
    ← category_theory.nat_trans.comp_app_assoc, ← category_theory.Sheaf.hom.comp_val_assoc],
  simp only [colim_to_lim, colimit.ι_desc_assoc, limit.lift_π_assoc, category.assoc],
  congr' 2,
  simp only [← lim_map_eq_lim_map, ← functor.map_iso_hom, ← functor.map_iso_inv, iso.inv_comp_eq],
  simp only [← category.assoc, ← iso.eq_comp_inv],
  simp only [functor.map_iso_hom, functor.map_iso_inv, category.assoc,
    lim_map_eq_lim_map, lim_map_π_assoc, colimit.ι_map_assoc,
    category_theory.functor.ι_map_colimit_inv, category_theory.functor.map_limit_hom_π_assoc,
    iso.refl_hom, iso.refl_inv, category.id_comp, nat_trans.id_app],
  refl,
end

end

def prod_eval_iso (α : Type (u+1))
  (X : α → J ⥤ CondensedSet.{u}) (j) :
  (∏ X).obj j ≅ ∏ (λ i, (X i).obj j) :=
preserves_limit_iso ((category_theory.evaluation _ _).obj j) _ ≪≫
has_limit.iso_of_nat_iso (discrete.nat_iso $ λ i, iso.refl _)

def is_colimit_pow_functor_map_cocone_aux (α : Type (u+1)) [fintype α] (F : J ⥤ CondensedSet)
  (S : cocone (F ⋙ pow_functor CondensedSet α)) :
  cocone (∏ λ (i : α), F) :=
{ X := S.X,
  ι :=
  { app := λ j, begin
      refine (prod_eval_iso _ _ _).hom ≫ _,
      refine S.ι.app j,
    end,
    naturality' := begin
      intros i j f, dsimp [prod_eval_iso], simp only [category.comp_id, category.assoc],
      rw ← S.w f,
      simp only [← category.assoc], congr' 1, simp only [category.assoc], dsimp,
      apply limit.hom_ext, intros k,
      dsimp [pow_functor], simp only [category.assoc, has_limit.iso_of_nat_iso_hom_π,
        discrete.nat_iso_hom_app, preserves_limits_iso_hom_π_assoc,
        evaluation_obj_map, nat_trans.naturality_assoc, lim_map_π, discrete.nat_trans_app,
        has_limit.iso_of_nat_iso_hom_π_assoc],
      dsimp [discrete.functor], simp,
    end } }

variables [is_filtered J]

lemma is_iso_colim_to_lim : is_iso (colim_to_lim F) :=
begin
  suffices : is_iso (CondensedSet_to_presheaf.map (colim_to_lim F)),
  { resetI, apply is_iso_of_fully_faithful CondensedSet_to_presheaf },
  apply_with nat_iso.is_iso_of_is_iso_app { instances := ff },
  intros S,
  apply is_iso_colim_to_lim_component,
end

noncomputable
def colimit_limit_iso_limit_colimit :
  colimit (limit F) ≅ limit (colimit F.flip) :=
@as_iso _ _ _ _ (colim_to_lim F) (is_iso_colim_to_lim _)

open_locale classical

noncomputable
def colimit_pow_iso (α : Type (u+1)) [fintype α] (F : J ⥤ CondensedSet.{u}) :
  colimit (∏ λ i : α, F) ≅ ∏ (λ i : α, colimit F) :=
colimit_limit_iso_limit_colimit (discrete.functor $ λ i : α, F) ≪≫
has_limit.iso_of_nat_iso (discrete.nat_iso $ λ i,
begin
  refine (preserves_colimit_iso ((category_theory.evaluation _ _).obj i) _) ≪≫ _,
  refine has_colimit.iso_of_nat_iso _,
  refine nat_iso.of_components (λ j, iso.refl _) _,
  intros j k f, dsimp,
  simp only [category.comp_id, category.id_comp], refl
end)
.

def is_colimit_pow_functor_map_cocone (α : Type (u+1)) [fintype α] (F : J ⥤ CondensedSet) :
  is_colimit ((pow_functor CondensedSet α).map_cocone (colimit.cocone F)) :=
{ desc := λ S, (colimit_pow_iso α F).inv ≫
    colimit.desc (∏ λ (i : α), F) (is_colimit_pow_functor_map_cocone_aux α F S),
  fac' := begin
    intros S j, dsimp,  simp only [← category.assoc], let t := _, change t ≫ _ = _,
    have ht : t = (prod_eval_iso _ _ _).inv ≫ colimit.ι _ j,
    { rw iso.eq_inv_comp,
      dsimp [t], rw [← category.assoc, iso.comp_inv_eq], dsimp [prod_eval_iso, colimit_pow_iso,
        pow_functor, colimit_limit_iso_limit_colimit, colim_to_lim],
      simp only [category.assoc, colimit.ι_desc_assoc, has_limit.lift_iso_of_nat_iso_hom],
      apply limit.hom_ext, intros k,
      simp only [category.assoc, lim_map_π, discrete.nat_trans_app,
        has_limit.iso_of_nat_iso_hom_π_assoc, discrete.nat_iso_hom_app,
        preserves_limits_iso_hom_π_assoc, evaluation_obj_map, limit.lift_π,
        cones.postcompose_obj_π, nat_trans.comp_app, iso.trans_hom],
      dsimp, simp only [category.id_comp],
      erw (is_colimit_of_preserves ((category_theory.evaluation
        (discrete α) CondensedSet).obj k) _).fac_assoc,
      erw colimit.ι_desc, refl },
    rw [ht, category.assoc, colimit.ι_desc],
    dsimp [is_colimit_pow_functor_map_cocone_aux], simp,
  end,
  uniq' := begin
    intros S m hm, rw iso.eq_inv_comp, apply colimit.hom_ext, intros j,
    dsimp [colimit_pow_iso], simp only [category.assoc, colimit.ι_desc],
    erw colimit.ι_desc_assoc, dsimp [is_colimit_pow_functor_map_cocone_aux],
    simp_rw [← hm, ← category.assoc], congr' 1, apply limit.hom_ext, intros k,
    dsimp [pow_functor, prod_eval_iso],
    simp only [has_limit.lift_iso_of_nat_iso_hom, limit.lift_π, cones.postcompose_obj_π,
      nat_trans.comp_app, discrete.nat_iso_hom_app, iso.trans_hom, category.assoc, lim_map_π,
      discrete.nat_trans_app, has_limit.iso_of_nat_iso_hom_π_assoc,
      preserves_limits_iso_hom_π_assoc, evaluation_obj_map],
    erw (is_colimit_of_preserves ((category_theory.evaluation
      (discrete α) CondensedSet).obj k) _).fac_assoc,
    erw colimit.ι_desc,
    dsimp, simp,
  end }

-- Filtered colimits commute with finite products in condensed sets
noncomputable
instance pow_functor_preserves_filtered_colimits (α : Type (u+1)) [fintype α] :
  preserves_filtered_colimits
  (pow_functor CondensedSet.{u} α) :=
begin
  constructor, introsI J _ _, constructor, intros F,
  apply preserves_colimit_of_preserves_colimit_cocone (colimit.is_colimit F),
  apply is_colimit_pow_functor_map_cocone,
end

end CondensedSet