/-
Copyright (c) 2014 Jeremy Avigad. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Author: Jeremy Avigad, Leonardo de Moura
-/
import tactic.ext tactic.finish data.subtype tactic.interactive
open function

/- set coercion to a type -/
namespace set
instance {α : Type*} : has_coe_to_sort (set α) := ⟨_, λ s, {x // x ∈ s}⟩
end set

section set_coe
universe u
variables {α : Type u}
theorem set.set_coe_eq_subtype (s : set α) :
  coe_sort.{(u+1) (u+2)} s = {x // x ∈ s} := rfl

@[simp] theorem set_coe.forall {s : set α} {p : s → Prop} :
  (∀ x : s, p x) ↔ (∀ x (h : x ∈ s), p ⟨x, h⟩) :=
subtype.forall

@[simp] theorem set_coe.exists {s : set α} {p : s → Prop} :
  (∃ x : s, p x) ↔ (∃ x (h : x ∈ s), p ⟨x, h⟩) :=
subtype.exists

@[simp] theorem set_coe_cast : ∀ {s t : set α} (H' : s = t) (H : @eq (Type u) s t) (x : s),
  cast H x = ⟨x.1, H' ▸ x.2⟩
| s _ rfl _ ⟨x, h⟩ := rfl

theorem set_coe.ext {s : set α} {a b : s} : (↑a : α) = ↑b → a = b :=
subtype.eq

theorem set_coe.ext_iff {s : set α} {a b : s} : (↑a : α) = ↑b ↔ a = b :=
iff.intro set_coe.ext (assume h, h ▸ rfl)

end set_coe

lemma subtype.mem {α : Type*} {s : set α} (p : s) : (p : α) ∈ s := p.property

namespace set
universes u v w x
variables {α : Type u} {β : Type v} {γ : Type w} {ι : Sort x} {a : α} {s t : set α}

instance : inhabited (set α) := ⟨∅⟩

@[extensionality]
theorem ext {a b : set α} (h : ∀ x, x ∈ a ↔ x ∈ b) : a = b :=
funext (assume x, propext (h x))

theorem ext_iff (s t : set α) : s = t ↔ ∀ x, x ∈ s ↔ x ∈ t :=
⟨λ h x, by rw h, ext⟩

@[trans] theorem mem_of_mem_of_subset {α : Type u} {x : α} {s t : set α} (hx : x ∈ s) (h : s ⊆ t) : x ∈ t :=
h hx

/- mem and set_of -/

@[simp] theorem mem_set_of_eq {a : α} {p : α → Prop} : a ∈ {a | p a} = p a := rfl

@[simp] theorem nmem_set_of_eq {a : α} {P : α → Prop} : a ∉ {a : α | P a} = ¬ P a := rfl

@[simp] theorem set_of_mem_eq {s : set α} : {x | x ∈ s} = s := rfl

theorem mem_def {a : α} {s : set α} : a ∈ s ↔ s a := iff.rfl

instance decidable_mem (s : set α) [H : decidable_pred s] : ∀ a, decidable (a ∈ s) := H

instance decidable_set_of (p : α → Prop) [H : decidable_pred p] : decidable_pred {a | p a} := H

@[simp] theorem set_of_subset_set_of {p q : α → Prop} : {a | p a} ⊆ {a | q a} ↔ (∀a, p a → q a) := iff.rfl

@[simp] lemma sep_set_of {α} {p q : α → Prop} : {a ∈ {a | p a } | q a} = {a | p a ∧ q a} :=
rfl

@[simp] lemma set_of_mem {α} {s : set α} : {a | a ∈ s} = s := rfl

/- subset -/

-- TODO(Jeremy): write a tactic to unfold specific instances of generic notation?
theorem subset_def {s t : set α} : (s ⊆ t) = ∀ x, x ∈ s → x ∈ t := rfl

@[refl] theorem subset.refl (a : set α) : a ⊆ a := assume x, id

@[trans] theorem subset.trans {a b c : set α} (ab : a ⊆ b) (bc : b ⊆ c) : a ⊆ c :=
assume x h, bc (ab h)

@[trans] theorem mem_of_eq_of_mem {α : Type u} {x y : α} {s : set α} (hx : x = y) (h : y ∈ s) : x ∈ s :=
hx.symm ▸ h

theorem subset.antisymm {a b : set α} (h₁ : a ⊆ b) (h₂ : b ⊆ a) : a = b :=
ext (λ x, iff.intro (λ ina, h₁ ina) (λ inb, h₂ inb))

theorem subset.antisymm_iff {a b : set α} : a = b ↔ a ⊆ b ∧ b ⊆ a :=
⟨λ e, e ▸ ⟨subset.refl _, subset.refl _⟩,
 λ ⟨h₁, h₂⟩, subset.antisymm h₁ h₂⟩

-- an alterantive name
theorem eq_of_subset_of_subset {a b : set α} (h₁ : a ⊆ b) (h₂ : b ⊆ a) : a = b :=
subset.antisymm h₁ h₂

theorem mem_of_subset_of_mem {s₁ s₂ : set α} {a : α} : s₁ ⊆ s₂ → a ∈ s₁ → a ∈ s₂ :=
assume h₁ h₂, h₁ h₂

theorem not_subset : (¬ s ⊆ t) ↔ ∃a, a ∈ s ∧ a ∉ t :=
by simp [subset_def, classical.not_forall]

/- strict subset -/

/-- `s ⊂ t` means that `s` is a strict subset of `t`, that is, `s ⊆ t` but `s ≠ t`. -/
def strict_subset (s t : set α) := s ⊆ t ∧ s ≠ t

instance : has_ssubset (set α) := ⟨strict_subset⟩

theorem ssubset_def : (s ⊂ t) = (s ⊆ t ∧ s ≠ t) := rfl

lemma exists_of_ssubset {α : Type u} {s t : set α} (h : s ⊂ t) : (∃x∈t, x ∉ s) :=
classical.by_contradiction $ assume hn,
  have t ⊆ s, from assume a hat, classical.by_contradiction $ assume has, hn ⟨a, hat, has⟩,
  h.2 $ subset.antisymm h.1 this

lemma ssubset_iff_subset_not_subset {s t : set α} : s ⊂ t ↔ s ⊆ t ∧ ¬ t ⊆ s :=
by split; simp [set.ssubset_def, ne.def, set.subset.antisymm_iff] {contextual := tt}

theorem not_mem_empty (x : α) : ¬ (x ∈ (∅ : set α)) :=
assume h : x ∈ ∅, h

@[simp] theorem not_not_mem [decidable (a ∈ s)] : ¬ (a ∉ s) ↔ a ∈ s :=
not_not

/- empty set -/

theorem empty_def : (∅ : set α) = {x | false} := rfl

@[simp] theorem mem_empty_eq (x : α) : x ∈ (∅ : set α) = false := rfl

@[simp] theorem set_of_false : {a : α | false} = ∅ := rfl

theorem eq_empty_iff_forall_not_mem {s : set α} : s = ∅ ↔ ∀ x, x ∉ s :=
by simp [ext_iff]

theorem ne_empty_of_mem {s : set α} {x : α} (h : x ∈ s) : s ≠ ∅ :=
by { intro hs, rw hs at h, apply not_mem_empty _ h }

@[simp] theorem empty_subset (s : set α) : ∅ ⊆ s :=
assume x, assume h, false.elim h

theorem subset_empty_iff {s : set α} : s ⊆ ∅ ↔ s = ∅ :=
by simp [subset.antisymm_iff]

theorem eq_empty_of_subset_empty {s : set α} : s ⊆ ∅ → s = ∅ :=
subset_empty_iff.1

theorem ne_empty_iff_exists_mem {s : set α} : s ≠ ∅ ↔ ∃ x, x ∈ s :=
by haveI := classical.prop_decidable;
   simp [eq_empty_iff_forall_not_mem]

theorem exists_mem_of_ne_empty {s : set α} : s ≠ ∅ → ∃ x, x ∈ s :=
ne_empty_iff_exists_mem.1

theorem coe_nonempty_iff_ne_empty {s : set α} : nonempty s ↔ s ≠ ∅ :=
nonempty_subtype.trans ne_empty_iff_exists_mem.symm

-- TODO: remove when simplifier stops rewriting `a ≠ b` to `¬ a = b`
theorem not_eq_empty_iff_exists {s : set α} : ¬ (s = ∅) ↔ ∃ x, x ∈ s :=
ne_empty_iff_exists_mem

theorem subset_eq_empty {s t : set α} (h : t ⊆ s) (e : s = ∅) : t = ∅ :=
subset_empty_iff.1 $ e ▸ h

theorem subset_ne_empty {s t : set α} (h : t ⊆ s) : t ≠ ∅ → s ≠ ∅ :=
mt (subset_eq_empty h)

theorem ball_empty_iff {p : α → Prop} :
  (∀ x ∈ (∅ : set α), p x) ↔ true :=
by simp [iff_def]

/- universal set -/

theorem univ_def : @univ α = {x | true} := rfl

@[simp] theorem mem_univ (x : α) : x ∈ @univ α := trivial

theorem empty_ne_univ [h : inhabited α] : (∅ : set α) ≠ univ :=
by simp [ext_iff]

@[simp] theorem subset_univ (s : set α) : s ⊆ univ := λ x H, trivial

theorem univ_subset_iff {s : set α} : univ ⊆ s ↔ s = univ :=
by simp [subset.antisymm_iff]

theorem eq_univ_of_univ_subset {s : set α} : univ ⊆ s → s = univ :=
univ_subset_iff.1

theorem eq_univ_iff_forall {s : set α} : s = univ ↔ ∀ x, x ∈ s :=
by simp [ext_iff]

theorem eq_univ_of_forall {s : set α} : (∀ x, x ∈ s) → s = univ := eq_univ_iff_forall.2

@[simp] lemma univ_eq_empty_iff {α : Type*} : (univ : set α) = ∅ ↔ ¬ nonempty α :=
eq_empty_iff_forall_not_mem.trans ⟨λ H ⟨x⟩, H x trivial, λ H x _, H ⟨x⟩⟩

lemma nonempty_iff_univ_ne_empty {α : Type*} : nonempty α ↔ (univ : set α) ≠ ∅ :=
by classical; exact iff_not_comm.1 univ_eq_empty_iff

lemma exists_mem_of_nonempty (α) : ∀ [nonempty α], ∃x:α, x ∈ (univ : set α)
| ⟨x⟩ := ⟨x, trivial⟩

@[simp] lemma univ_ne_empty {α} [h : nonempty α] : (univ : set α) ≠ ∅ :=
λ e, univ_eq_empty_iff.1 e h

instance univ_decidable : decidable_pred (@set.univ α) :=
λ x, is_true trivial

/- union -/

theorem union_def {s₁ s₂ : set α} : s₁ ∪ s₂ = {a | a ∈ s₁ ∨ a ∈ s₂} := rfl

theorem mem_union_left {x : α} {a : set α} (b : set α) : x ∈ a → x ∈ a ∪ b := or.inl

theorem mem_union_right {x : α} {b : set α} (a : set α) : x ∈ b → x ∈ a ∪ b := or.inr

theorem mem_or_mem_of_mem_union {x : α} {a b : set α} (H : x ∈ a ∪ b) : x ∈ a ∨ x ∈ b := H

theorem mem_union.elim {x : α} {a b : set α} {P : Prop}
    (H₁ : x ∈ a ∪ b) (H₂ : x ∈ a → P) (H₃ : x ∈ b → P) : P :=
or.elim H₁ H₂ H₃

theorem mem_union (x : α) (a b : set α) : x ∈ a ∪ b ↔ x ∈ a ∨ x ∈ b := iff.rfl

@[simp] theorem mem_union_eq (x : α) (a b : set α) : x ∈ a ∪ b = (x ∈ a ∨ x ∈ b) := rfl

@[simp] theorem union_self (a : set α) : a ∪ a = a :=
ext (assume x, or_self _)

@[simp] theorem union_empty (a : set α) : a ∪ ∅ = a :=
ext (assume x, or_false _)

@[simp] theorem empty_union (a : set α) : ∅ ∪ a = a :=
ext (assume x, false_or _)

theorem union_comm (a b : set α) : a ∪ b = b ∪ a :=
ext (assume x, or.comm)

theorem union_assoc (a b c : set α) : (a ∪ b) ∪ c = a ∪ (b ∪ c) :=
ext (assume x, or.assoc)

instance union_is_assoc : is_associative (set α) (∪) :=
⟨union_assoc⟩

instance union_is_comm : is_commutative (set α) (∪) :=
⟨union_comm⟩

theorem union_left_comm (s₁ s₂ s₃ : set α) : s₁ ∪ (s₂ ∪ s₃) = s₂ ∪ (s₁ ∪ s₃) :=
by finish

theorem union_right_comm (s₁ s₂ s₃ : set α) : (s₁ ∪ s₂) ∪ s₃ = (s₁ ∪ s₃) ∪ s₂ :=
by finish

theorem union_eq_self_of_subset_left {s t : set α} (h : s ⊆ t) : s ∪ t = t :=
by finish [subset_def, ext_iff, iff_def]

theorem union_eq_self_of_subset_right {s t : set α} (h : t ⊆ s) : s ∪ t = s :=
by finish [subset_def, ext_iff, iff_def]

@[simp] theorem subset_union_left (s t : set α) : s ⊆ s ∪ t := λ x, or.inl

@[simp] theorem subset_union_right (s t : set α) : t ⊆ s ∪ t := λ x, or.inr

theorem union_subset {s t r : set α} (sr : s ⊆ r) (tr : t ⊆ r) : s ∪ t ⊆ r :=
by finish [subset_def, union_def]

@[simp] theorem union_subset_iff {s t u : set α} : s ∪ t ⊆ u ↔ s ⊆ u ∧ t ⊆ u :=
by finish [iff_def, subset_def]

theorem union_subset_union {s₁ s₂ t₁ t₂ : set α} (h₁ : s₁ ⊆ s₂) (h₂ : t₁ ⊆ t₂) : s₁ ∪ t₁ ⊆ s₂ ∪ t₂ :=
by finish [subset_def]

theorem union_subset_union_left {s₁ s₂ : set α} (t) (h : s₁ ⊆ s₂) : s₁ ∪ t ⊆ s₂ ∪ t :=
union_subset_union h (by refl)

theorem union_subset_union_right (s) {t₁ t₂ : set α} (h : t₁ ⊆ t₂) : s ∪ t₁ ⊆ s ∪ t₂ :=
union_subset_union (by refl) h

@[simp] theorem union_empty_iff {s t : set α} : s ∪ t = ∅ ↔ s = ∅ ∧ t = ∅ :=
⟨by finish [ext_iff], by finish [ext_iff]⟩

/- intersection -/

theorem inter_def {s₁ s₂ : set α} : s₁ ∩ s₂ = {a | a ∈ s₁ ∧ a ∈ s₂} := rfl

theorem mem_inter_iff (x : α) (a b : set α) : x ∈ a ∩ b ↔ x ∈ a ∧ x ∈ b := iff.rfl

@[simp] theorem mem_inter_eq (x : α) (a b : set α) : x ∈ a ∩ b = (x ∈ a ∧ x ∈ b) := rfl

theorem mem_inter {x : α} {a b : set α} (ha : x ∈ a) (hb : x ∈ b) : x ∈ a ∩ b :=
⟨ha, hb⟩

theorem mem_of_mem_inter_left {x : α} {a b : set α} (h : x ∈ a ∩ b) : x ∈ a :=
h.left

theorem mem_of_mem_inter_right {x : α} {a b : set α} (h : x ∈ a ∩ b) : x ∈ b :=
h.right

@[simp] theorem inter_self (a : set α) : a ∩ a = a :=
ext (assume x, and_self _)

@[simp] theorem inter_empty (a : set α) : a ∩ ∅ = ∅ :=
ext (assume x, and_false _)

@[simp] theorem empty_inter (a : set α) : ∅ ∩ a = ∅ :=
ext (assume x, false_and _)

theorem inter_comm (a b : set α) : a ∩ b = b ∩ a :=
ext (assume x, and.comm)

theorem inter_assoc (a b c : set α) : (a ∩ b) ∩ c = a ∩ (b ∩ c) :=
ext (assume x, and.assoc)

instance inter_is_assoc : is_associative (set α) (∩) :=
⟨inter_assoc⟩

instance inter_is_comm : is_commutative (set α) (∩) :=
⟨inter_comm⟩

theorem inter_left_comm (s₁ s₂ s₃ : set α) : s₁ ∩ (s₂ ∩ s₃) = s₂ ∩ (s₁ ∩ s₃) :=
by finish

theorem inter_right_comm (s₁ s₂ s₃ : set α) : (s₁ ∩ s₂) ∩ s₃ = (s₁ ∩ s₃) ∩ s₂ :=
by finish

@[simp] theorem inter_subset_left (s t : set α) : s ∩ t ⊆ s := λ x H, and.left H

@[simp] theorem inter_subset_right (s t : set α) : s ∩ t ⊆ t := λ x H, and.right H

theorem subset_inter {s t r : set α} (rs : r ⊆ s) (rt : r ⊆ t) : r ⊆ s ∩ t :=
by finish [subset_def, inter_def]

@[simp] theorem subset_inter_iff {s t r : set α} : r ⊆ s ∩ t ↔ r ⊆ s ∧ r ⊆ t :=
⟨λ h, ⟨subset.trans h (inter_subset_left _ _), subset.trans h (inter_subset_right _ _)⟩,
 λ ⟨h₁, h₂⟩, subset_inter h₁ h₂⟩

@[simp] theorem inter_univ (a : set α) : a ∩ univ = a :=
ext (assume x, and_true _)

@[simp] theorem univ_inter (a : set α) : univ ∩ a = a :=
ext (assume x, true_and _)

theorem inter_subset_inter_left {s t : set α} (u : set α) (H : s ⊆ t) : s ∩ u ⊆ t ∩ u :=
by finish [subset_def]

theorem inter_subset_inter_right {s t : set α} (u : set α) (H : s ⊆ t) : u ∩ s ⊆ u ∩ t :=
by finish [subset_def]

theorem inter_subset_inter {s₁ s₂ t₁ t₂ : set α} (h₁ : s₁ ⊆ t₁) (h₂ : s₂ ⊆ t₂) : s₁ ∩ s₂ ⊆ t₁ ∩ t₂ :=
by finish [subset_def]

theorem inter_eq_self_of_subset_left {s t : set α} (h : s ⊆ t) : s ∩ t = s :=
by finish [subset_def, ext_iff, iff_def]

theorem inter_eq_self_of_subset_right {s t : set α} (h : t ⊆ s) : s ∩ t = t :=
by finish [subset_def, ext_iff, iff_def]

theorem union_inter_cancel_left {s t : set α} : (s ∪ t) ∩ s = s :=
by finish [ext_iff, iff_def]

theorem union_inter_cancel_right {s t : set α} : (s ∪ t) ∩ t = t :=
by finish [ext_iff, iff_def]

-- TODO(Mario): remove?
theorem nonempty_of_inter_nonempty_right {s t : set α} (h : s ∩ t ≠ ∅) : t ≠ ∅ :=
by finish [ext_iff, iff_def]

theorem nonempty_of_inter_nonempty_left {s t : set α} (h : s ∩ t ≠ ∅) : s ≠ ∅ :=
by finish [ext_iff, iff_def]

/- distributivity laws -/

theorem inter_distrib_left (s t u : set α) : s ∩ (t ∪ u) = (s ∩ t) ∪ (s ∩ u) :=
ext (assume x, and_or_distrib_left)

theorem inter_distrib_right (s t u : set α) : (s ∪ t) ∩ u = (s ∩ u) ∪ (t ∩ u) :=
ext (assume x, or_and_distrib_right)

theorem union_distrib_left (s t u : set α) : s ∪ (t ∩ u) = (s ∪ t) ∩ (s ∪ u) :=
ext (assume x, or_and_distrib_left)

theorem union_distrib_right (s t u : set α) : (s ∩ t) ∪ u = (s ∪ u) ∩ (t ∪ u) :=
ext (assume x, and_or_distrib_right)

/- insert -/

theorem insert_def (x : α) (s : set α) : insert x s = { y | y = x ∨ y ∈ s } := rfl

@[simp] theorem insert_of_has_insert (x : α) (s : set α) : has_insert.insert x s = insert x s := rfl

@[simp] theorem subset_insert (x : α) (s : set α) : s ⊆ insert x s :=
assume y ys, or.inr ys

theorem mem_insert (x : α) (s : set α) : x ∈ insert x s :=
or.inl rfl

theorem mem_insert_of_mem {x : α} {s : set α} (y : α) : x ∈ s → x ∈ insert y s := or.inr

theorem eq_or_mem_of_mem_insert {x a : α} {s : set α} : x ∈ insert a s → x = a ∨ x ∈ s := id

theorem mem_of_mem_insert_of_ne {x a : α} {s : set α} (xin : x ∈ insert a s) : x ≠ a → x ∈ s :=
by finish [insert_def]

@[simp] theorem mem_insert_iff {x a : α} {s : set α} : x ∈ insert a s ↔ (x = a ∨ x ∈ s) := iff.rfl

@[simp] theorem insert_eq_of_mem {a : α} {s : set α} (h : a ∈ s) : insert a s = s :=
by finish [ext_iff, iff_def]

theorem insert_subset : insert a s ⊆ t ↔ (a ∈ t ∧ s ⊆ t) :=
by simp [subset_def, or_imp_distrib, forall_and_distrib]

theorem insert_subset_insert (h : s ⊆ t) : insert a s ⊆ insert a t :=
assume a', or.imp_right (@h a')

theorem ssubset_insert {s : set α} {a : α} (h : a ∉ s) : s ⊂ insert a s :=
by finish [ssubset_def, ext_iff]

theorem insert_comm (a b : α) (s : set α) : insert a (insert b s) = insert b (insert a s) :=
ext $ by simp [or.left_comm]

theorem insert_union : insert a s ∪ t = insert a (s ∪ t) :=
ext $ assume a, by simp [or.comm, or.left_comm]

@[simp] theorem union_insert : s ∪ insert a t = insert a (s ∪ t) :=
ext $ assume a, by simp [or.comm, or.left_comm]

-- TODO(Jeremy): make this automatic
theorem insert_ne_empty (a : α) (s : set α) : insert a s ≠ ∅ :=
by safe [ext_iff, iff_def]; have h' := a_1 a; finish

-- useful in proofs by induction
theorem forall_of_forall_insert {P : α → Prop} {a : α} {s : set α} (h : ∀ x, x ∈ insert a s → P x) :
  ∀ x, x ∈ s → P x :=
by finish

theorem forall_insert_of_forall {P : α → Prop} {a : α} {s : set α} (h : ∀ x, x ∈ s → P x) (ha : P a) :
  ∀ x, x ∈ insert a s → P x :=
by finish

theorem ball_insert_iff {P : α → Prop} {a : α} {s : set α} :
  (∀ x ∈ insert a s, P x) ↔ P a ∧ (∀x ∈ s, P x) :=
by finish [iff_def]

/- singletons -/

theorem singleton_def (a : α) : ({a} : set α) = insert a ∅ := rfl

@[simp] theorem mem_singleton_iff {a b : α} : a ∈ ({b} : set α) ↔ a = b :=
by finish [singleton_def]

lemma set_of_eq_eq_singleton {a : α} : {n | n = a} = {a} := set.ext $ λ n, (set.mem_singleton_iff).symm

-- TODO: again, annotation needed
@[simp] theorem mem_singleton (a : α) : a ∈ ({a} : set α) := by finish

theorem eq_of_mem_singleton {x y : α} (h : x ∈ ({y} : set α)) : x = y :=
by finish

@[simp] theorem singleton_eq_singleton_iff {x y : α} : {x} = ({y} : set α) ↔ x = y :=
by finish [ext_iff, iff_def]

theorem mem_singleton_of_eq {x y : α} (H : x = y) : x ∈ ({y} : set α) :=
by finish

theorem insert_eq (x : α) (s : set α) : insert x s = ({x} : set α) ∪ s :=
by finish [ext_iff, or_comm]

@[simp] theorem pair_eq_singleton (a : α) : ({a, a} : set α) = {a} :=
by finish

@[simp] theorem singleton_ne_empty (a : α) : ({a} : set α) ≠ ∅ := insert_ne_empty _ _

@[simp] theorem singleton_subset_iff {a : α} {s : set α} : {a} ⊆ s ↔ a ∈ s :=
⟨λh, h (by simp), λh b e, by simp at e; simp [*]⟩

theorem set_compr_eq_eq_singleton {a : α} : {b | b = a} = {a} :=
ext $ by simp

@[simp] theorem union_singleton : s ∪ {a} = insert a s :=
by simp [singleton_def]

@[simp] theorem singleton_union : {a} ∪ s = insert a s :=
by rw [union_comm, union_singleton]

theorem singleton_inter_eq_empty : {a} ∩ s = ∅ ↔ a ∉ s :=
by simp [eq_empty_iff_forall_not_mem]

theorem inter_singleton_eq_empty : s ∩ {a} = ∅ ↔ a ∉ s :=
by rw [inter_comm, singleton_inter_eq_empty]

/- separation -/

theorem mem_sep {s : set α} {p : α → Prop} {x : α} (xs : x ∈ s) (px : p x) : x ∈ {x ∈ s | p x} :=
⟨xs, px⟩

@[simp] theorem mem_sep_eq {s : set α} {p : α → Prop} {x : α} : x ∈ {x ∈ s | p x} = (x ∈ s ∧ p x) := rfl

theorem mem_sep_iff {s : set α} {p : α → Prop} {x : α} : x ∈ {x ∈ s | p x} ↔ x ∈ s ∧ p x :=
iff.rfl

theorem eq_sep_of_subset {s t : set α} (ssubt : s ⊆ t) : s = {x ∈ t | x ∈ s} :=
by finish [ext_iff, iff_def, subset_def]

theorem sep_subset (s : set α) (p : α → Prop) : {x ∈ s | p x} ⊆ s :=
assume x, and.left

theorem forall_not_of_sep_empty {s : set α} {p : α → Prop} (h : {x ∈ s | p x} = ∅) :
  ∀ x ∈ s, ¬ p x :=
by finish [ext_iff]

@[simp] lemma sep_univ {α} {p : α → Prop} : {a ∈ (univ : set α) | p a} = {a | p a} :=
set.ext $ by simp

/- complement -/

theorem mem_compl {s : set α} {x : α} (h : x ∉ s) : x ∈ -s := h

lemma compl_set_of {α} (p : α → Prop) : - {a | p a} = { a | ¬ p a } := rfl

theorem not_mem_of_mem_compl {s : set α} {x : α} (h : x ∈ -s) : x ∉ s := h

@[simp] theorem mem_compl_eq (s : set α) (x : α) : x ∈ -s = (x ∉ s) := rfl

theorem mem_compl_iff (s : set α) (x : α) : x ∈ -s ↔ x ∉ s := iff.rfl

@[simp] theorem inter_compl_self (s : set α) : s ∩ -s = ∅ :=
by finish [ext_iff]

@[simp] theorem compl_inter_self (s : set α) : -s ∩ s = ∅ :=
by finish [ext_iff]

@[simp] theorem compl_empty : -(∅ : set α) = univ :=
by finish [ext_iff]

@[simp] theorem compl_union (s t : set α) : -(s ∪ t) = -s ∩ -t :=
by finish [ext_iff]

@[simp] theorem compl_compl (s : set α) : -(-s) = s :=
by finish [ext_iff]

-- ditto
theorem compl_inter (s t : set α) : -(s ∩ t) = -s ∪ -t :=
by finish [ext_iff]

@[simp] theorem compl_univ : -(univ : set α) = ∅ :=
by finish [ext_iff]

theorem union_eq_compl_compl_inter_compl (s t : set α) : s ∪ t = -(-s ∩ -t) :=
by simp [compl_inter, compl_compl]

theorem inter_eq_compl_compl_union_compl (s t : set α) : s ∩ t = -(-s ∪ -t) :=
by simp [compl_compl]

@[simp] theorem union_compl_self (s : set α) : s ∪ -s = univ :=
by finish [ext_iff]

@[simp] theorem compl_union_self (s : set α) : -s ∪ s = univ :=
by finish [ext_iff]

theorem compl_comp_compl : compl ∘ compl = @id (set α) :=
funext compl_compl

theorem compl_subset_comm {s t : set α} : -s ⊆ t ↔ -t ⊆ s :=
by haveI := classical.prop_decidable; exact
forall_congr (λ a, not_imp_comm)

lemma compl_subset_compl {s t : set α} : -s ⊆ -t ↔ t ⊆ s :=
by rw [compl_subset_comm, compl_compl]

theorem compl_subset_iff_union {s t : set α} : -s ⊆ t ↔ s ∪ t = univ :=
iff.symm $ eq_univ_iff_forall.trans $ forall_congr $ λ a,
by haveI := classical.prop_decidable; exact or_iff_not_imp_left

theorem subset_compl_comm {s t : set α} : s ⊆ -t ↔ t ⊆ -s :=
forall_congr $ λ a, imp_not_comm

theorem subset_compl_iff_disjoint {s t : set α} : s ⊆ -t ↔ s ∩ t = ∅ :=
iff.trans (forall_congr $ λ a, and_imp.symm) subset_empty_iff

theorem inter_subset (a b c : set α) : a ∩ b ⊆ c ↔ a ⊆ -b ∪ c :=
begin
  haveI := classical.prop_decidable,
  split,
  { intros h x xa, by_cases h' : x ∈ b, simp [h ⟨xa, h'⟩], simp [h'] },
  intros h x, rintro ⟨xa, xb⟩, cases h xa, contradiction, assumption
end

/- set difference -/

theorem diff_eq (s t : set α) : s \ t = s ∩ -t := rfl

@[simp] theorem mem_diff {s t : set α} (x : α) : x ∈ s \ t ↔ x ∈ s ∧ x ∉ t := iff.rfl

theorem mem_diff_of_mem {s t : set α} {x : α} (h1 : x ∈ s) (h2 : x ∉ t) : x ∈ s \ t :=
⟨h1, h2⟩

theorem mem_of_mem_diff {s t : set α} {x : α} (h : x ∈ s \ t) : x ∈ s :=
h.left

theorem not_mem_of_mem_diff {s t : set α} {x : α} (h : x ∈ s \ t) : x ∉ t :=
h.right

theorem union_diff_cancel {s t : set α} (h : s ⊆ t) : s ∪ (t \ s) = t :=
by finish [ext_iff, iff_def, subset_def]

theorem union_diff_cancel_left {s t : set α} (h : s ∩ t ⊆ ∅) : (s ∪ t) \ s = t :=
by finish [ext_iff, iff_def, subset_def]

theorem union_diff_cancel_right {s t : set α} (h : s ∩ t ⊆ ∅) : (s ∪ t) \ t = s :=
by finish [ext_iff, iff_def, subset_def]

theorem union_diff_left {s t : set α} : (s ∪ t) \ s = t \ s :=
by finish [ext_iff, iff_def]

theorem union_diff_right {s t : set α} : (s ∪ t) \ t = s \ t :=
by finish [ext_iff, iff_def]

theorem union_diff_distrib {s t u : set α} : (s ∪ t) \ u = s \ u ∪ t \ u :=
inter_distrib_right _ _ _

theorem inter_diff_assoc (a b c : set α) : (a ∩ b) \ c = a ∩ (b \ c) :=
inter_assoc _ _ _

theorem inter_diff_self (a b : set α) : a ∩ (b \ a) = ∅ :=
by finish [ext_iff]

theorem inter_union_diff (s t : set α) : (s ∩ t) ∪ (s \ t) = s :=
by finish [ext_iff, iff_def]

theorem diff_subset (s t : set α) : s \ t ⊆ s :=
by finish [subset_def]

theorem diff_subset_diff {s₁ s₂ t₁ t₂ : set α} : s₁ ⊆ s₂ → t₂ ⊆ t₁ → s₁ \ t₁ ⊆ s₂ \ t₂ :=
by finish [subset_def]

theorem diff_subset_diff_left {s₁ s₂ t : set α} (h : s₁ ⊆ s₂) : s₁ \ t ⊆ s₂ \ t :=
diff_subset_diff h (by refl)

theorem diff_subset_diff_right {s t u : set α} (h : t ⊆ u) : s \ u ⊆ s \ t :=
diff_subset_diff (subset.refl s) h

theorem compl_eq_univ_diff (s : set α) : -s = univ \ s :=
by finish [ext_iff]

@[simp] lemma empty_diff {α : Type*} (s : set α) : (∅ \ s : set α) = ∅ :=
eq_empty_of_subset_empty $ assume x ⟨hx, _⟩, hx

theorem diff_eq_empty {s t : set α} : s \ t = ∅ ↔ s ⊆ t :=
⟨assume h x hx, classical.by_contradiction $ assume : x ∉ t, show x ∈ (∅ : set α), from h ▸ ⟨hx, this⟩,
  assume h, eq_empty_of_subset_empty $ assume x ⟨hx, hnx⟩, hnx $ h hx⟩

@[simp] theorem diff_empty {s : set α} : s \ ∅ = s :=
ext $ assume x, ⟨assume ⟨hx, _⟩, hx, assume h, ⟨h, not_false⟩⟩

theorem diff_diff {u : set α} : s \ t \ u = s \ (t ∪ u) :=
ext $ by simp [not_or_distrib, and.comm, and.left_comm]

lemma diff_subset_iff {s t u : set α} : s \ t ⊆ u ↔ s ⊆ t ∪ u :=
⟨assume h x xs, classical.by_cases or.inl (assume nxt, or.inr (h ⟨xs, nxt⟩)),
 assume h x ⟨xs, nxt⟩, or.resolve_left (h xs) nxt⟩

lemma diff_subset_comm {s t u : set α} : s \ t ⊆ u ↔ s \ u ⊆ t :=
by rw [diff_subset_iff, diff_subset_iff, union_comm]

@[simp] theorem insert_diff (h : a ∈ t) : insert a s \ t = s \ t :=
ext $ by intro; constructor; simp [or_imp_distrib, h] {contextual := tt}

theorem union_diff_self {s t : set α} : s ∪ (t \ s) = s ∪ t :=
by finish [ext_iff, iff_def]

theorem diff_union_self {s t : set α} : (s \ t) ∪ t = s ∪ t :=
by rw [union_comm, union_diff_self, union_comm]

theorem diff_inter_self {a b : set α} : (b \ a) ∩ a = ∅ :=
ext $ by simp [iff_def] {contextual:=tt}

theorem diff_eq_self {s t : set α} : s \ t = s ↔ t ∩ s ⊆ ∅ :=
by finish [ext_iff, iff_def, subset_def]

@[simp] theorem diff_singleton_eq_self {a : α} {s : set α} (h : a ∉ s) : s \ {a} = s :=
diff_eq_self.2 $ by simp [singleton_inter_eq_empty.2 h]

@[simp] theorem insert_diff_singleton {a : α} {s : set α} :
  insert a (s \ {a}) = insert a s :=
by simp [insert_eq, union_diff_self, -union_singleton, -singleton_union]

@[simp] lemma diff_self {s : set α} : s \ s = ∅ := ext $ by simp

/- powerset -/

theorem mem_powerset {x s : set α} (h : x ⊆ s) : x ∈ powerset s := h

theorem subset_of_mem_powerset {x s : set α} (h : x ∈ powerset s) : x ⊆ s := h

theorem mem_powerset_iff (x s : set α) : x ∈ powerset s ↔ x ⊆ s := iff.rfl

/- inverse image -/

/-- The preimage of `s : set β` by `f : α → β`, written `f ⁻¹' s`,
  is the set of `x : α` such that `f x ∈ s`. -/
def preimage {α : Type u} {β : Type v} (f : α → β) (s : set β) : set α := {x | f x ∈ s}

infix ` ⁻¹' `:80 := preimage

section preimage
variables {f : α → β} {g : β → γ}

@[simp] theorem preimage_empty : f ⁻¹' ∅ = ∅ := rfl

@[simp] theorem mem_preimage_eq {s : set β} {a : α} : (a ∈ f ⁻¹' s) = (f a ∈ s) := rfl

theorem preimage_mono {s t : set β} (h : s ⊆ t) : f ⁻¹' s ⊆ f ⁻¹' t :=
assume x hx, h hx

@[simp] theorem preimage_univ : f ⁻¹' univ = univ := rfl

@[simp] theorem preimage_inter {s t : set β} : f ⁻¹' (s ∩ t) = f ⁻¹' s ∩ f ⁻¹' t := rfl

@[simp] theorem preimage_union {s t : set β} : f ⁻¹' (s ∪ t) = f ⁻¹' s ∪ f ⁻¹' t := rfl

@[simp] theorem preimage_compl {s : set β} : f ⁻¹' (- s) = - (f ⁻¹' s) := rfl

@[simp] theorem preimage_diff (f : α → β) (s t : set β) :
  f ⁻¹' (s \ t) = f ⁻¹' s \ f ⁻¹' t := rfl

@[simp] theorem preimage_set_of_eq {p : α → Prop} {f : β → α} : f ⁻¹' {a | p a} = {a | p (f a)} :=
rfl

theorem preimage_id {s : set α} : id ⁻¹' s = s := rfl

theorem preimage_comp {s : set γ} : (g ∘ f) ⁻¹' s = f ⁻¹' (g ⁻¹' s) := rfl

theorem eq_preimage_subtype_val_iff {p : α → Prop} {s : set (subtype p)} {t : set α} :
  s = subtype.val ⁻¹' t ↔ (∀x (h : p x), (⟨x, h⟩ : subtype p) ∈ s ↔ x ∈ t) :=
⟨assume s_eq x h, by rw [s_eq]; simp,
 assume h, ext $ assume ⟨x, hx⟩, by simp [h]⟩

end preimage

/- function image -/

section image

infix ` '' `:80 := image

/-- Two functions `f₁ f₂ : α → β` are equal on `s`
  if `f₁ x = f₂ x` for all `x ∈ a`. -/
@[reducible] def eq_on (f1 f2 : α → β) (a : set α) : Prop :=
∀ x ∈ a, f1 x = f2 x

-- TODO(Jeremy): use bounded exists in image

theorem mem_image_iff_bex {f : α → β} {s : set α} {y : β} :
  y ∈ f '' s ↔ ∃ x (_ : x ∈ s), f x = y := bex_def.symm

theorem mem_image_eq (f : α → β) (s : set α) (y: β) : y ∈ f '' s = ∃ x, x ∈ s ∧ f x = y := rfl

@[simp] theorem mem_image (f : α → β) (s : set α) (y : β) : y ∈ f '' s ↔ ∃ x, x ∈ s ∧ f x = y := iff.rfl

theorem mem_image_of_mem (f : α → β) {x : α} {a : set α} (h : x ∈ a) : f x ∈ f '' a :=
⟨_, h, rfl⟩

theorem mem_image_of_injective {f : α → β} {a : α} {s : set α} (hf : injective f) :
  f a ∈ f '' s ↔ a ∈ s :=
iff.intro
  (assume ⟨b, hb, eq⟩, (hf eq) ▸ hb)
  (assume h, mem_image_of_mem _ h)

theorem ball_image_of_ball {f : α → β} {s : set α} {p : β → Prop}
  (h : ∀ x ∈ s, p (f x)) : ∀ y ∈ f '' s, p y :=
by finish [mem_image_eq]

@[simp] theorem ball_image_iff {f : α → β} {s : set α} {p : β → Prop} :
  (∀ y ∈ f '' s, p y) ↔ (∀ x ∈ s, p (f x)) :=
iff.intro
  (assume h a ha, h _ $ mem_image_of_mem _ ha)
  (assume h b ⟨a, ha, eq⟩, eq ▸ h a ha)

theorem mono_image {f : α → β} {s t : set α} (h : s ⊆ t) : f '' s ⊆ f '' t :=
assume x ⟨y, hy, y_eq⟩, y_eq ▸ mem_image_of_mem _ $ h hy

theorem mem_image_elim {f : α → β} {s : set α} {C : β → Prop} (h : ∀ (x : α), x ∈ s → C (f x)) :
 ∀{y : β}, y ∈ f '' s → C y
| ._ ⟨a, a_in, rfl⟩ := h a a_in

theorem mem_image_elim_on {f : α → β} {s : set α} {C : β → Prop} {y : β} (h_y : y ∈ f '' s)
  (h : ∀ (x : α), x ∈ s → C (f x)) : C y :=
mem_image_elim h h_y

@[congr] lemma image_congr {f g : α → β} {s : set α}
  (h : ∀a∈s, f a = g a) : f '' s = g '' s :=
by safe [ext_iff, iff_def]

theorem image_eq_image_of_eq_on {f₁ f₂ : α → β} {s : set α} (heq : eq_on f₁ f₂ s) :
  f₁ '' s = f₂ '' s :=
image_congr heq

theorem image_comp (f : β → γ) (g : α → β) (a : set α) : (f ∘ g) '' a = f '' (g '' a) :=
subset.antisymm
  (ball_image_of_ball $ assume a ha, mem_image_of_mem _ $ mem_image_of_mem _ ha)
  (ball_image_of_ball $ ball_image_of_ball $ assume a ha, mem_image_of_mem _ ha)
/- Proof is removed as it uses generated names
TODO(Jeremy): make automatic,
begin
  safe [ext_iff, iff_def, mem_image, (∘)],
  have h' := h_2 (g a_2),
  finish
end -/

theorem image_subset {a b : set α} (f : α → β) (h : a ⊆ b) : f '' a ⊆ f '' b :=
by finish [subset_def, mem_image_eq]

theorem image_union (f : α → β) (s t : set α) :
  f '' (s ∪ t) = f '' s ∪ f '' t :=
by finish [ext_iff, iff_def, mem_image_eq]

@[simp] theorem image_empty (f : α → β) : f '' ∅ = ∅ := ext $ by simp

theorem image_inter_on {f : α → β} {s t : set α} (h : ∀x∈t, ∀y∈s, f x = f y → x = y) :
  f '' s ∩ f '' t = f '' (s ∩ t) :=
subset.antisymm
  (assume b ⟨⟨a₁, ha₁, h₁⟩, ⟨a₂, ha₂, h₂⟩⟩,
    have a₂ = a₁, from h _ ha₂ _ ha₁ (by simp *),
    ⟨a₁, ⟨ha₁, this ▸ ha₂⟩, h₁⟩)
  (subset_inter (mono_image $ inter_subset_left _ _) (mono_image $ inter_subset_right _ _))

theorem image_inter {f : α → β} {s t : set α} (H : injective f) :
  f '' s ∩ f '' t = f '' (s ∩ t) :=
image_inter_on (assume x _ y _ h, H h)

theorem image_univ_of_surjective {ι : Type*} {f : ι → β} (H : surjective f) : f '' univ = univ :=
eq_univ_of_forall $ by simp [image]; exact H

@[simp] theorem image_singleton {f : α → β} {a : α} : f '' {a} = {f a} :=
ext $ λ x, by simp [image]; rw eq_comm

@[simp] lemma image_eq_empty {α β} {f : α → β} {s : set α} : f '' s = ∅ ↔ s = ∅ :=
by simp only [eq_empty_iff_forall_not_mem]; exact
⟨λ H a ha, H _ ⟨_, ha, rfl⟩, λ H b ⟨_, ha, _⟩, H _ ha⟩

lemma inter_singleton_ne_empty {α : Type*} {s : set α} {a : α} : s ∩ {a} ≠ ∅ ↔ a ∈ s :=
by finish  [set.inter_singleton_eq_empty]

theorem fix_set_compl (t : set α) : compl t = - t := rfl

-- TODO(Jeremy): there is an issue with - t unfolding to compl t
theorem mem_compl_image (t : set α) (S : set (set α)) :
  t ∈ compl '' S ↔ -t ∈ S :=
begin
  suffices : ∀ x, -x = t ↔ -t = x, {simp [fix_set_compl, this]},
  intro x, split; { intro e, subst e, simp }
end

@[simp] theorem image_id (s : set α) : id '' s = s := ext $ by simp

theorem compl_compl_image (S : set (set α)) :
  compl '' (compl '' S) = S :=
by rw [← image_comp, compl_comp_compl, image_id]

theorem image_insert_eq {f : α → β} {a : α} {s : set α} :
  f '' (insert a s) = insert (f a) (f '' s) :=
ext $ by simp [and_or_distrib_left, exists_or_distrib, eq_comm, or_comm, and_comm]

theorem image_subset_preimage_of_inverse {f : α → β} {g : β → α}
  (I : left_inverse g f) (s : set α) : f '' s ⊆ g ⁻¹' s :=
λ b ⟨a, h, e⟩, e ▸ ((I a).symm ▸ h : g (f a) ∈ s)

theorem preimage_subset_image_of_inverse {f : α → β} {g : β → α}
  (I : left_inverse g f) (s : set β) : f ⁻¹' s ⊆ g '' s :=
λ b h, ⟨f b, h, I b⟩

theorem image_eq_preimage_of_inverse {f : α → β} {g : β → α}
  (h₁ : left_inverse g f) (h₂ : right_inverse g f) :
  image f = preimage g :=
funext $ λ s, subset.antisymm
  (image_subset_preimage_of_inverse h₁ s)
  (preimage_subset_image_of_inverse h₂ s)

theorem mem_image_iff_of_inverse {f : α → β} {g : β → α} {b : β} {s : set α}
  (h₁ : left_inverse g f) (h₂ : right_inverse g f) :
  b ∈ f '' s ↔ g b ∈ s :=
by rw image_eq_preimage_of_inverse h₁ h₂; refl

theorem image_compl_subset {f : α → β} {s : set α} (H : injective f) : f '' -s ⊆ -(f '' s) :=
subset_compl_iff_disjoint.2 $ by simp [image_inter H]

theorem subset_image_compl {f : α → β} {s : set α} (H : surjective f) : -(f '' s) ⊆ f '' -s :=
compl_subset_iff_union.2 $
by rw ← image_union; simp [image_univ_of_surjective H]

theorem image_compl_eq {f : α → β} {s : set α} (H : bijective f) : f '' -s = -(f '' s) :=
subset.antisymm (image_compl_subset H.1) (subset_image_compl H.2)

/- image and preimage are a Galois connection -/
theorem image_subset_iff {s : set α} {t : set β} {f : α → β} :
  f '' s ⊆ t ↔ s ⊆ f ⁻¹' t :=
ball_image_iff

theorem image_preimage_subset (f : α → β) (s : set β) :
  f '' (f ⁻¹' s) ⊆ s :=
image_subset_iff.2 (subset.refl _)

theorem subset_preimage_image (f : α → β) (s : set α) :
  s ⊆ f ⁻¹' (f '' s) :=
λ x, mem_image_of_mem f

theorem preimage_image_eq {f : α → β} (s : set α) (h : injective f) : f ⁻¹' (f '' s) = s :=
subset.antisymm
  (λ x ⟨y, hy, e⟩, h e ▸ hy)
  (subset_preimage_image f s)

theorem image_preimage_eq {f : α → β} {s : set β} (h : surjective f) : f '' (f ⁻¹' s) = s :=
subset.antisymm
  (image_preimage_subset f s)
  (λ x hx, let ⟨y, e⟩ := h x in ⟨y, (e.symm ▸ hx : f y ∈ s), e⟩)

lemma preimage_eq_preimage {f : β → α} (hf : surjective f) : f ⁻¹' s = preimage f t ↔ s = t :=
iff.intro
  (assume eq, by rw [← @image_preimage_eq β α f s hf, ← @image_preimage_eq β α f t hf, eq])
  (assume eq, eq ▸ rfl)

lemma surjective_preimage {f : β → α} (hf : surjective f) : injective (preimage f) :=
assume s t, (preimage_eq_preimage hf).1

theorem compl_image : image (@compl α) = preimage compl :=
image_eq_preimage_of_inverse compl_compl compl_compl

theorem compl_image_set_of {α : Type u} {p : set α → Prop} :
  compl '' {x | p x} = {x | p (- x)} :=
congr_fun compl_image p

theorem inter_preimage_subset (s : set α) (t : set β) (f : α → β) :
  s ∩ f ⁻¹' t ⊆ f ⁻¹' (f '' s ∩ t) :=
λ x h, ⟨mem_image_of_mem _ h.left, h.right⟩

theorem union_preimage_subset (s : set α) (t : set β) (f : α → β) :
  s ∪ f ⁻¹' t ⊆ f ⁻¹' (f '' s ∪ t) :=
λ x h, or.elim h (λ l, or.inl $ mem_image_of_mem _ l) (λ r, or.inr r)

theorem subset_image_union (f : α → β) (s : set α) (t : set β) :
  f '' (s ∪ f ⁻¹' t) ⊆ f '' s ∪ t :=
image_subset_iff.2 (union_preimage_subset _ _ _)

lemma preimage_subset_iff {A : set α} {B : set β} {f : α → β} :
  f⁻¹' B ⊆ A ↔ (∀ a : α, f a ∈ B → a ∈ A) := iff.rfl

lemma image_eq_image {f : α → β} (hf : injective f) : f '' s = f '' t ↔ s = t :=
iff.symm $ iff.intro (assume eq, eq ▸ rfl) $ assume eq,
  by rw [← preimage_image_eq s hf, ← preimage_image_eq t hf, eq]

lemma image_subset_image_iff {f : α → β} (hf : injective f) : f '' s ⊆ f '' t ↔ s ⊆ t :=
begin
  refine (iff.symm $ iff.intro (image_subset f) $ assume h, _),
  rw [← preimage_image_eq s hf, ← preimage_image_eq t hf],
  exact preimage_mono h
end

lemma injective_image {f : α → β} (hf : injective f) : injective (('') f) :=
assume s t, (image_eq_image hf).1

lemma prod_quotient_preimage_eq_image [s : setoid α] (g : quotient s → β) {h : α → β}
  (Hh : h = g ∘ quotient.mk) (r : set (β × β)) :
  {x : quotient s × quotient s | (g x.1, g x.2) ∈ r} =
  (λ a : α × α, (⟦a.1⟧, ⟦a.2⟧)) '' ((λ a : α × α, (h a.1, h a.2)) ⁻¹' r) :=
Hh.symm ▸ set.ext (λ ⟨a₁, a₂⟩, ⟨quotient.induction_on₂ a₁ a₂
  (λ a₁ a₂ h, ⟨(a₁, a₂), h, rfl⟩),
  λ ⟨⟨b₁, b₂⟩, h₁, h₂⟩, show (g a₁, g a₂) ∈ r, from
  have h₃ : ⟦b₁⟧ = a₁ ∧ ⟦b₂⟧ = a₂ := prod.ext_iff.1 h₂,
    h₃.1 ▸ h₃.2 ▸ h₁⟩)

def image_factorization (f : α → β) (s : set α) : s → f '' s :=
λ p, ⟨f p.1, mem_image_of_mem f p.2⟩

lemma image_factorization_eq {f : α → β} {s : set α} :
  subtype.val ∘ image_factorization f s = f ∘ subtype.val :=
funext $ λ p, rfl

lemma surjective_onto_image {f : α → β} {s : set α} :
  surjective (image_factorization f s) :=
λ ⟨_, ⟨a, ha, rfl⟩⟩, ⟨⟨a, ha⟩, rfl⟩

end image

theorem univ_eq_true_false : univ = ({true, false} : set Prop) :=
eq.symm $ eq_univ_of_forall $ classical.cases (by simp) (by simp)

section range
variables {f : ι → α}
open function

/-- Range of a function.

This function is more flexible than `f '' univ`, as the image requires that the domain is in Type
and not an arbitrary Sort. -/
def range (f : ι → α) : set α := {x | ∃y, f y = x}

@[simp] theorem mem_range {x : α} : x ∈ range f ↔ ∃ y, f y = x := iff.rfl

theorem mem_range_self (i : ι) : f i ∈ range f := ⟨i, rfl⟩

theorem forall_range_iff {p : α → Prop} : (∀ a ∈ range f, p a) ↔ (∀ i, p (f i)) :=
⟨assume h i, h (f i) (mem_range_self _), assume h a ⟨i, (hi : f i = a)⟩, hi ▸ h i⟩

theorem exists_range_iff {p : α → Prop} : (∃ a ∈ range f, p a) ↔ (∃ i, p (f i)) :=
⟨assume ⟨a, ⟨i, eq⟩, h⟩, ⟨i, eq.symm ▸ h⟩, assume ⟨i, h⟩, ⟨f i, mem_range_self _, h⟩⟩

theorem range_iff_surjective : range f = univ ↔ surjective f :=
eq_univ_iff_forall

@[simp] theorem range_id : range (@id α) = univ := range_iff_surjective.2 surjective_id

@[simp] theorem image_univ {ι : Type*} {f : ι → β} : f '' univ = range f :=
ext $ by simp [image, range]

theorem image_subset_range {ι : Type*} (f : ι → β) (s : set ι) : f '' s ⊆ range f :=
by rw ← image_univ; exact image_subset _ (subset_univ _)

theorem range_comp {g : α → β} : range (g ∘ f) = g '' range f :=
subset.antisymm
  (forall_range_iff.mpr $ assume i, mem_image_of_mem g (mem_range_self _))
  (ball_image_iff.mpr $ forall_range_iff.mpr mem_range_self)

theorem range_subset_iff {ι : Type*} {f : ι → β} {s : set β} : range f ⊆ s ↔ ∀ y, f y ∈ s :=
forall_range_iff

lemma nonempty_of_nonempty_range {α : Type*} {β : Type*} {f : α → β} (H : ¬range f = ∅) : nonempty α :=
begin
  cases exists_mem_of_ne_empty H with x h,
  cases mem_range.1 h with y _,
  exact ⟨y⟩
end

@[simp] lemma range_eq_empty {α : Type u} {β : Type v} {f : α → β} : range f = ∅ ↔ ¬ nonempty α :=
by rw ← set.image_univ; simp [-set.image_univ]

theorem image_preimage_eq_inter_range {f : α → β} {t : set β} :
  f '' (f ⁻¹' t) = t ∩ range f :=
ext $ assume x, ⟨assume ⟨x, hx, heq⟩, heq ▸ ⟨hx, mem_range_self _⟩,
  assume ⟨hx, ⟨y, h_eq⟩⟩, h_eq ▸ mem_image_of_mem f $
    show y ∈ f ⁻¹' t, by simp [preimage, h_eq, hx]⟩

lemma image_preimage_eq_of_subset {f : α → β} {s : set β} (hs : s ⊆ range f) :
  f '' (f ⁻¹' s) = s :=
by rw [image_preimage_eq_inter_range, inter_eq_self_of_subset_left hs]

theorem preimage_inter_range {f : α → β} {s : set β} : f ⁻¹' (s ∩ range f) = f ⁻¹' s :=
set.ext $ λ x, and_iff_left ⟨x, rfl⟩

theorem preimage_image_preimage {f : α → β} {s : set β} :
  f ⁻¹' (f '' (f ⁻¹' s)) = f ⁻¹' s :=
by rw [image_preimage_eq_inter_range, preimage_inter_range]

@[simp] theorem quot_mk_range_eq [setoid α] : range (λx : α, ⟦x⟧) = univ :=
range_iff_surjective.2 quot.exists_rep

lemma range_const_subset {c : β} : range (λx:α, c) ⊆ {c} :=
range_subset_iff.2 $ λ x, or.inl rfl

@[simp] lemma range_const [h : nonempty α] {c : β} : range (λx:α, c) = {c} :=
begin
  refine subset.antisymm range_const_subset (λy hy, _),
  rw set.mem_singleton_iff.1 hy,
  rcases exists_mem_of_nonempty α with ⟨x, _⟩,
  exact mem_range_self x
end

def range_factorization (f : ι → β) : ι → range f :=
λ i, ⟨f i, mem_range_self i⟩

lemma range_factorization_eq {f : ι → β} :
  subtype.val ∘ range_factorization f = f :=
funext $ λ i, rfl

lemma surjective_onto_range : surjective (range_factorization f) :=
λ ⟨_, ⟨i, rfl⟩⟩, ⟨i, rfl⟩

end range

/-- The set `s` is pairwise `r` if `r x y` for all *distinct* `x y ∈ s`. -/
def pairwise_on (s : set α) (r : α → α → Prop) := ∀ x ∈ s, ∀ y ∈ s, x ≠ y → r x y

theorem pairwise_on.mono {s t : set α} {r}
  (h : t ⊆ s) (hp : pairwise_on s r) : pairwise_on t r :=
λ x xt y yt, hp x (h xt) y (h yt)

theorem pairwise_on.mono' {s : set α} {r r' : α → α → Prop}
  (H : ∀ a b, r a b → r' a b) (hp : pairwise_on s r) : pairwise_on s r' :=
λ x xs y ys h, H _ _ (hp x xs y ys h)

end set

/- image and preimage on subtypes -/

namespace subtype

variable {α : Type*}

lemma val_image {p : α → Prop} {s : set (subtype p)} :
  subtype.val '' s = {x | ∃h : p x, (⟨x, h⟩ : subtype p) ∈ s} :=
set.ext $ assume a,
⟨assume ⟨⟨a', ha'⟩, in_s, h_eq⟩, h_eq ▸ ⟨ha', in_s⟩,
  assume ⟨ha, in_s⟩, ⟨⟨a, ha⟩, in_s, rfl⟩⟩

@[simp] lemma val_range {p : α → Prop} :
  set.range (@subtype.val _ p) = {x | p x} :=
by rw ← set.image_univ; simp [-set.image_univ, val_image]
theorem val_image_subset (s : set α) (t : set (subtype s)) : t.image val ⊆ s :=
λ x ⟨y, yt, yvaleq⟩, by rw ←yvaleq; exact y.property

theorem val_image_univ (s : set α) : @val _ s '' set.univ = s :=
set.eq_of_subset_of_subset (val_image_subset _ _) (λ x xs, ⟨⟨x, xs⟩, ⟨set.mem_univ _, rfl⟩⟩)

theorem image_preimage_val (s t : set α) :
  (@subtype.val _ s) '' ((@subtype.val _ s) ⁻¹' t) = t ∩ s :=
begin
  ext x, simp, split,
  { rintros ⟨y, ys, yt, yx⟩, rw ←yx, exact ⟨yt, ys⟩ },
  rintros ⟨xt, xs⟩, exact ⟨x, xs, xt, rfl⟩
end

theorem preimage_val_eq_preimage_val_iff (s t u : set α) :
  ((@subtype.val _ s) ⁻¹' t = (@subtype.val _ s) ⁻¹' u) ↔ (t ∩ s = u ∩ s) :=
begin
  rw [←image_preimage_val, ←image_preimage_val],
  split, { intro h, rw h },
  intro h, exact set.injective_image (val_injective) h
end
end subtype

namespace set

section range

variable {α : Type*}

@[simp] lemma subtype.val_range {p : α → Prop} :
  range (@subtype.val _ p) = {x | p x} :=
by rw ← image_univ; simp [-image_univ, subtype.val_image]

@[simp] lemma range_coe_subtype (s : set α): range (coe : s → α) = s :=
subtype.val_range

end range

section prod

variables {α : Type*} {β : Type*} {γ : Type*} {δ : Type*}
variables {s s₁ s₂ : set α} {t t₁ t₂ : set β}

/-- The cartesian product `prod s t` is the set of `(a, b)`
  such that `a ∈ s` and `b ∈ t`. -/
protected def prod (s : set α) (t : set β) : set (α × β) :=
{p | p.1 ∈ s ∧ p.2 ∈ t}

lemma prod_eq (s : set α) (t : set β) : set.prod s t = prod.fst ⁻¹' s ∩ prod.snd ⁻¹' t := rfl

theorem mem_prod_eq {p : α × β} : p ∈ set.prod s t = (p.1 ∈ s ∧ p.2 ∈ t) := rfl

@[simp] theorem mem_prod {p : α × β} : p ∈ set.prod s t ↔ p.1 ∈ s ∧ p.2 ∈ t := iff.rfl

lemma mk_mem_prod {a : α} {b : β} (a_in : a ∈ s) (b_in : b ∈ t) : (a, b) ∈ set.prod s t := ⟨a_in, b_in⟩

@[simp] theorem prod_empty {s : set α} : set.prod s ∅ = (∅ : set (α × β)) :=
ext $ by simp [set.prod]

@[simp] theorem empty_prod {t : set β} : set.prod ∅ t = (∅ : set (α × β)) :=
ext $ by simp [set.prod]

theorem insert_prod {a : α} {s : set α} {t : set β} :
  set.prod (insert a s) t = (prod.mk a '' t) ∪ set.prod s t :=
ext begin simp [set.prod, image, iff_def, or_imp_distrib] {contextual := tt}; cc end

theorem prod_insert {b : β} {s : set α} {t : set β} :
  set.prod s (insert b t) = ((λa, (a, b)) '' s) ∪ set.prod s t :=
ext begin simp [set.prod, image, iff_def, or_imp_distrib] {contextual := tt}; cc end

theorem prod_preimage_eq {f : γ → α} {g : δ → β} :
  set.prod (preimage f s) (preimage g t) = preimage (λp, (f p.1, g p.2)) (set.prod s t) := rfl

theorem prod_mono {s₁ s₂ : set α} {t₁ t₂ : set β} (hs : s₁ ⊆ s₂) (ht : t₁ ⊆ t₂) :
  set.prod s₁ t₁ ⊆ set.prod s₂ t₂ :=
assume x ⟨h₁, h₂⟩, ⟨hs h₁, ht h₂⟩

theorem prod_inter_prod : set.prod s₁ t₁ ∩ set.prod s₂ t₂ = set.prod (s₁ ∩ s₂) (t₁ ∩ t₂) :=
subset.antisymm
  (assume ⟨a, b⟩ ⟨⟨ha₁, hb₁⟩, ⟨ha₂, hb₂⟩⟩, ⟨⟨ha₁, ha₂⟩, ⟨hb₁, hb₂⟩⟩)
  (subset_inter
    (prod_mono (inter_subset_left _ _) (inter_subset_left _ _))
    (prod_mono (inter_subset_right _ _) (inter_subset_right _ _)))

theorem image_swap_prod : (λp:β×α, (p.2, p.1)) '' set.prod t s = set.prod s t :=
ext $ assume ⟨a, b⟩, by simp [mem_image_eq, set.prod, and_comm]; exact
⟨ assume ⟨b', a', ⟨h_a, h_b⟩, h⟩, by subst a'; subst b'; assumption,
  assume h, ⟨b, a, ⟨rfl, rfl⟩, h⟩⟩

theorem image_swap_eq_preimage_swap : image (@prod.swap α β) = preimage prod.swap :=
image_eq_preimage_of_inverse prod.swap_left_inverse prod.swap_right_inverse

theorem prod_image_image_eq {m₁ : α → γ} {m₂ : β → δ} :
  set.prod (image m₁ s) (image m₂ t) = image (λp:α×β, (m₁ p.1, m₂ p.2)) (set.prod s t) :=
ext $ by simp [-exists_and_distrib_right, exists_and_distrib_right.symm, and.left_comm, and.assoc, and.comm]

theorem prod_range_range_eq {α β γ δ} {m₁ : α → γ} {m₂ : β → δ} :
  set.prod (range m₁) (range m₂) = range (λp:α×β, (m₁ p.1, m₂ p.2)) :=
ext $ by simp [range]

@[simp] theorem prod_singleton_singleton {a : α} {b : β} :
  set.prod {a} {b} = ({(a, b)} : set (α×β)) :=
ext $ by simp [set.prod]

theorem prod_neq_empty_iff {s : set α} {t : set β} :
  set.prod s t ≠ ∅ ↔ (s ≠ ∅ ∧ t ≠ ∅) :=
by simp [not_eq_empty_iff_exists]

theorem prod_eq_empty_iff {s : set α} {t : set β} :
  set.prod s t = ∅ ↔ (s = ∅ ∨ t = ∅) :=
suffices (¬ set.prod s t ≠ ∅) ↔ (¬ s ≠ ∅ ∨ ¬ t ≠ ∅), by simpa only [(≠), classical.not_not],
by classical; rw [prod_neq_empty_iff, not_and_distrib]

@[simp] theorem prod_mk_mem_set_prod_eq {a : α} {b : β} {s : set α} {t : set β} :
  (a, b) ∈ set.prod s t = (a ∈ s ∧ b ∈ t) := rfl

@[simp] theorem univ_prod_univ : set.prod (@univ α) (@univ β) = univ :=
ext $ assume ⟨a, b⟩, by simp

lemma prod_sub_preimage_iff {W : set γ} {f : α × β → γ} :
  set.prod s t ⊆ f ⁻¹' W ↔ ∀ a b, a ∈ s → b ∈ t → f (a, b) ∈ W :=
by simp [subset_def]

end prod

section pi
variables {α : Type*} {π : α → Type*}

def pi (i : set α) (s : Πa, set (π a)) : set (Πa, π a) := { f | ∀a∈i, f a ∈ s a }

@[simp] lemma pi_empty_index (s : Πa, set (π a)) : pi ∅ s = univ := by ext; simp [pi]

@[simp] lemma pi_insert_index (a : α) (i : set α) (s : Πa, set (π a)) :
  pi (insert a i) s = ((λf, f a) ⁻¹' s a) ∩ pi i s :=
by ext; simp [pi, or_imp_distrib, forall_and_distrib]

@[simp] lemma pi_singleton_index (a : α) (s : Πa, set (π a)) :
  pi {a} s = ((λf:(Πa, π a), f a) ⁻¹' s a) :=
by ext; simp [pi]

lemma pi_if {p : α → Prop} [h : decidable_pred p] (i : set α) (s t : Πa, set (π a)) :
  pi i (λa, if p a then s a else t a) = pi {a ∈ i | p a} s ∩ pi {a ∈ i | ¬ p a} t :=
begin
  ext f,
  split,
  { assume h, split; { rintros a ⟨hai, hpa⟩, simpa [*] using h a } },
  { rintros ⟨hs, ht⟩ a hai,
    by_cases p a; simp [*, pi] at * }
end

end pi

end set


/-
Copyright (c) 2020 Johan Commelin and Robert Y. Lewis. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Johan Commelin, Robert Y. Lewis
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.ring_theory.witt_vector.basic
import Mathlib.ring_theory.witt_vector.is_poly
import Mathlib.PostPort

universes u_1

namespace Mathlib

/-!

# `init` and `tail`

Given a Witt vector `x`, we are sometimes interested
in its components before and after an index `n`.
This file defines those operations, proves that `init` is polynomial,
and shows how that polynomial interacts with `mv_polynomial.bind₁`.

## Main declarations

* `witt_vector.init n x`: the first `n` coefficients of `x`, as a Witt vector. All coefficients at
  indices ≥ `n` are 0.
* `witt_vector.tail n x`: the complementary part to `init`. All coefficients at indices < `n` are 0,
  otherwise they are the same as in `x`.
* `witt_vector.coeff_add_of_disjoint`: if `x` and `y` are Witt vectors such that for every `n`
  the `n`-th coefficient of `x` or of `y` is `0`, then the coefficients of `x + y`
  are just `x.coeff n + y.coeff n`.
-/

namespace tactic

namespace interactive

/--
`init_ring` is an auxiliary tactic that discharges goals factoring `init` over ring operations.
-/
end interactive

end tactic

namespace witt_vector

/-- `witt_vector.select P x`, for a predicate `P : ℕ → Prop` is the Witt vector
whose `n`-th coefficient is `x.coeff n` if `P n` is true, and `0` otherwise.
-/
def select {p : ℕ} {R : Type u_1} [comm_ring R] (P : ℕ → Prop) (x : witt_vector p R) :
    witt_vector p R :=
  mk p fun (n : ℕ) => ite (P n) (coeff x n) 0

/-- The polynomial that witnesses that `witt_vector.select` is a polynomial function.
`select_poly n` is `X n` if `P n` holds, and `0` otherwise. -/
def select_poly (P : ℕ → Prop) (n : ℕ) : mv_polynomial ℕ ℤ := ite (P n) (mv_polynomial.X n) 0

theorem coeff_select {p : ℕ} {R : Type u_1} [comm_ring R] (P : ℕ → Prop) (x : witt_vector p R)
    (n : ℕ) : coeff (select P x) n = coe_fn (mv_polynomial.aeval (coeff x)) (select_poly P n) :=
  sorry

theorem select_is_poly {p : ℕ} (P : ℕ → Prop) :
    is_poly p fun (R : Type u_1) (_Rcr : comm_ring R) (x : witt_vector p R) => select P x :=
  Exists.intro (select_poly P)
    (id
      fun (R : Type u_1) (_Rcr : comm_ring R) (x : witt_vector p R) =>
        funext fun (i : ℕ) => coeff_select P x i)

theorem select_add_select_not {p : ℕ} [hp : fact (nat.prime p)] {R : Type u_1} [comm_ring R]
    (P : ℕ → Prop) (x : witt_vector p R) : select P x + select (fun (i : ℕ) => ¬P i) x = x :=
  sorry

theorem coeff_add_of_disjoint {p : ℕ} [hp : fact (nat.prime p)] (n : ℕ) {R : Type u_1} [comm_ring R]
    (x : witt_vector p R) (y : witt_vector p R) (h : ∀ (n : ℕ), coeff x n = 0 ∨ coeff y n = 0) :
    coeff (x + y) n = coeff x n + coeff y n :=
  sorry

/-- `witt_vector.init n x` is the Witt vector of which the first `n` coefficients are those from `x`
and all other coefficients are `0`.
See `witt_vector.tail` for the complementary part.
-/
def init {p : ℕ} {R : Type u_1} [comm_ring R] (n : ℕ) : witt_vector p R → witt_vector p R :=
  select fun (i : ℕ) => i < n

/-- `witt_vector.tail n x` is the Witt vector of which the first `n` coefficients are `0`
and all other coefficients are those from `x`.
See `witt_vector.init` for the complementary part. -/
def tail {p : ℕ} {R : Type u_1} [comm_ring R] (n : ℕ) : witt_vector p R → witt_vector p R :=
  select fun (i : ℕ) => n ≤ i

@[simp] theorem init_add_tail {p : ℕ} [hp : fact (nat.prime p)] {R : Type u_1} [comm_ring R]
    (x : witt_vector p R) (n : ℕ) : init n x + tail n x = x :=
  sorry

@[simp] theorem init_init {p : ℕ} {R : Type u_1} [comm_ring R] (x : witt_vector p R) (n : ℕ) :
    init n (init n x) = init n x :=
  sorry

theorem init_add {p : ℕ} [hp : fact (nat.prime p)] {R : Type u_1} [comm_ring R]
    (x : witt_vector p R) (y : witt_vector p R) (n : ℕ) :
    init n (x + y) = init n (init n x + init n y) :=
  sorry

theorem init_mul {p : ℕ} [hp : fact (nat.prime p)] {R : Type u_1} [comm_ring R]
    (x : witt_vector p R) (y : witt_vector p R) (n : ℕ) :
    init n (x * y) = init n (init n x * init n y) :=
  sorry

theorem init_neg {p : ℕ} [hp : fact (nat.prime p)] {R : Type u_1} [comm_ring R]
    (x : witt_vector p R) (n : ℕ) : init n (-x) = init n (-init n x) :=
  sorry

theorem init_sub {p : ℕ} [hp : fact (nat.prime p)] {R : Type u_1} [comm_ring R]
    (x : witt_vector p R) (y : witt_vector p R) (n : ℕ) :
    init n (x - y) = init n (init n x - init n y) :=
  sorry

/-- `witt_vector.init n x` is polynomial in the coefficients of `x`. -/
theorem init_is_poly (p : ℕ) (n : ℕ) :
    is_poly p fun (R : Type u_1) (_Rcr : comm_ring R) => init n :=
  select_is_poly fun (i : ℕ) => i < n

end Mathlib


import homotopy.basic
import covering_space.lift

variables {X X' Y : Type _} [topological_space X] [topological_space X'] [topological_space Y]

open_locale unit_interval

example (p : C(X', X)) (hp : is_covering_map p) (f₀ f₁ : C(Y, X)) (H : homotopy f₀ f₁) (f₀' : C(Y, X'))
  (hf₀' : p.comp f₀' = f₀) : C(Y × I, X) :=
sorry


/-
Copyright (c) 2017 Microsoft Corporation. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Leonardo de Moura
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default

universes u

namespace Mathlib

namespace rbnode

inductive is_node_of {α : Type u} : rbnode α → rbnode α → α → rbnode α → Prop where
| of_red : ∀ (l : rbnode α) (v : α) (r : rbnode α), is_node_of (red_node l v r) l v r
| of_black : ∀ (l : rbnode α) (v : α) (r : rbnode α), is_node_of (black_node l v r) l v r

def lift {α : Type u} (lt : α → α → Prop) : Option α → Option α → Prop := sorry

inductive is_searchable {α : Type u} (lt : α → α → Prop) : rbnode α → Option α → Option α → Prop
    where
| leaf_s : ∀ {lo hi : Option α}, lift lt lo hi → is_searchable lt leaf lo hi
| red_s :
    ∀ {l r : rbnode α} {v : α} {lo hi : Option α},
      is_searchable lt l lo (some v) →
        is_searchable lt r (some v) hi → is_searchable lt (red_node l v r) lo hi
| black_s :
    ∀ {l r : rbnode α} {v : α} {lo hi : Option α},
      is_searchable lt l lo (some v) →
        is_searchable lt r (some v) hi → is_searchable lt (black_node l v r) lo hi

theorem lo_lt_hi {α : Type u} {t : rbnode α} {lt : α → α → Prop} [is_trans α lt] {lo : Option α}
    {hi : Option α} : is_searchable lt t lo hi → lift lt lo hi :=
  sorry

theorem is_searchable_of_is_searchable_of_incomp {α : Type u} {lt : α → α → Prop} [DecidableRel lt]
    [is_strict_weak_order α lt] {t : rbnode α} {lo : Option α} {hi : α} {hi' : α}
    (hc : ¬lt hi' hi ∧ ¬lt hi hi') (hs : is_searchable lt t lo (some hi)) :
    is_searchable lt t lo (some hi') :=
  sorry

theorem is_searchable_of_incomp_of_is_searchable {α : Type u} {lt : α → α → Prop} [DecidableRel lt]
    [is_strict_weak_order α lt] {t : rbnode α} {lo : α} {lo' : α} {hi : Option α}
    (hc : ¬lt lo' lo ∧ ¬lt lo lo') (hs : is_searchable lt t (some lo) hi) :
    is_searchable lt t (some lo') hi :=
  sorry

theorem is_searchable_some_low_of_is_searchable_of_lt {α : Type u} {lt : α → α → Prop}
    [DecidableRel lt] {t : rbnode α} [is_trans α lt] {lo : α} {hi : Option α} {lo' : α}
    (hlt : lt lo' lo) (hs : is_searchable lt t (some lo) hi) : is_searchable lt t (some lo') hi :=
  sorry

theorem is_searchable_none_low_of_is_searchable_some_low {α : Type u} {lt : α → α → Prop}
    [DecidableRel lt] {t : rbnode α} {y : α} {hi : Option α}
    (hlt : is_searchable lt t (some y) hi) : is_searchable lt t none hi :=
  sorry

theorem is_searchable_some_high_of_is_searchable_of_lt {α : Type u} {lt : α → α → Prop}
    [DecidableRel lt] {t : rbnode α} [is_trans α lt] {lo : Option α} {hi : α} {hi' : α}
    (hlt : lt hi hi') (hs : is_searchable lt t lo (some hi)) : is_searchable lt t lo (some hi') :=
  sorry

theorem is_searchable_none_high_of_is_searchable_some_high {α : Type u} {lt : α → α → Prop}
    [DecidableRel lt] {t : rbnode α} {lo : Option α} {y : α}
    (hlt : is_searchable lt t lo (some y)) : is_searchable lt t lo none :=
  sorry

theorem range {α : Type u} {lt : α → α → Prop} [DecidableRel lt] [is_strict_weak_order α lt]
    {t : rbnode α} {x : α} {lo : Option α} {hi : Option α} :
    is_searchable lt t lo hi → mem lt x t → lift lt lo (some x) ∧ lift lt (some x) hi :=
  sorry

theorem lt_of_mem_left {α : Type u} {lt : α → α → Prop} [DecidableRel lt]
    [is_strict_weak_order α lt] {y : α} {t : rbnode α} {l : rbnode α} {r : rbnode α} {lo : Option α}
    {hi : Option α} :
    is_searchable lt t lo hi → is_node_of t l y r → ∀ {x : α}, mem lt x l → lt x y :=
  sorry

theorem lt_of_mem_right {α : Type u} {lt : α → α → Prop} [DecidableRel lt]
    [is_strict_weak_order α lt] {y : α} {t : rbnode α} {l : rbnode α} {r : rbnode α} {lo : Option α}
    {hi : Option α} :
    is_searchable lt t lo hi → is_node_of t l y r → ∀ {z : α}, mem lt z r → lt y z :=
  sorry

theorem lt_of_mem_left_right {α : Type u} {lt : α → α → Prop} [DecidableRel lt]
    [is_strict_weak_order α lt] {y : α} {t : rbnode α} {l : rbnode α} {r : rbnode α} {lo : Option α}
    {hi : Option α} :
    is_searchable lt t lo hi → is_node_of t l y r → ∀ {x z : α}, mem lt x l → mem lt z r → lt x z :=
  sorry

inductive is_red_black {α : Type u} : rbnode α → color → ℕ → Prop where
| leaf_rb : is_red_black leaf color.black 0
| red_rb :
    ∀ {v : α} {l r : rbnode α} {n : ℕ},
      is_red_black l color.black n →
        is_red_black r color.black n → is_red_black (red_node l v r) color.red n
| black_rb :
    ∀ {v : α} {l r : rbnode α} {n : ℕ} {c₁ c₂ : color},
      is_red_black l c₁ n →
        is_red_black r c₂ n → is_red_black (black_node l v r) color.black (Nat.succ n)

theorem depth_min {α : Type u} {c : color} {n : ℕ} {t : rbnode α} :
    is_red_black t c n → depth min t ≥ n :=
  sorry

theorem depth_max' {α : Type u} {c : color} {n : ℕ} {t : rbnode α} :
    is_red_black t c n → depth max t ≤ upper c n :=
  sorry

theorem depth_max {α : Type u} {c : color} {n : ℕ} {t : rbnode α} (h : is_red_black t c n) :
    depth max t ≤ bit0 1 * n + 1 :=
  le_trans (depth_max' h) (upper_le c n)

theorem balanced {α : Type u} {c : color} {n : ℕ} {t : rbnode α} (h : is_red_black t c n) :
    bit0 1 * depth min t + 1 ≥ depth max t :=
  le_trans (depth_max h) (nat.succ_le_succ (nat.mul_le_mul_left (bit0 1) (depth_min h)))

end Mathlib


/-
Copyright (c) 2021 Yury Kudryashov. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Yury Kudryashov
-/
import topology.urysohns_lemma
import topology.continuous_function.bounded

/-!
# Metrizability of a normal topological space with second countable topology

In this file we define metrizable topological spaces, i.e., topological spaces for which there
exists a metric space structure that generates the same topology.

We also show that a normal topological space with second countable topology `X` is metrizable.

First we prove that `X` can be embedded into `l^∞`, then use this embedding to pull back the metric
space structure.
-/

open set filter metric
open_locale bounded_continuous_function filter topological_space

namespace topological_space

/-- A topological space is metrizable if there exists a metric space structure compatible with the
topology. To endow such a space with a compatible distance, use
`letI : metric_space α := metrizable_space_metric α` -/
class metrizable_space (α : Type*) [t : topological_space α] : Prop :=
(exists_metric : ∃ (m : metric_space α), m.to_uniform_space.to_topological_space = t)

@[priority 100]
instance _root_.metric_space.to_metrizable_space {α : Type*} [m : metric_space α] :
  metrizable_space α :=
⟨⟨m, rfl⟩⟩

/-- Construct on a metrizable space a metric compatible with the topology. -/
noncomputable def metrizable_space_metric
  (α : Type*) [topological_space α] [h : metrizable_space α] :
  metric_space α :=
h.exists_metric.some.replace_topology h.exists_metric.some_spec.symm

@[priority 100]
instance t2_space_of_metrizable_space
  (α : Type*) [topological_space α] [metrizable_space α] : t2_space α :=
by { letI : metric_space α := metrizable_space_metric α, apply_instance }

instance metrizable_space_prod (α : Type*) [topological_space α] [metrizable_space α]
  (β : Type*) [topological_space β] [metrizable_space β] :
  metrizable_space (α × β) :=
begin
  letI : metric_space α := metrizable_space_metric α,
  letI : metric_space β := metrizable_space_metric β,
  apply_instance
end

instance metrizable_space.subtype {α : Type*} [topological_space α] [metrizable_space α]
  (s : set α) : metrizable_space s :=
by { letI := metrizable_space_metric α, apply_instance }

/-- Given an embedding of a topological space into a metrizable space, the source space is also
metrizable. -/
lemma _root_.embedding.metrizable_space {α β : Type*} [topological_space α] [topological_space β]
  [metrizable_space β] {f : α → β} (hf : embedding f) :
  metrizable_space α :=
begin
  letI : metric_space β := metrizable_space_metric β,
  exact ⟨⟨hf.comap_metric_space f, rfl⟩⟩
end

variables (X : Type*) [topological_space X] [normal_space X] [second_countable_topology X]

/-- A normal topological space with second countable topology can be embedded into `l^∞ = ℕ →ᵇ ℝ`.
-/
lemma exists_embedding_l_infty : ∃ f : X → (ℕ →ᵇ ℝ), embedding f :=
begin
  -- Choose a countable basis, and consider the set `s` of pairs of set `(U, V)` such that `U ∈ B`,
  -- `V ∈ B`, and `closure U ⊆ V`.
  rcases exists_countable_basis X with ⟨B, hBc, -, hB⟩,
  set s : set (set X × set X) := {UV ∈ B ×ˢ B| closure UV.1 ⊆ UV.2},
  -- `s` is a countable set.
  haveI : encodable s := ((hBc.prod hBc).mono (inter_subset_left _ _)).to_encodable,
  -- We don't have the space of bounded (possibly discontinuous) functions, so we equip `s`
  -- with the discrete topology and deal with `s →ᵇ ℝ` instead.
  letI : topological_space s := ⊥, haveI : discrete_topology s := ⟨rfl⟩,
  suffices : ∃ f : X → (s →ᵇ ℝ), embedding f,
  { rcases this with ⟨f, hf⟩,
    exact ⟨λ x, (f x).extend (encodable.encode' s) 0, (bounded_continuous_function.isometry_extend
      (encodable.encode' s) (0 : ℕ →ᵇ ℝ)).embedding.comp hf⟩ },
  have hd : ∀ UV : s, disjoint (closure UV.1.1) (UV.1.2ᶜ) :=
    λ UV, disjoint_compl_right.mono_right (compl_subset_compl.2 UV.2.2),
  -- Choose a sequence of `εₙ > 0`, `n : s`, that is bounded above by `1` and tends to zero
  -- along the `cofinite` filter.
  obtain ⟨ε, ε01, hε⟩ : ∃ ε : s → ℝ, (∀ UV, ε UV ∈ Ioc (0 : ℝ) 1) ∧ tendsto ε cofinite (𝓝 0),
  { rcases pos_sum_of_encodable zero_lt_one s with ⟨ε, ε0, c, hεc, hc1⟩,
    refine ⟨ε, λ UV, ⟨ε0 UV, _⟩, hεc.summable.tendsto_cofinite_zero⟩,
    exact (le_has_sum hεc UV $ λ _ _, (ε0 _).le).trans hc1 },
  /- For each `UV = (U, V) ∈ s` we use Urysohn's lemma to choose a function `f UV` that is equal to
  zero on `U` and is equal to `ε UV` on the complement to `V`. -/
  have : ∀ UV : s, ∃ f : C(X, ℝ), eq_on f 0 UV.1.1 ∧ eq_on f (λ _, ε UV) UV.1.2ᶜ ∧
    ∀ x, f x ∈ Icc 0 (ε UV),
  { intro UV,
    rcases exists_continuous_zero_one_of_closed is_closed_closure
      (hB.is_open UV.2.1.2).is_closed_compl (hd UV) with ⟨f, hf₀, hf₁, hf01⟩,
    exact ⟨ε UV • f, λ x hx, by simp [hf₀ (subset_closure hx)], λ x hx, by simp [hf₁ hx],
      λ x, ⟨mul_nonneg (ε01 _).1.le (hf01 _).1, mul_le_of_le_one_right (ε01 _).1.le (hf01 _).2⟩⟩ },
  choose f hf0 hfε hf0ε,
  have hf01 : ∀ UV x, f UV x ∈ Icc (0 : ℝ) 1,
    from λ UV x, Icc_subset_Icc_right (ε01 _).2 (hf0ε _ _),
  /- The embedding is given by `F x UV = f UV x`. -/
  set F : X → s →ᵇ ℝ := λ x, ⟨⟨λ UV, f UV x, continuous_of_discrete_topology⟩, 1, λ UV₁ UV₂,
    real.dist_le_of_mem_Icc_01 (hf01 _ _) (hf01 _ _)⟩,
  have hF : ∀ x UV, F x UV = f UV x := λ _ _, rfl,
  refine ⟨F, embedding.mk' _ (λ x y hxy, _) (λ x, le_antisymm _ _)⟩,
  { /- First we prove that `F` is injective. Indeed, if `F x = F y` and `x ≠ y`, then we can find
    `(U, V) ∈ s` such that `x ∈ U` and `y ∉ V`, hence `F x UV = 0 ≠ ε UV = F y UV`. -/
    refine not_not.1 (λ Hne, _), -- `by_contra Hne` timeouts
    rcases hB.mem_nhds_iff.1 (is_open_ne.mem_nhds Hne) with ⟨V, hVB, hxV, hVy⟩,
    rcases hB.exists_closure_subset (hB.mem_nhds hVB hxV) with ⟨U, hUB, hxU, hUV⟩,
    set UV : ↥s := ⟨(U, V), ⟨hUB, hVB⟩, hUV⟩,
    apply (ε01 UV).1.ne,
    calc (0 : ℝ) = F x UV : (hf0 UV hxU).symm
             ... = F y UV : by rw hxy
             ... = ε UV   : hfε UV (λ h : y ∈ V, hVy h rfl) },
  { /- Now we prove that each neighborhood `V` of `x : X` include a preimage of a neighborhood of
    `F x` under `F`. Without loss of generality, `V` belongs to `B`. Choose `U ∈ B` such that
    `x ∈ V` and `closure V ⊆ U`. Then the preimage of the `(ε (U, V))`-neighborhood of `F x`
    is included by `V`. -/
    refine ((nhds_basis_ball.comap _).le_basis_iff hB.nhds_has_basis).2 _,
    rintro V ⟨hVB, hxV⟩,
    rcases hB.exists_closure_subset (hB.mem_nhds hVB hxV) with ⟨U, hUB, hxU, hUV⟩,
    set UV : ↥s := ⟨(U, V), ⟨hUB, hVB⟩, hUV⟩,
    refine ⟨ε UV, (ε01 UV).1, λ y (hy : dist (F y) (F x) < ε UV), _⟩,
    replace hy : dist (F y UV) (F x UV) < ε UV,
      from (bounded_continuous_function.dist_coe_le_dist _).trans_lt hy,
    contrapose! hy,
    rw [hF, hF, hfε UV hy, hf0 UV hxU, pi.zero_apply, dist_zero_right],
    exact le_abs_self _ },
  { /- Finally, we prove that `F` is continuous. Given `δ > 0`, consider the set `T` of `(U, V) ∈ s`
    such that `ε (U, V) ≥ δ`. Since `ε` tends to zero, `T` is finite. Since each `f` is continuous,
    we can choose a neighborhood such that `dist (F y (U, V)) (F x (U, V)) ≤ δ` for any
    `(U, V) ∈ T`. For `(U, V) ∉ T`, the same inequality is true because both `F y (U, V)` and
    `F x (U, V)` belong to the interval `[0, ε (U, V)]`. -/
    refine (nhds_basis_closed_ball.comap _).ge_iff.2 (λ δ δ0, _),
    have h_fin : finite {UV : s | δ ≤ ε UV}, by simpa only [← not_lt] using hε (gt_mem_nhds δ0),
    have : ∀ᶠ y in 𝓝 x, ∀ UV, δ ≤ ε UV → dist (F y UV) (F x UV) ≤ δ,
    { refine (eventually_all_finite h_fin).2 (λ UV hUV, _),
      exact (f UV).continuous.tendsto x (closed_ball_mem_nhds _ δ0) },
    refine this.mono (λ y hy, (bounded_continuous_function.dist_le δ0.le).2 $ λ UV, _),
    cases le_total δ (ε UV) with hle hle,
    exacts [hy _ hle, (real.dist_le_of_mem_Icc (hf0ε _ _) (hf0ε _ _)).trans (by rwa sub_zero)] }
end

/-- A normal topological space with second countable topology `X` is metrizable: there exists a
metric space structure that generates the same topology. -/
lemma metrizable_space_of_normal_second_countable : metrizable_space X :=
let ⟨f, hf⟩ := exists_embedding_l_infty X in hf.metrizable_space

instance : metrizable_space ennreal := metrizable_space_of_normal_second_countable ennreal

end topological_space


/-
Copyright (c) 2020 Simon Hudon. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Author: Simon Hudon
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.data.nat.upto
import Mathlib.data.stream.basic
import Mathlib.data.pfun
import Mathlib.PostPort

universes u_3 l u_1 u_2

namespace Mathlib

/-!
# Fixed point

This module defines a generic `fix` operator for defining recursive
computations that are not necessarily well-founded or productive.
An instance is defined for `roption`.

## Main definition

 * class `has_fix`
 * `roption.fix`
-/

/-- `has_fix α` gives us a way to calculate the fixed point
of function of type `α → α`. -/
class has_fix (α : Type u_3)
where
  fix : (α → α) → α

namespace roption

/-- A series of successive, finite approximation of the fixed point of `f`, defined by
`approx f n = f^[n] ⊥`. The limit of this chain is the fixed point of `f`. -/
def fix.approx {α : Type u_1} {β : α → Type u_2} (f : ((a : α) → roption (β a)) → (a : α) → roption (β a)) : stream ((a : α) → roption (β a)) :=
  sorry

/-- loop body for finding the fixed point of `f` -/
def fix_aux {α : Type u_1} {β : α → Type u_2} (f : ((a : α) → roption (β a)) → (a : α) → roption (β a)) {p : ℕ → Prop} (i : nat.upto p) (g : (j : nat.upto p) → i < j → (a : α) → roption (β a)) (a : α) : roption (β a) :=
  f fun (x : α) => assert (¬p (subtype.val i)) fun (h : ¬p (subtype.val i)) => g (nat.upto.succ i h) sorry x

/-- The least fixed point of `f`.

If `f` is a continuous function (according to complete partial orders),
it satisfies the equations:

  1. `fix f = f (fix f)`          (is a fixed point)
  2. `∀ X, f X ≤ X → fix f ≤ X`   (least fixed point)
-/
protected def fix {α : Type u_1} {β : α → Type u_2} (f : ((a : α) → roption (β a)) → (a : α) → roption (β a)) (x : α) : roption (β x) :=
  assert (∃ (i : ℕ), dom sorry) fun (h : ∃ (i : ℕ), dom sorry) => well_founded.fix sorry (fix_aux f) nat.upto.zero x

protected theorem fix_def {α : Type u_1} {β : α → Type u_2} (f : ((a : α) → roption (β a)) → (a : α) → roption (β a)) {x : α} (h' : ∃ (i : ℕ), dom (fix.approx f i x)) : roption.fix f x = fix.approx f (Nat.succ (nat.find h')) x := sorry

theorem fix_def' {α : Type u_1} {β : α → Type u_2} (f : ((a : α) → roption (β a)) → (a : α) → roption (β a)) {x : α} (h' : ¬∃ (i : ℕ), dom (fix.approx f i x)) : roption.fix f x = none := sorry

end roption

namespace roption

protected instance has_fix {α : Type u_1} : has_fix (roption α) :=
  has_fix.mk fun (f : roption α → roption α) => roption.fix (fun (x : Unit → roption α) (u : Unit) => f (x u)) Unit.unit

end roption

namespace pi

protected instance roption.has_fix {α : Type u_1} {β : Type u_2} : has_fix (α → roption β) :=
  has_fix.mk roption.fix


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

import category_theory.abelian.basic

/-!
# Idempotent complete categories

In this file, we define the notion of idempotent complete categories
(also known as Karoubian categories, or pseudoabelian in the case of
preadditive categories).

## Main definitions

- `is_idempotent_complete C` expresses that `C` is idempotent complete, i.e.
all idempotents in `C` split. Other characterisations of idempotent completeness are given
by `is_idempotent_complete_iff_has_equalizer_of_id_and_idempotent` and
`is_idempotent_complete_iff_idempotents_have_kernels`.
- `is_idempotent_complete_of_abelian` expresses that abelian categories are
idempotent complete.
- `is_idempotent_complete_iff_of_equivalence` expresses that if two categories `C` and `D`
are equivalent, then `C` is idempotent complete iff `D` is.
- `is_idempotent_complete_iff_opposite` expresses that `Cᵒᵖ` is idempotent complete
iff `C` is.

## References
* [Stacks: Karoubian categories] https://stacks.math.columbia.edu/tag/09SF

-/

open category_theory
open category_theory.category
open category_theory.limits
open category_theory.preadditive
open opposite

namespace category_theory

variables (C : Type*) [category C]

/-- A category is idempotent complete iff all idempotent endomorphisms `p`
split as a composition `p = e ≫ i` with `i ≫ e = 𝟙 _` -/
class is_idempotent_complete : Prop :=
(idempotents_split : ∀ (X : C) (p : X ⟶ X), p ≫ p = p →
  ∃ (Y : C) (i : Y ⟶ X) (e : X ⟶ Y), i ≫ e = 𝟙 Y ∧ e ≫ i = p)

namespace idempotents

/-- A category is idempotent complete iff for all idempotent endomorphisms,
the equalizer of the identity and this idempotent exists. -/
lemma is_idempotent_complete_iff_has_equalizer_of_id_and_idempotent :
  is_idempotent_complete C ↔ ∀ (X : C) (p : X ⟶ X), p ≫ p = p → has_equalizer (𝟙 X) p :=
begin
  split,
  { introI,
    intros X p hp,
    rcases is_idempotent_complete.idempotents_split X p hp with ⟨Y, i, e, ⟨h₁, h₂⟩⟩,
    exact ⟨nonempty.intro
      { cone := fork.of_ι i
          (show i ≫ 𝟙 X = i ≫ p, by rw [comp_id, ← h₂, ← assoc, h₁, id_comp]),
        is_limit := begin
          apply fork.is_limit.mk',
          intro s,
          refine ⟨s.ι ≫ e, _⟩,
          split,
          { erw [assoc, h₂, ← limits.fork.condition s, comp_id], },
          { intros m hm,
            rw fork.ι_of_ι at hm,
            rw [← hm],
            simp only [← hm, assoc, h₁],
            exact (comp_id m).symm }
        end }⟩, },
  { intro h,
    refine ⟨_⟩,
    intros X p hp,
    haveI := h X p hp,
    use equalizer (𝟙 X) p,
    use equalizer.ι (𝟙 X) p,
    use equalizer.lift p (show p ≫ 𝟙 X = p ≫ p, by rw [hp, comp_id]),
    split,
    { ext,
      rw [assoc, equalizer.lift_ι, id_comp],
      conv { to_rhs, erw [← comp_id (equalizer.ι (𝟙 X) p)], },
      exact (limits.fork.condition (equalizer.fork (𝟙 X) p)).symm, },
    { rw [equalizer.lift_ι], }, }
end

variables {C}

/-- In a preadditive category, when `p : X ⟶ X` is idempotent,
then `𝟙 X - p` is also idempotent. -/
lemma idem_of_id_sub_idem [preadditive C]
  {X : C} (p : X ⟶ X) (hp : p ≫ p = p) :
  (𝟙 _ - p) ≫ (𝟙 _ - p) = (𝟙 _ - p) :=
by simp only [comp_sub, sub_comp, id_comp, comp_id, hp, sub_self, sub_zero]

variables (C)

/-- A preadditive category is pseudoabelian iff all idempotent endomorphisms have a kernel. -/
lemma is_idempotent_complete_iff_idempotents_have_kernels [preadditive C] :
  is_idempotent_complete C ↔ ∀ (X : C) (p : X ⟶ X), p ≫ p = p → has_kernel p :=
begin
  rw is_idempotent_complete_iff_has_equalizer_of_id_and_idempotent,
  split,
  { intros h X p hp,
    haveI := h X (𝟙 _ - p) (idem_of_id_sub_idem p hp),
    convert has_kernel_of_has_equalizer (𝟙 X) (𝟙 X - p),
    rw [sub_sub_cancel], },
  { intros h X p hp,
    haveI : has_kernel (𝟙 _ - p) := h X (𝟙 _ - p) (idem_of_id_sub_idem p hp),
    apply preadditive.has_equalizer_of_has_kernel, },
end

/-- An abelian category is idempotent complete. -/
@[priority 100]
instance is_idempotent_complete_of_abelian (D : Type*) [category D] [abelian D] :
  is_idempotent_complete D :=
by { rw is_idempotent_complete_iff_idempotents_have_kernels, intros, apply_instance, }

variables {C}

lemma split_imp_of_iso {X X' : C} (φ : X ≅ X') (p : X ⟶ X) (p' : X' ⟶ X')
  (hpp' : p ≫ φ.hom = φ.hom ≫ p')
  (h : ∃ (Y : C) (i : Y ⟶ X) (e : X ⟶ Y), i ≫ e = 𝟙 Y ∧ e ≫ i = p) :
  (∃ (Y' : C) (i' : Y' ⟶ X') (e' : X' ⟶ Y'), i' ≫ e' = 𝟙 Y' ∧ e' ≫ i' = p') :=
begin
  rcases h with ⟨Y, i, e, ⟨h₁, h₂⟩⟩,
  use [Y, i ≫ φ.hom, φ.inv ≫ e],
  split,
  { slice_lhs 2 3 { rw φ.hom_inv_id, },
    rw [id_comp, h₁], },
  { slice_lhs 2 3 { rw h₂, },
    rw [hpp', ← assoc, φ.inv_hom_id, id_comp], }
end

lemma split_iff_of_iso {X X' : C} (φ : X ≅ X') (p : X ⟶ X) (p' : X' ⟶ X')
  (hpp' : p ≫ φ.hom = φ.hom ≫ p') :
  (∃ (Y : C) (i : Y ⟶ X) (e : X ⟶ Y), i ≫ e = 𝟙 Y ∧ e ≫ i = p) ↔
  (∃ (Y' : C) (i' : Y' ⟶ X') (e' : X' ⟶ Y'), i' ≫ e' = 𝟙 Y' ∧ e' ≫ i' = p') :=
begin
  split,
  { exact split_imp_of_iso φ p p' hpp', },
  { apply split_imp_of_iso φ.symm p' p,
    rw [← comp_id p, ← φ.hom_inv_id],
    slice_rhs 2 3 { rw hpp', },
    slice_rhs 1 2 { erw φ.inv_hom_id, },
    simpa only [id_comp], },
end

lemma equivalence.is_idempotent_complete {D : Type*} [category D] (ε : C ≌ D)
  (h : is_idempotent_complete C) : is_idempotent_complete D :=
begin
  refine ⟨_⟩,
  intros X' p hp,
  let φ := ε.counit_iso.symm.app X',
  erw split_iff_of_iso φ p (φ.inv ≫ p ≫ φ.hom)
    (by { slice_rhs 1 2 { rw φ.hom_inv_id, }, rw id_comp,}),
  rcases is_idempotent_complete.idempotents_split (ε.inverse.obj X') (ε.inverse.map p)
    (by rw [← ε.inverse.map_comp, hp]) with ⟨Y, i, e, ⟨h₁,h₂⟩⟩,
  use [ε.functor.obj Y, ε.functor.map i, ε.functor.map e],
  split,
  { rw [← ε.functor.map_comp, h₁, ε.functor.map_id], },
  { simpa only [← ε.functor.map_comp, h₂, equivalence.fun_inv_map], },
end

/-- If `C` and `D` are equivalent categories, that `C` is idempotent complete iff `D` is. -/
lemma is_idempotent_complete_iff_of_equivalence {D : Type*} [category D] (ε : C ≌ D) :
  is_idempotent_complete C ↔ is_idempotent_complete D :=
begin
  split,
  { exact equivalence.is_idempotent_complete ε, },
  { exact equivalence.is_idempotent_complete ε.symm, },
end

lemma is_idempotent_complete_of_is_idempotent_complete_opposite
  (h : is_idempotent_complete Cᵒᵖ) : is_idempotent_complete C :=
begin
  refine ⟨_⟩,
  intros X p hp,
  rcases is_idempotent_complete.idempotents_split (op X) p.op
    (by rw [← op_comp, hp]) with ⟨Y, i, e, ⟨h₁, h₂⟩⟩,
  use [Y.unop, e.unop, i.unop],
  split,
  { simpa only [← unop_comp, h₁], },
  { simpa only [← unop_comp, h₂], },
end

lemma is_idempotent_complete_iff_opposite :
  is_idempotent_complete Cᵒᵖ ↔ is_idempotent_complete C :=
begin
  split,
  { exact is_idempotent_complete_of_is_idempotent_complete_opposite, },
  { intro h,
    apply is_idempotent_complete_of_is_idempotent_complete_opposite,
    rw is_idempotent_complete_iff_of_equivalence (op_op_equivalence C),
    exact h, },
end

instance [is_idempotent_complete C] : is_idempotent_complete (Cᵒᵖ) :=
by rwa is_idempotent_complete_iff_opposite

end idempotents

end category_theory


import data.list algebra.ring tactic.omega defs

lemma single_complete: almost_complete [●] :=
begin
  apply almost_complete.cmp_rule,
  existsi ([]),
  intros t h,
  exfalso, apply h, apply grow_list.head_grow,
  apply grow.single_grow
end

lemma single_grow : ∀ t : bintree, (t ↣ ●) → t = ● :=
begin
  intros t H1,
  destruct t,
  begin intros, assumption end,
  repeat {
    intros a H2,
    rewrite H2 at H1,
    cases H1,
  }, -- this proves the first two goals
  begin
    intros a a1 H2,
    rewrite H2 at H1,
    cases H1,
  end -- this proves the last two goals
end


import algebra.module.linear_map
import data.real.basic

variables (R : Type*) (M : Type*) (X : Type*)
[field R] [add_comm_group M] [module R M] [set X]
[add_comm_group(X -> M)] [module R (X -> M)]
theorem cpge_applin_5_a  :
∀ (a : X), ∃ g : linear_map R (X->M) M, (λf : X -> M, f a) = g := sorry


/-
Copyright (c) 2019 Yury Kudryashov. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Yury Kudryashov
-/
import category_theory.endomorphism
import category_theory.category.Cat
import algebra.category.Mon.basic

/-!
# Single-object category

Single object category with a given monoid of endomorphisms.
It is defined to facilitate transfering some definitions and lemmas (e.g., conjugacy etc.)
from category theory to monoids and groups.

## Main definitions

Given a type `α` with a monoid structure, `single_obj α` is `unit` type with `category` structure
such that `End (single_obj α).star` is the monoid `α`.  This can be extended to a functor `Mon ⥤
Cat`.

If `α` is a group, then `single_obj α` is a groupoid.

An element `x : α` can be reinterpreted as an element of `End (single_obj.star α)` using
`single_obj.to_End`.

## Implementation notes

- `category_struct.comp` on `End (single_obj.star α)` is `flip (*)`, not `(*)`. This way
  multiplication on `End` agrees with the multiplication on `α`.

- By default, Lean puts instances into `category_theory` namespace instead of
  `category_theory.single_obj`, so we give all names explicitly.
-/

universes u v w

namespace category_theory
/-- Type tag on `unit` used to define single-object categories and groupoids. -/
@[nolint unused_arguments has_inhabited_instance]
def single_obj (α : Type u) : Type := unit

namespace single_obj

variables (α : Type u)

/-- One and `flip (*)` become `id` and `comp` for morphisms of the single object category. -/
instance category_struct [has_one α] [has_mul α] : category_struct (single_obj α) :=
{ hom := λ _ _, α,
  comp := λ _ _ _ x y, y * x,
  id := λ _, 1 }

/-- Monoid laws become category laws for the single object category. -/
instance category [monoid α] : category (single_obj α) :=
{ comp_id' := λ _ _, one_mul,
  id_comp' := λ _ _, mul_one,
  assoc' := λ _ _ _ _ x y z, (mul_assoc z y x).symm }

lemma id_as_one [monoid α] (x : single_obj α) : 𝟙 x = 1 := rfl

lemma comp_as_mul [monoid α] {x y z : single_obj α} (f : x ⟶ y) (g : y ⟶ z) :
  f ≫ g = g * f := rfl

/--
Groupoid structure on `single_obj α`.

See https://stacks.math.columbia.edu/tag/0019.
-/
instance groupoid [group α] : groupoid (single_obj α) :=
{ inv := λ _ _ x, x⁻¹,
  inv_comp' := λ _ _, mul_right_inv,
  comp_inv' := λ _ _, mul_left_inv }

/-- The single object in `single_obj α`. -/
protected def star : single_obj α := unit.star

/-- The endomorphisms monoid of the only object in `single_obj α` is equivalent to the original
     monoid α. -/
def to_End [monoid α] : α ≃* End (single_obj.star α) :=
{ map_mul' := λ x y, rfl,
  .. equiv.refl α }

lemma to_End_def [monoid α] (x : α) : to_End α x = x := rfl

/-- There is a 1-1 correspondence between monoid homomorphisms `α → β` and functors between the
    corresponding single-object categories. It means that `single_obj` is a fully faithful
    functor.

See https://stacks.math.columbia.edu/tag/001F --
although we do not characterize when the functor is full or faithful.
-/
def map_hom (α : Type u) (β : Type v) [monoid α] [monoid β] :
  (α →* β) ≃ (single_obj α) ⥤ (single_obj β) :=
{ to_fun := λ f,
  { obj := id,
    map := λ _ _, ⇑f,
    map_id' := λ _, f.map_one,
    map_comp' := λ _ _ _ x y, f.map_mul y x },
  inv_fun := λ f,
    { to_fun := @functor.map _ _ _ _ f (single_obj.star α) (single_obj.star α),
      map_one' := f.map_id _,
      map_mul' := λ x y, f.map_comp y x },
  left_inv := λ ⟨f, h₁, h₂⟩, rfl,
  right_inv := λ f, by cases f; obviously }

lemma map_hom_id (α : Type u) [monoid α] : map_hom α α (monoid_hom.id α) = 𝟭 _ := rfl

lemma map_hom_comp {α : Type u} {β : Type v} [monoid α] [monoid β] (f : α →* β)
  {γ : Type w} [monoid γ] (g : β →* γ) :
  map_hom α γ (g.comp f) = map_hom α β f ⋙ map_hom β γ g :=
rfl

/-- Given a function `f : C → G` from a category to a group, we get a functor
    `C ⥤ G` sending any morphism `x ⟶ y` to `f y * (f x)⁻¹`. -/
@[simps] def difference_functor {C G} [category C] [group G] (f : C → G) : C ⥤ single_obj G :=
{ obj := λ _, (),
  map := λ x y _, f y * (f x)⁻¹,
  map_id' := by { intro, rw [single_obj.id_as_one, mul_right_inv] },
  map_comp' := by { intros, rw [single_obj.comp_as_mul, ←mul_assoc,
    mul_left_inj, mul_assoc, inv_mul_self, mul_one] } }

end single_obj

end category_theory

open category_theory

namespace monoid_hom

/-- Reinterpret a monoid homomorphism `f : α → β` as a functor `(single_obj α) ⥤ (single_obj β)`.
See also `category_theory.single_obj.map_hom` for an equivalence between these types. -/
@[reducible] def to_functor {α : Type u} {β : Type v} [monoid α] [monoid β] (f : α →* β) :
  (single_obj α) ⥤ (single_obj β) :=
single_obj.map_hom α β f

@[simp] lemma id_to_functor (α : Type u) [monoid α] : (id α).to_functor = 𝟭 _ := rfl
@[simp] lemma comp_to_functor {α : Type u} {β : Type v} [monoid α] [monoid β] (f : α →* β)
  {γ : Type w} [monoid γ] (g : β →* γ) :
  (g.comp f).to_functor = f.to_functor ⋙ g.to_functor :=
rfl

end monoid_hom

namespace units

variables (α : Type u) [monoid α]

/--
The units in a monoid are (multiplicatively) equivalent to
the automorphisms of `star` when we think of the monoid as a single-object category. -/
def to_Aut : units α ≃* Aut (single_obj.star α) :=
(units.map_equiv (single_obj.to_End α)).trans $
  Aut.units_End_equiv_Aut _

@[simp] lemma to_Aut_hom (x : units α) : (to_Aut α x).hom = single_obj.to_End α x := rfl
@[simp] lemma to_Aut_inv (x : units α) :
  (to_Aut α x).inv = single_obj.to_End α (x⁻¹ : units α) :=
rfl
end units

namespace Mon

open category_theory

/-- The fully faithful functor from `Mon` to `Cat`. -/
def to_Cat : Mon ⥤ Cat :=
{ obj := λ x, Cat.of (single_obj x),
  map := λ x y f, single_obj.map_hom x y f }

instance to_Cat_full : full to_Cat :=
{ preimage := λ x y, (single_obj.map_hom x y).inv_fun,
  witness' := λ x y, by apply equiv.right_inv }

instance to_Cat_faithful : faithful to_Cat :=
{ map_injective' := λ x y, by apply equiv.injective }

end Mon


import tactic.tidy
import set_category.diagram_lemmas
import set_category.category_set
import help_functions
import set_category.limits.Equalizer
import set_category.limits.Product
import category_theory.types

namespace Pullback

open set
     diagram_lemmas
     classical
     function
     help_functions
     Equalizer
     Product
     category_theory
     category_set

universes v u

local notation f ` ⊚ `:80 g:80 := category_struct.comp g f

def is_pullback {X : Type v} [category X]
    {A₁ A₂ B : X}
    (f : A₁ ⟶ B) (g : A₂ ⟶ B)
    {P : X} (p₁ : P ⟶ A₁) (p₂ : P ⟶ A₂): Prop :=
    f ⊚ p₁ = g ⊚ p₂ ∧
    Π {Q : X} (q₁ : Q ⟶ A₁) (q₂ : Q ⟶ A₂),
        f ⊚ q₁ = g ⊚ q₂ →
            ∃! h : Q ⟶ P, q₁ = p₁ ⊚ h ∧ q₂ = p₂ ⊚ h

lemma equalizer_product_is_pullback_cat
    {X : Type u} [category X]
    {A₁ A₂ B P E : X}
    (f : A₁ ⟶ B) (g : A₂ ⟶ B)
    (π₁ : P ⟶ A₁) (π₂ : P ⟶ A₂)
    (pr : is_product A₁ A₂ π₁ π₂)
    (e : E ⟶ P)
    (eqauliz : is_equalizer (f ⊚ π₁) (g ⊚ π₂) e) :
    is_pullback f g
        (π₁ ⊚ e)
        (π₂ ⊚ e)
    :=
    ⟨ begin
        tidy
     end
    ,
    begin
        intros Q q₁ q₂ fq₁_gq₂,
        let p : Q ⟶ P := some (pr  Q q₁ q₂),
        have spec_p : q₁ = π₁ ⊚ p ∧ q₂ = π₂ ⊚ p := (some_spec (pr Q q₁ q₂)).1,

        have eq_comp : f ⊚ π₁ ⊚ p  = g ⊚ π₂ ⊚ p :=
            calc f ⊚ π₁ ⊚ p   = f ⊚ (π₁ ⊚ p)   : by tidy
                    ...         = f ⊚ q₁         : by rw ← spec_p.1
                    ...         = g ⊚ q₂         : fq₁_gq₂
                    ...         = g ⊚ (π₂ ⊚ p)  : by rw spec_p.2
                    ...         = g ⊚ π₂ ⊚ p    : by tidy,

        let h : Q ⟶ E := some (eqauliz.2 p eq_comp),
        have spec_h : p = e ⊚ h := (some_spec (eqauliz.2 p eq_comp)).1,
        use h,
        have h0 : q₁ = π₁ ⊚ e ⊚ h ∧ q₂ = π₂ ⊚ e ⊚ h :=
            ⟨
                by simp [spec_h , spec_p.1]
                ,
                by simp [spec_h , spec_p.2]
            ⟩ ,
        split,
        exact h0,
        assume (y : Q ⟶ E) (spec_y : q₁ = π₁ ⊚ e ⊚ y ∧ q₂ = π₂ ⊚ e ⊚ y),
        have s0 : π₁ ⊚ (e ⊚ h) = π₁ ⊚ (e ⊚ y) :=
            calc π₁ ⊚ (e ⊚ h) = π₁ ⊚ e ⊚ h      : by tidy
                ...            = q₁                : eq.symm h0.1
                ...            = π₁ ⊚ e ⊚ y      : spec_y.1
                ...            = π₁ ⊚ (e ⊚ y)    : by tidy,
        have s1 : π₂ ⊚ (e ⊚ h) = π₂ ⊚ (e ⊚ y) :=
            calc π₂ ⊚ (e ⊚ h) = π₂ ⊚ e ⊚ h      : by tidy
            ...                = q₂                : eq.symm h0.2
            ...                = π₂ ⊚ e ⊚ y      : spec_y.2
            ...                = π₂ ⊚ (e ⊚ y)    : by tidy,
        have eh_ey : e ⊚ h = e ⊚ y :=
            jointly_mono A₁ A₂ P π₁ π₂ pr s0 s1,

        haveI m_e : mono e := equalizer_is_mono (f ⊚ π₁) (g ⊚ π₂) e eqauliz,
        exact left_cancel e (eq.symm eh_ey)
    end ⟩

variables {A₁ A₂ B : Type u}
variables (f : A₁ ⟶ B) (g : A₂ ⟶ B)

lemma equalizer_product_is_pullback :
    let P := A₁ × A₂ in
    let π₁ : P → A₁ := λ ab, ab.1 in
    let π₂ : P → A₂ := λ ab, ab.2 in
    let E := equalizer_set (f ∘ π₁) (g ∘ π₂) in
    let e := E ↪ P in

    is_pullback f g
        (π₁ ∘ e)
        (π₂ ∘ e)
    :=
    let P := A₁ × A₂ in
    let π₁ : P → A₁ := λ ab, ab.1 in
    let π₂ : P → A₂ := λ ab, ab.2 in
    let E := equalizer_set (f ∘ π₁) (g ∘ π₂) in
    let e : E → P := E ↪ P in
    ⟨ begin
        tidy
    end
    ,
    begin
        intros Q q₁ q₂ fq₁_gq₂,
        have eq := eqaulizer_set_is_equalizer (f ∘ π₁) (g ∘ π₂),
        have pr := cartesian_product_is_product A₁ A₂ Q q₁ q₂,
        let p : Q → P := some pr,
        have spec_p : q₁ = π₁ ∘ p ∧ q₂ = π₂ ∘ p := (some_spec pr).1,

        have eq_comp : f ∘ π₁ ∘ p = g ∘ π₂ ∘ p :=
            spec_p.2 ▸ (spec_p.1 ▸ fq₁_gq₂),

        let h : Q → E := some (eq.2 p eq_comp),
        have spec_h : p = e ∘ h := (some_spec (eq.2 p eq_comp)).1,
        use h,
        split,
        have h0 : q₁ = π₁ ∘ e ∘ h ∧ q₂ = π₂ ∘ e ∘ h :=
            ⟨
                by simp [spec_h , spec_p.1]
                ,
                by simp [spec_h , spec_p.2]
            ⟩ ,
        exact h0,
        assume (y : Q → E) (hy : q₁ = π₁ ∘ e ∘ y ∧ q₂ = π₂ ∘ e ∘ y),
        have s0 : π₁ ∘ e ∘ h = π₁ ∘ e ∘ y :=
                spec_h ▸ (spec_p.1 ▸ hy.1),
        have s1 : π₂ ∘ e ∘ h = π₂ ∘ e ∘ y :=
                spec_h ▸ (spec_p.2 ▸ hy.2),
        have eh_ey : e ∘ h = e ∘ y :=
            jointly_mono A₁ A₂ (A₁ × A₂) prod.fst prod.snd
                (cartesian_product_is_product A₁ A₂) s0 s1,

        have elements : ∀ q, y q = h q :=
            assume q,
            have e0 : (e ∘ y) q = (e ∘ h) q :=
                by rw eh_ey,
            (inj_inclusion P E) e0,
        exact funext elements

    end ⟩

end Pullback


import Mathlib
import Qpf.Util.Vec

universe u v

/-- A curried function of `n` arguments in `α`, resulting in `β`, i.e., `α → ... → α → β` -/
abbrev CurriedFun (α : Type u) (β : Type v) : Nat → Type (max u v)
  | 0   => PUnit.{u+1} → β
  | 1   => α → β
  | n+1 => α → CurriedFun α β n

/-- A curried type function of `n` arguments, i.e., `Type u → Type u → ... → Type v` -/
abbrev CurriedTypeFun : Nat → Type ((max u v) + 1)
  := CurriedFun (Type u) (Type v)

/-- An uncurried type function, all `n` arguments are collected into a single `TypeVec n`
    Note that all arguments live in the same universe, but the result may be in a different universe
-/
abbrev TypeFun (n : Nat) : Type ((max u v) + 1) :=
  TypeVec.{u} n → Type v

namespace TypeFun
  def reverseArgs : TypeFun n → TypeFun n :=
    fun v α => v <| Vec.reverse α

  @[simp]
  theorem reverseArgs_involution (F : TypeFun n) :
    F.reverseArgs.reverseArgs = F :=
  by
    simp only [reverseArgs, Vec.reverse_involution]

  def curriedAux : {n : Nat} → TypeFun n → CurriedTypeFun n
    | 0,    F => fun _ => F !![]
    | 1,    F => fun a => F !![a]
    | _+2,  F => fun a => curriedAux fun αs => F (αs ::: a)

  def curried (F : TypeFun n) : CurriedTypeFun n
    := curriedAux (F.reverseArgs)

  def ofCurriedAux : {n : Nat} → CurriedTypeFun n → TypeFun n
    | 0,    F, _ => F PUnit.unit
    | 1,    F, α => F (α 0)
    | n+2,  F, α => ofCurriedAux (F α.last) α.drop

  def ofCurried (F : CurriedTypeFun n) : TypeFun n
    := (ofCurriedAux F).reverseArgs

  @[simp]
  theorem curriedAux_ofCurriedAux_involution {F : CurriedTypeFun n} :
    curriedAux (ofCurriedAux F) = F :=
  by
    cases n
    case zero => simp [curriedAux, ofCurriedAux]
    case succ n => {
      induction n
      <;> simp [curriedAux, ofCurriedAux, Vec.append1]

      case succ _ ih => {
        funext a;
        simp[reverseArgs_involution]
        apply @ih (F a);
      }
    }

  @[simp]
  theorem curried_ofCurried_involution {F : CurriedTypeFun n} :
    curried (ofCurried F) = F :=
  by
    simp only [curried, ofCurried, reverseArgs_involution]
    apply curriedAux_ofCurriedAux_involution

  @[simp]
  theorem ofCurriedAux_curriedAux_involution {F : TypeFun n} :
    ofCurriedAux (curriedAux F) = F :=
  by
    cases n
    case zero =>
      funext x;
      simp [curriedAux, ofCurriedAux, Matrix.vecEmpty]
      congr
      funext i
      contradiction
    case succ n => {
      induction n;
      case zero => {
        funext x;
        simp [curriedAux, ofCurriedAux];
        apply congrArg;
        funext i;
        cases i;
        . simp [Vec.append1, OfNat.ofNat]
        . contradiction
      }

      case succ _ ih => {
        funext x;
        simp [ofCurriedAux, curriedAux];
        let F' := fun α => F (α ::: x.last);
        have : F x = F' x.drop;
        . simp
        rw [this]
        rw [@ih F']
      }
    }

  @[simp]
  theorem ofCurried_curried_involution {F : TypeFun n} :
    ofCurried (curried F) = F :=
  by
    simp only [ofCurried, curried, ofCurriedAux_curriedAux_involution]
    apply reverseArgs_involution
end TypeFun