/-
Copyright (c) 2018 Mario Carneiro. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Mario Carneiro
-/
import data.set.lattice
import logic.small.basic
import order.well_founded

/-!
# A model of ZFC

In this file, we model Zermelo-Fraenkel set theory (+ Choice) using Lean's underlying type theory.
We do this in four main steps:
* Define pre-sets inductively.
* Define extensional equivalence on pre-sets and give it a `setoid` instance.
* Define ZFC sets by quotienting pre-sets by extensional equivalence.
* Define classes as sets of ZFC sets.
Then the rest is usual set theory.

## The model

* `pSet`: Pre-set. A pre-set is inductively defined by its indexing type and its members, which are
  themselves pre-sets.
* `Set`: ZFC set. Defined as `pSet` quotiented by `pSet.equiv`, the extensional equivalence.
* `Class`: Class. Defined as `set Set`.
* `Set.choice`: Axiom of choice. Proved from Lean's axiom of choice.

## Other definitions

* `arity α n`: `n`-ary function `α → α → ... → α`. Defined inductively.
* `arity.const a n`: `n`-ary constant function equal to `a`.
* `pSet.type`: Underlying type of a pre-set.
* `pSet.func`: Underlying family of pre-sets of a pre-set.
* `pSet.equiv`: Extensional equivalence of pre-sets. Defined inductively.
* `pSet.omega`, `Set.omega`: The von Neumann ordinal `ω` as a `pSet`, as a `Set`.
* `pSet.arity.equiv`: Extensional equivalence of `n`-ary `pSet`-valued functions. Extension of
  `pSet.equiv`.
* `pSet.resp`: Collection of `n`-ary `pSet`-valued functions that respect extensional equivalence.
* `pSet.eval`: Turns a `pSet`-valued function that respect extensional equivalence into a
  `Set`-valued function.
* `classical.all_definable`: All functions are classically definable.
* `Set.is_func` : Predicate that a ZFC set is a subset of `x × y` that can be considered as a ZFC
  function `x → y`. That is, each member of `x` is related by the ZFC set to exactly one member of
  `y`.
* `Set.funs`: ZFC set of ZFC functions `x → y`.
* `Set.hereditarily p x`: Predicate that every set in the transitive closure of `x` has property
  `p`.
* `Class.iota`: Definite description operator.

## Notes

To avoid confusion between the Lean `set` and the ZFC `Set`, docstrings in this file refer to them
respectively as "`set`" and "ZFC set".

## TODO

Prove `Set.map_definable_aux` computably.
-/

universes u v

/-- The type of `n`-ary functions `α → α → ... → α`. -/
def arity (α : Type u) : ℕ → Type u
| 0     := α
| (n+1) := α → arity n

@[simp] theorem arity_zero (α : Type u) : arity α 0 = α := rfl
@[simp] theorem arity_succ (α : Type u) (n : ℕ) : arity α n.succ = (α → arity α n) := rfl

namespace arity

/-- Constant `n`-ary function with value `a`. -/
def const {α : Type u} (a : α) : ∀ n, arity α n
| 0     := a
| (n+1) := λ _, const n

@[simp] theorem const_zero {α : Type u} (a : α) : const a 0 = a := rfl
@[simp] theorem const_succ {α : Type u} (a : α) (n : ℕ) : const a n.succ = λ _, const a n := rfl
theorem const_succ_apply {α : Type u} (a : α) (n : ℕ) (x : α) : const a n.succ x = const a n := rfl

instance arity.inhabited {α n} [inhabited α] : inhabited (arity α n) := ⟨const default _⟩

end arity

/-- The type of pre-sets in universe `u`. A pre-set
  is a family of pre-sets indexed by a type in `Type u`.
  The ZFC universe is defined as a quotient of this
  to ensure extensionality. -/
inductive pSet : Type (u+1)
| mk (α : Type u) (A : α → pSet) : pSet

namespace pSet

/-- The underlying type of a pre-set -/
def type : pSet → Type u
| ⟨α, A⟩ := α

/-- The underlying pre-set family of a pre-set -/
def func : Π (x : pSet), x.type → pSet
| ⟨α, A⟩ := A

@[simp] theorem mk_type (α A) : type ⟨α, A⟩ = α := rfl
@[simp] theorem mk_func (α A) : func ⟨α, A⟩ = A := rfl

@[simp] theorem eta : Π (x : pSet), mk x.type x.func = x
| ⟨α, A⟩ := rfl

/-- Two pre-sets are extensionally equivalent if every element of the first family is extensionally
equivalent to some element of the second family and vice-versa. -/
def equiv (x y : pSet) : Prop :=
pSet.rec (λ α z m ⟨β, B⟩, (∀ a, ∃ b, m a (B b)) ∧ (∀ b, ∃ a, m a (B b))) x y

theorem equiv_iff : Π {x y : pSet}, equiv x y ↔
  (∀ i, ∃ j, equiv (x.func i) (y.func j)) ∧ (∀ j, ∃ i, equiv (x.func i) (y.func j))
| ⟨α, A⟩ ⟨β, B⟩ := iff.rfl

theorem equiv.exists_left {x y : pSet} (h : equiv x y) : ∀ i, ∃ j, equiv (x.func i) (y.func j) :=
(equiv_iff.1 h).1

theorem equiv.exists_right {x y : pSet} (h : equiv x y) : ∀ j, ∃ i, equiv (x.func i) (y.func j) :=
(equiv_iff.1 h).2

@[refl] protected theorem equiv.refl (x) : equiv x x :=
pSet.rec_on x $ λ α A IH, ⟨λ a, ⟨a, IH a⟩, λ a, ⟨a, IH a⟩⟩

protected theorem equiv.rfl : ∀ {x}, equiv x x := equiv.refl

protected theorem equiv.euc {x} : Π {y z}, equiv x y → equiv z y → equiv x z :=
pSet.rec_on x $ λ α A IH y, pSet.cases_on y $ λ β B ⟨γ, Γ⟩ ⟨αβ, βα⟩ ⟨γβ, βγ⟩,
⟨λ a, let ⟨b, ab⟩ := αβ a, ⟨c, bc⟩ := βγ b in ⟨c, IH a ab bc⟩,
  λ c, let ⟨b, cb⟩ := γβ c, ⟨a, ba⟩ := βα b in ⟨a, IH a ba cb⟩⟩

@[symm] protected theorem equiv.symm {x y} : equiv x y → equiv y x :=
(equiv.refl y).euc

protected theorem equiv.comm {x y} : equiv x y ↔ equiv y x :=
⟨equiv.symm, equiv.symm⟩

@[trans] protected theorem equiv.trans {x y z} (h1 : equiv x y) (h2 : equiv y z) : equiv x z :=
h1.euc h2.symm

protected theorem equiv_of_is_empty (x y : pSet) [is_empty x.type] [is_empty y.type] : equiv x y :=
equiv_iff.2 $ by simp

instance setoid : setoid pSet :=
⟨pSet.equiv, equiv.refl, λ x y, equiv.symm, λ x y z, equiv.trans⟩

/-- A pre-set is a subset of another pre-set if every element of the first family is extensionally
equivalent to some element of the second family.-/
protected def subset (x y : pSet) : Prop := ∀ a, ∃ b, equiv (x.func a) (y.func b)

instance : has_subset pSet := ⟨pSet.subset⟩

instance : is_refl pSet (⊆) := ⟨λ x a, ⟨a, equiv.refl _⟩⟩

instance : is_trans pSet (⊆) :=
⟨λ x y z hxy hyz a, begin
  cases hxy a with b hb,
  cases hyz b with c hc,
  exact ⟨c, hb.trans hc⟩
end⟩

theorem equiv.ext : Π (x y : pSet), equiv x y ↔ (x ⊆ y ∧ y ⊆ x)
| ⟨α, A⟩ ⟨β, B⟩ :=
  ⟨λ ⟨αβ, βα⟩, ⟨αβ, λ b, let ⟨a, h⟩ := βα b in ⟨a, equiv.symm h⟩⟩,
    λ ⟨αβ, βα⟩, ⟨αβ, λ b, let ⟨a, h⟩ := βα b in ⟨a, equiv.symm h⟩⟩⟩

theorem subset.congr_left : Π {x y z : pSet}, equiv x y → (x ⊆ z ↔ y ⊆ z)
| ⟨α, A⟩ ⟨β, B⟩ ⟨γ, Γ⟩ ⟨αβ, βα⟩ :=
  ⟨λ αγ b, let ⟨a, ba⟩ := βα b, ⟨c, ac⟩ := αγ a in ⟨c, (equiv.symm ba).trans ac⟩,
    λ βγ a, let ⟨b, ab⟩ := αβ a, ⟨c, bc⟩ := βγ b in ⟨c, equiv.trans ab bc⟩⟩

theorem subset.congr_right : Π {x y z : pSet}, equiv x y → (z ⊆ x ↔ z ⊆ y)
| ⟨α, A⟩ ⟨β, B⟩ ⟨γ, Γ⟩ ⟨αβ, βα⟩ :=
  ⟨λ γα c, let ⟨a, ca⟩ := γα c, ⟨b, ab⟩ := αβ a in ⟨b, ca.trans ab⟩,
    λ γβ c, let ⟨b, cb⟩ := γβ c, ⟨a, ab⟩ := βα b in ⟨a, cb.trans (equiv.symm ab)⟩⟩

/-- `x ∈ y` as pre-sets if `x` is extensionally equivalent to a member of the family `y`. -/
protected def mem (x y : pSet.{u}) : Prop := ∃ b, equiv x (y.func b)

instance : has_mem pSet pSet := ⟨pSet.mem⟩

theorem mem.mk {α : Type u} (A : α → pSet) (a : α) : A a ∈ mk α A :=
⟨a, equiv.refl (A a)⟩

theorem func_mem (x : pSet) (i : x.type) : x.func i ∈ x :=
by { cases x, apply mem.mk }

theorem mem.ext : Π {x y : pSet.{u}}, (∀ w : pSet.{u}, w ∈ x ↔ w ∈ y) → equiv x y
| ⟨α, A⟩ ⟨β, B⟩ h := ⟨λ a, (h (A a)).1 (mem.mk A a),
    λ b, let ⟨a, ha⟩ := (h (B b)).2 (mem.mk B b) in ⟨a, ha.symm⟩⟩

theorem mem.congr_right : Π {x y : pSet.{u}}, equiv x y → (∀ {w : pSet.{u}}, w ∈ x ↔ w ∈ y)
| ⟨α, A⟩ ⟨β, B⟩ ⟨αβ, βα⟩ w :=
  ⟨λ ⟨a, ha⟩, let ⟨b, hb⟩ := αβ a in ⟨b, ha.trans hb⟩,
    λ ⟨b, hb⟩, let ⟨a, ha⟩ := βα b in ⟨a, hb.euc ha⟩⟩

theorem equiv_iff_mem {x y : pSet.{u}} : equiv x y ↔ (∀ {w : pSet.{u}}, w ∈ x ↔ w ∈ y) :=
⟨mem.congr_right, match x, y with
| ⟨α, A⟩, ⟨β, B⟩, h := ⟨λ a, h.1 (mem.mk A a), λ b,
  let ⟨a, h⟩ := h.2 (mem.mk B b) in ⟨a, h.symm⟩⟩
end⟩

theorem mem.congr_left : Π {x y : pSet.{u}}, equiv x y → (∀ {w : pSet.{u}}, x ∈ w ↔ y ∈ w)
| x y h ⟨α, A⟩ := ⟨λ ⟨a, ha⟩, ⟨a, h.symm.trans ha⟩, λ ⟨a, ha⟩, ⟨a, h.trans ha⟩⟩

private theorem mem_wf_aux : Π {x y : pSet.{u}}, equiv x y → acc (∈) y
| ⟨α, A⟩ ⟨β, B⟩ H := ⟨_, begin
  rintros ⟨γ, C⟩ ⟨b, hc⟩,
  cases H.exists_right b with a ha,
  have H := ha.trans hc.symm,
  rw mk_func at H,
  exact mem_wf_aux H
end⟩

theorem mem_wf : @well_founded pSet (∈) := ⟨λ x, mem_wf_aux $ equiv.refl x⟩

instance : has_well_founded pSet := ⟨_, mem_wf⟩
instance : is_asymm pSet (∈) := mem_wf.is_asymm

theorem mem_asymm {x y : pSet} : x ∈ y → y ∉ x := asymm
theorem mem_irrefl (x : pSet) : x ∉ x := irrefl x

/-- Convert a pre-set to a `set` of pre-sets. -/
def to_set (u : pSet.{u}) : set pSet.{u} := {x | x ∈ u}

@[simp] theorem mem_to_set (a u : pSet.{u}) : a ∈ u.to_set ↔ a ∈ u := iff.rfl

/-- A nonempty set is one that contains some element. -/
protected def nonempty (u : pSet) : Prop := u.to_set.nonempty

theorem nonempty_def (u : pSet) : u.nonempty ↔ ∃ x, x ∈ u := iff.rfl

theorem nonempty_of_mem {x u : pSet} (h : x ∈ u) : u.nonempty := ⟨x, h⟩

@[simp] theorem nonempty_to_set_iff {u : pSet} : u.to_set.nonempty ↔ u.nonempty := iff.rfl

theorem nonempty_type_iff_nonempty {x : pSet} : nonempty x.type ↔ pSet.nonempty x :=
⟨λ ⟨i⟩, ⟨_, func_mem _ i⟩, λ ⟨i, j, h⟩, ⟨j⟩⟩

theorem nonempty_of_nonempty_type (x : pSet) [h : nonempty x.type] : pSet.nonempty x :=
nonempty_type_iff_nonempty.1 h

/-- Two pre-sets are equivalent iff they have the same members. -/
theorem equiv.eq {x y : pSet} : equiv x y ↔ to_set x = to_set y :=
equiv_iff_mem.trans set.ext_iff.symm

instance : has_coe pSet (set pSet) := ⟨to_set⟩

/-- The empty pre-set -/
protected def empty : pSet := ⟨_, pempty.elim⟩

instance : has_emptyc pSet := ⟨pSet.empty⟩

instance : inhabited pSet := ⟨∅⟩

instance : is_empty (type (∅)) := pempty.is_empty

@[simp] theorem not_mem_empty (x : pSet.{u}) : x ∉ (∅ : pSet.{u}) := is_empty.exists_iff.1

@[simp] theorem to_set_empty : to_set ∅ = ∅ := by simp [to_set]

@[simp] theorem empty_subset (x : pSet.{u}) : (∅ : pSet) ⊆ x := λ x, x.elim

@[simp] theorem not_nonempty_empty : ¬ pSet.nonempty ∅ := by simp [pSet.nonempty]

protected theorem equiv_empty (x : pSet) [is_empty x.type] : equiv x ∅ :=
pSet.equiv_of_is_empty x _

/-- Insert an element into a pre-set -/
protected def insert (x y : pSet) : pSet := ⟨option y.type, λ o, option.rec x y.func o⟩

instance : has_insert pSet pSet := ⟨pSet.insert⟩

instance : has_singleton pSet pSet := ⟨λ s, insert s ∅⟩

instance : is_lawful_singleton pSet pSet := ⟨λ _, rfl⟩

instance (x y : pSet) : inhabited (insert x y).type := option.inhabited _

/-- The n-th von Neumann ordinal -/
def of_nat : ℕ → pSet
| 0     := ∅
| (n+1) := insert (of_nat n) (of_nat n)

/-- The von Neumann ordinal ω -/
def omega : pSet := ⟨ulift ℕ, λ n, of_nat n.down⟩

/-- The pre-set separation operation `{x ∈ a | p x}` -/
protected def sep (p : pSet → Prop) (x : pSet) : pSet := ⟨{a // p (x.func a)}, λ y, x.func y.1⟩

instance : has_sep pSet pSet := ⟨pSet.sep⟩

/-- The pre-set powerset operator -/
def powerset (x : pSet) : pSet := ⟨set x.type, λ p, ⟨{a // p a}, λ y, x.func y.1⟩⟩

@[simp] theorem mem_powerset : Π {x y : pSet}, y ∈ powerset x ↔ y ⊆ x
| ⟨α, A⟩ ⟨β, B⟩ := ⟨λ ⟨p, e⟩, (subset.congr_left e).2 $ λ ⟨a, pa⟩, ⟨a, equiv.refl (A a)⟩,
  λ βα, ⟨{a | ∃ b, equiv (B b) (A a)}, λ b, let ⟨a, ba⟩ := βα b in ⟨⟨a, b, ba⟩, ba⟩,
    λ ⟨a, b, ba⟩, ⟨b, ba⟩⟩⟩

/-- The pre-set union operator -/
def sUnion (a : pSet) : pSet := ⟨Σ x, (a.func x).type, λ ⟨x, y⟩, (a.func x).func y⟩

prefix (name := pSet.sUnion) `⋃₀ `:110 := pSet.sUnion

@[simp] theorem mem_sUnion : Π {x y : pSet.{u}}, y ∈ ⋃₀ x ↔ ∃ z ∈ x, y ∈ z
| ⟨α, A⟩ y :=
  ⟨λ ⟨⟨a, c⟩, (e : equiv y ((A a).func c))⟩,
    have func (A a) c ∈ mk (A a).type (A a).func, from mem.mk (A a).func c,
    ⟨_, mem.mk _ _, (mem.congr_left e).2 (by rwa eta at this)⟩,
  λ ⟨⟨β, B⟩, ⟨a, (e : equiv (mk β B) (A a))⟩, ⟨b, yb⟩⟩,
    by { rw ←(eta (A a)) at e, exact
    let ⟨βt, tβ⟩ := e, ⟨c, bc⟩ := βt b in ⟨⟨a, c⟩, yb.trans bc⟩ }⟩

@[simp] theorem to_set_sUnion (x : pSet.{u}) : (⋃₀ x).to_set = ⋃₀ (to_set '' x.to_set) :=
by { ext, simp }

/-- The image of a function from pre-sets to pre-sets. -/
def image (f : pSet.{u} → pSet.{u}) (x : pSet.{u}) : pSet := ⟨x.type, f ∘ x.func⟩

theorem mem_image {f : pSet.{u} → pSet.{u}} (H : ∀ {x y}, equiv x y → equiv (f x) (f y)) :
  Π {x y : pSet.{u}}, y ∈ image f x ↔ ∃ z ∈ x, equiv y (f z)
| ⟨α, A⟩ y := ⟨λ ⟨a, ya⟩, ⟨A a, mem.mk A a, ya⟩, λ ⟨z, ⟨a, za⟩, yz⟩, ⟨a, yz.trans (H za)⟩⟩

/-- Universe lift operation -/
protected def lift : pSet.{u} → pSet.{max u v}
| ⟨α, A⟩ := ⟨ulift α, λ ⟨x⟩, lift (A x)⟩

/-- Embedding of one universe in another -/
@[nolint check_univs] -- intended to be used with explicit universe parameters
def embed : pSet.{max (u+1) v} := ⟨ulift.{v u+1} pSet, λ ⟨x⟩, pSet.lift.{u (max (u+1) v)} x⟩

theorem lift_mem_embed : Π (x : pSet.{u}), pSet.lift.{u (max (u+1) v)} x ∈ embed.{u v} :=
λ x, ⟨⟨x⟩, equiv.rfl⟩

/-- Function equivalence is defined so that `f ~ g` iff `∀ x y, x ~ y → f x ~ g y`. This extends to
equivalence of `n`-ary functions. -/
def arity.equiv : Π {n}, arity pSet.{u} n → arity pSet.{u} n → Prop
| 0     a b := equiv a b
| (n+1) a b := ∀ x y, equiv x y → arity.equiv (a x) (b y)

lemma arity.equiv_const {a : pSet.{u}} : ∀ n, arity.equiv (arity.const a n) (arity.const a n)
| 0     := equiv.rfl
| (n+1) := λ x y h, arity.equiv_const _

/-- `resp n` is the collection of n-ary functions on `pSet` that respect
  equivalence, i.e. when the inputs are equivalent the output is as well. -/
def resp (n) := {x : arity pSet.{u} n // arity.equiv x x}

instance resp.inhabited {n} : inhabited (resp n) :=
⟨⟨arity.const default _, arity.equiv_const _⟩⟩

/-- The `n`-ary image of a `(n + 1)`-ary function respecting equivalence as a function respecting
equivalence. -/
def resp.f {n} (f : resp (n+1)) (x : pSet) : resp n :=
⟨f.1 x, f.2 _ _ $ equiv.refl x⟩

/-- Function equivalence for functions respecting equivalence. See `pSet.arity.equiv`. -/
def resp.equiv {n} (a b : resp n) : Prop := arity.equiv a.1 b.1

protected theorem resp.equiv.refl {n} (a : resp n) : resp.equiv a a := a.2

protected theorem resp.equiv.euc : Π {n} {a b c : resp n},
  resp.equiv a b → resp.equiv c b → resp.equiv a c
| 0     a b c hab hcb := equiv.euc hab hcb
| (n+1) a b c hab hcb := λ x y h,
  @resp.equiv.euc n (a.f x) (b.f y) (c.f y) (hab _ _ h) (hcb _ _ $ equiv.refl y)

protected theorem resp.equiv.symm {n} {a b : resp n} : resp.equiv a b → resp.equiv b a :=
(resp.equiv.refl b).euc

protected theorem resp.equiv.trans {n} {x y z : resp n}
  (h1 : resp.equiv x y) (h2 : resp.equiv y z) : resp.equiv x z :=
h1.euc h2.symm

instance resp.setoid {n} : setoid (resp n) :=
⟨resp.equiv, resp.equiv.refl, λ x y, resp.equiv.symm, λ x y z, resp.equiv.trans⟩

end pSet

/-- The ZFC universe of sets consists of the type of pre-sets,
  quotiented by extensional equivalence. -/
def Set : Type (u+1) := quotient pSet.setoid.{u}

namespace pSet

namespace resp

/-- Helper function for `pSet.eval`. -/
def eval_aux : Π {n}, {f : resp n → arity Set.{u} n // ∀ (a b : resp n), resp.equiv a b → f a = f b}
| 0     := ⟨λ a, ⟦a.1⟧, λ a b h, quotient.sound h⟩
| (n+1) := let F : resp (n + 1) → arity Set (n + 1) := λ a, @quotient.lift _ _ pSet.setoid
    (λ x, eval_aux.1 (a.f x)) (λ b c h, eval_aux.2 _ _ (a.2 _ _ h)) in
  ⟨F, λ b c h, funext $ @quotient.ind _ _ (λ q, F b q = F c q) $ λ z,
  eval_aux.2 (resp.f b z) (resp.f c z) (h _ _ (pSet.equiv.refl z))⟩

/-- An equivalence-respecting function yields an n-ary ZFC set function. -/
def eval (n) : resp n → arity Set.{u} n := eval_aux.1

theorem eval_val {n f x} : (@eval (n+1) f : Set → arity Set n) ⟦x⟧ = eval n (resp.f f x) := rfl

end resp

/-- A set function is "definable" if it is the image of some n-ary pre-set
  function. This isn't exactly definability, but is useful as a sufficient
  condition for functions that have a computable image. -/
class inductive definable (n) : arity Set.{u} n → Type (u+1)
| mk (f) : definable (resp.eval n f)

attribute [instance] definable.mk

/-- The evaluation of a function respecting equivalence is definable, by that same function. -/
def definable.eq_mk {n} (f) : Π {s : arity Set.{u} n} (H : resp.eval _ f = s), definable n s
| ._ rfl := ⟨f⟩

/-- Turns a definable function into a function that respects equivalence. -/
def definable.resp {n} : Π (s : arity Set.{u} n) [definable n s], resp n
| ._ ⟨f⟩ := f

theorem definable.eq {n} :
  Π (s : arity Set.{u} n) [H : definable n s], (@definable.resp n s H).eval _ = s
| ._ ⟨f⟩ := rfl

end pSet

namespace classical
open pSet

/-- All functions are classically definable. -/
noncomputable def all_definable : Π {n} (F : arity Set.{u} n), definable n F
| 0     F := let p := @quotient.exists_rep pSet _ F in
              definable.eq_mk ⟨some p, equiv.rfl⟩ (some_spec p)
| (n+1) (F : arity Set.{u} (n + 1)) := begin
    have I := λ x, (all_definable (F x)),
    refine definable.eq_mk ⟨λ x : pSet, (@definable.resp _ _ (I ⟦x⟧)).1, _⟩ _,
    { dsimp [arity.equiv],
      introsI x y h,
      rw @quotient.sound pSet _ _ _ h,
      exact (definable.resp (F ⟦y⟧)).2 },
    refine funext (λ q, quotient.induction_on q $ λ x, _),
    simp_rw [resp.eval_val, resp.f, subtype.val_eq_coe, subtype.coe_eta],
    exact @definable.eq _ (F ⟦x⟧) (I ⟦x⟧),
  end

end classical

namespace Set
open pSet

/-- Turns a pre-set into a ZFC set. -/
def mk : pSet → Set := quotient.mk

@[simp] theorem mk_eq (x : pSet) : @eq Set ⟦x⟧ (mk x) := rfl
@[simp] theorem mk_out : ∀ x : Set, mk x.out = x := quotient.out_eq
theorem eq {x y : pSet} : mk x = mk y ↔ equiv x y := quotient.eq
theorem sound {x y : pSet} (h : pSet.equiv x y) : mk x = mk y := quotient.sound h
theorem exact {x y : pSet} : mk x = mk y → pSet.equiv x y := quotient.exact

@[simp] lemma eval_mk {n f x} :
  (@resp.eval (n+1) f : Set → arity Set n) (mk x) = resp.eval n (resp.f f x) :=
rfl

/-- The membership relation for ZFC sets is inherited from the membership relation for pre-sets. -/
protected def mem : Set → Set → Prop :=
quotient.lift₂ pSet.mem
  (λ x y x' y' hx hy, propext ((mem.congr_left hx).trans (mem.congr_right hy)))

instance : has_mem Set Set := ⟨Set.mem⟩

@[simp] theorem mk_mem_iff {x y : pSet} : mk x ∈ mk y ↔ x ∈ y := iff.rfl

/-- Convert a ZFC set into a `set` of ZFC sets -/
def to_set (u : Set.{u}) : set Set.{u} := {x | x ∈ u}

@[simp] theorem mem_to_set (a u : Set.{u}) : a ∈ u.to_set ↔ a ∈ u := iff.rfl

instance small_to_set (x : Set.{u}) : small.{u} x.to_set :=
quotient.induction_on x $ λ a, begin
  let f : a.type → (mk a).to_set := λ i, ⟨mk $ a.func i, func_mem a i⟩,
  suffices : function.surjective f,
  { exact small_of_surjective this },
  rintro ⟨y, hb⟩,
  induction y using quotient.induction_on,
  cases hb with i h,
  exact ⟨i, subtype.coe_injective (quotient.sound h.symm)⟩
end

/-- A nonempty set is one that contains some element. -/
protected def nonempty (u : Set) : Prop := u.to_set.nonempty

theorem nonempty_def (u : Set) : u.nonempty ↔ ∃ x, x ∈ u := iff.rfl

theorem nonempty_of_mem {x u : Set} (h : x ∈ u) : u.nonempty := ⟨x, h⟩

@[simp] theorem nonempty_to_set_iff {u : Set} : u.to_set.nonempty ↔ u.nonempty := iff.rfl

/-- `x ⊆ y` as ZFC sets means that all members of `x` are members of `y`. -/
protected def subset (x y : Set.{u}) :=
∀ ⦃z⦄, z ∈ x → z ∈ y

instance has_subset : has_subset Set :=
⟨Set.subset⟩

lemma subset_def {x y : Set.{u}} : x ⊆ y ↔ ∀ ⦃z⦄, z ∈ x → z ∈ y := iff.rfl

instance : is_refl Set (⊆) := ⟨λ x a, id⟩
instance : is_trans Set (⊆) := ⟨λ x y z hxy hyz a ha, hyz (hxy ha)⟩

@[simp] theorem subset_iff : Π {x y : pSet}, mk x ⊆ mk y ↔ x ⊆ y
| ⟨α, A⟩ ⟨β, B⟩ := ⟨λ h a, @h ⟦A a⟧ (mem.mk A a),
  λ h z, quotient.induction_on z (λ z ⟨a, za⟩, let ⟨b, ab⟩ := h a in ⟨b, za.trans ab⟩)⟩

@[simp] theorem to_set_subset_iff {x y : Set} : x.to_set ⊆ y.to_set ↔ x ⊆ y :=
by simp [subset_def, set.subset_def]

@[ext] theorem ext {x y : Set.{u}} : (∀ z : Set.{u}, z ∈ x ↔ z ∈ y) → x = y :=
quotient.induction_on₂ x y (λ u v h, quotient.sound (mem.ext (λ w, h ⟦w⟧)))

theorem ext_iff {x y : Set.{u}} : x = y ↔ (∀ z : Set.{u}, z ∈ x ↔ z ∈ y) :=
⟨λ h, by simp [h], ext⟩

theorem to_set_injective : function.injective to_set := λ x y h, ext $ set.ext_iff.1 h

@[simp] theorem to_set_inj {x y : Set} : x.to_set = y.to_set ↔ x = y :=
to_set_injective.eq_iff

instance : is_antisymm Set (⊆) := ⟨λ a b hab hba, ext $ λ c, ⟨@hab c, @hba c⟩⟩

/-- The empty ZFC set -/
protected def empty : Set := mk ∅
instance : has_emptyc Set := ⟨Set.empty⟩
instance : inhabited Set := ⟨∅⟩

@[simp] theorem not_mem_empty (x) : x ∉ (∅ : Set.{u}) :=
quotient.induction_on x pSet.not_mem_empty

@[simp] theorem to_set_empty : to_set ∅ = ∅ := by simp [to_set]

@[simp] theorem empty_subset (x : Set.{u}) : (∅ : Set) ⊆ x :=
quotient.induction_on x $ λ y, subset_iff.2 $ pSet.empty_subset y

@[simp] theorem not_nonempty_empty : ¬ Set.nonempty ∅ := by simp [Set.nonempty]

@[simp] theorem nonempty_mk_iff {x : pSet} : (mk x).nonempty ↔ x.nonempty :=
begin
  refine ⟨_, λ ⟨a, h⟩, ⟨mk a, h⟩⟩,
  rintro ⟨a, h⟩,
  induction a using quotient.induction_on,
  exact ⟨a, h⟩
end

theorem eq_empty (x : Set.{u}) : x = ∅ ↔ ∀ y : Set.{u}, y ∉ x := by { rw ext_iff, simp }

theorem eq_empty_or_nonempty (u : Set) : u = ∅ ∨ u.nonempty :=
by { rw [eq_empty, ←not_exists], apply em' }

/-- `insert x y` is the set `{x} ∪ y` -/
protected def insert : Set → Set → Set :=
resp.eval 2 ⟨pSet.insert, λ u v uv ⟨α, A⟩ ⟨β, B⟩ ⟨αβ, βα⟩,
  ⟨λ o, match o with
   | some a := let ⟨b, hb⟩ := αβ a in ⟨some b, hb⟩
   | none := ⟨none, uv⟩
   end, λ o, match o with
   | some b := let ⟨a, ha⟩ := βα b in ⟨some a, ha⟩
   | none := ⟨none, uv⟩
   end⟩⟩

instance : has_insert Set Set := ⟨Set.insert⟩

instance : has_singleton Set Set := ⟨λ x, insert x ∅⟩

instance : is_lawful_singleton Set Set := ⟨λ x, rfl⟩

@[simp] theorem mem_insert_iff {x y z : Set.{u}} : x ∈ insert y z ↔ x = y ∨ x ∈ z :=
quotient.induction_on₃ x y z
 (λ x y ⟨α, A⟩, show x ∈ pSet.mk (option α) (λ o, option.rec y A o) ↔
    mk x = mk y ∨ x ∈ pSet.mk α A, from
  ⟨λ m, match m with
  | ⟨some a, ha⟩ := or.inr ⟨a, ha⟩
  | ⟨none, h⟩ := or.inl (quotient.sound h)
  end, λ m, match m with
  | or.inr ⟨a, ha⟩ := ⟨some a, ha⟩
  | or.inl h := ⟨none, quotient.exact h⟩
  end⟩)

theorem mem_insert (x y : Set) : x ∈ insert x y := mem_insert_iff.2 $ or.inl rfl
theorem mem_insert_of_mem {y z : Set} (x) (h : z ∈ y): z ∈ insert x y := mem_insert_iff.2 $ or.inr h

@[simp] theorem to_set_insert (x y : Set) : (insert x y).to_set = insert x y.to_set :=
by { ext, simp }

@[simp] theorem mem_singleton {x y : Set.{u}} : x ∈ @singleton Set.{u} Set.{u} _ y ↔ x = y :=
iff.trans mem_insert_iff ⟨λ o, or.rec (λ h, h) (λ n, absurd n (not_mem_empty _)) o, or.inl⟩

@[simp] theorem to_set_singleton (x : Set) : ({x} : Set).to_set = {x} :=
by { ext, simp }

theorem insert_nonempty (u v : Set) : (insert u v).nonempty := ⟨u, mem_insert u v⟩

theorem singleton_nonempty (u : Set) : Set.nonempty {u} := insert_nonempty u ∅

@[simp] theorem mem_pair {x y z : Set.{u}} : x ∈ ({y, z} : Set) ↔ x = y ∨ x = z :=
iff.trans mem_insert_iff $ or_congr iff.rfl mem_singleton

/-- `omega` is the first infinite von Neumann ordinal -/
def omega : Set := mk omega

@[simp] theorem omega_zero : ∅ ∈ omega :=
⟨⟨0⟩, equiv.rfl⟩

@[simp] theorem omega_succ {n} : n ∈ omega.{u} → insert n n ∈ omega.{u} :=
quotient.induction_on n (λ x ⟨⟨n⟩, h⟩, ⟨⟨n+1⟩, Set.exact $
  show insert (mk x) (mk x) = insert (mk $ of_nat n) (mk $ of_nat n), { rw Set.sound h, refl } ⟩)

/-- `{x ∈ a | p x}` is the set of elements in `a` satisfying `p` -/
protected def sep (p : Set → Prop) : Set → Set :=
resp.eval 1 ⟨pSet.sep (λ y, p (mk y)), λ ⟨α, A⟩ ⟨β, B⟩ ⟨αβ, βα⟩,
  ⟨λ ⟨a, pa⟩, let ⟨b, hb⟩ := αβ a in ⟨⟨b, by rwa [mk_func, ←Set.sound hb]⟩, hb⟩,
   λ ⟨b, pb⟩, let ⟨a, ha⟩ := βα b in ⟨⟨a, by rwa [mk_func, Set.sound ha]⟩, ha⟩⟩⟩

instance : has_sep Set Set := ⟨Set.sep⟩

@[simp] theorem mem_sep {p : Set.{u} → Prop} {x y : Set.{u}} : y ∈ {y ∈ x | p y} ↔ y ∈ x ∧ p y :=
quotient.induction_on₂ x y (λ ⟨α, A⟩ y,
  ⟨λ ⟨⟨a, pa⟩, h⟩, ⟨⟨a, h⟩, by rwa (@quotient.sound pSet _ _ _ h)⟩,
  λ ⟨⟨a, h⟩, pa⟩, ⟨⟨a, by { rw mk_func at h, rwa [mk_func, ←Set.sound h] }⟩, h⟩⟩)

@[simp] theorem to_set_sep (a : Set) (p : Set → Prop) :
  {x ∈ a | p x}.to_set = {x ∈ a.to_set | p x} :=
by { ext, simp }

/-- The powerset operation, the collection of subsets of a ZFC set -/
def powerset : Set → Set :=
resp.eval 1 ⟨powerset, λ ⟨α, A⟩ ⟨β, B⟩ ⟨αβ, βα⟩,
  ⟨λ p, ⟨{b | ∃ a, p a ∧ equiv (A a) (B b)},
    λ ⟨a, pa⟩, let ⟨b, ab⟩ := αβ a in ⟨⟨b, a, pa, ab⟩, ab⟩,
    λ ⟨b, a, pa, ab⟩, ⟨⟨a, pa⟩, ab⟩⟩,
   λ q, ⟨{a | ∃ b, q b ∧ equiv (A a) (B b)},
    λ ⟨a, b, qb, ab⟩, ⟨⟨b, qb⟩, ab⟩,
    λ ⟨b, qb⟩, let ⟨a, ab⟩ := βα b in ⟨⟨a, b, qb, ab⟩, ab⟩⟩⟩⟩

@[simp] theorem mem_powerset {x y : Set.{u}} : y ∈ powerset x ↔ y ⊆ x :=
quotient.induction_on₂ x y ( λ ⟨α, A⟩ ⟨β, B⟩,
  show (⟨β, B⟩ : pSet.{u}) ∈ (pSet.powerset.{u} ⟨α, A⟩) ↔ _,
    by simp [mem_powerset, subset_iff])

theorem sUnion_lem {α β : Type u} (A : α → pSet) (B : β → pSet) (αβ : ∀ a, ∃ b, equiv (A a) (B b)) :
  ∀ a, ∃ b, (equiv ((sUnion ⟨α, A⟩).func a) ((sUnion ⟨β, B⟩).func b))
| ⟨a, c⟩ := let ⟨b, hb⟩ := αβ a in
  begin
    induction ea : A a with γ Γ,
    induction eb : B b with δ Δ,
    rw [ea, eb] at hb,
    cases hb with γδ δγ,
    exact
    let c : type (A a) := c, ⟨d, hd⟩ := γδ (by rwa ea at c) in
    have pSet.equiv ((A a).func c) ((B b).func (eq.rec d (eq.symm eb))), from
    match A a, B b, ea, eb, c, d, hd with ._, ._, rfl, rfl, x, y, hd := hd end,
    ⟨⟨b, by { rw mk_func, exact eq.rec d (eq.symm eb) }⟩, this⟩
  end

/-- The union operator, the collection of elements of elements of a ZFC set -/
def sUnion : Set → Set :=
resp.eval 1 ⟨pSet.sUnion, λ ⟨α, A⟩ ⟨β, B⟩ ⟨αβ, βα⟩,
  ⟨sUnion_lem A B αβ, λ a, exists.elim (sUnion_lem B A (λ b,
    exists.elim (βα b) (λ c hc, ⟨c, pSet.equiv.symm hc⟩)) a) (λ b hb, ⟨b, pSet.equiv.symm hb⟩)⟩⟩

prefix (name := Set.sUnion) `⋃₀ `:110 := Set.sUnion

/-- The intersection operator, the collection of elements in all of the elements of a ZFC set. We
special-case `⋂₀ ∅ = ∅`. -/
noncomputable def sInter (x : Set) : Set :=
by { classical, exact dite x.nonempty (λ h, {y ∈ h.some | ∀ z ∈ x, y ∈ z}) (λ _, ∅) }

prefix (name := Set.sInter) `⋂₀ `:110 := Set.sInter

@[simp] theorem mem_sUnion {x y : Set.{u}} : y ∈ ⋃₀ x ↔ ∃ z ∈ x, y ∈ z :=
quotient.induction_on₂ x y (λ x y, iff.trans mem_sUnion
  ⟨λ ⟨z, h⟩, ⟨⟦z⟧, h⟩, λ ⟨z, h⟩, quotient.induction_on z (λ z h, ⟨z, h⟩) h⟩)

theorem mem_sInter {x y : Set} (h : x.nonempty) : y ∈ ⋂₀ x ↔ ∀ z ∈ x, y ∈ z :=
begin
  rw [sInter, dif_pos h],
  simp only [mem_to_set, mem_sep, and_iff_right_iff_imp],
  exact λ H, H _ h.some_mem
end

@[simp] theorem sUnion_empty : ⋃₀ (∅ : Set) = ∅ := by { ext, simp }
@[simp] theorem sInter_empty : ⋂₀ (∅ : Set) = ∅ := dif_neg $ by simp

theorem mem_of_mem_sInter {x y z : Set} (hy : y ∈ ⋂₀ x) (hz : z ∈ x) : y ∈ z :=
begin
  rcases eq_empty_or_nonempty x with rfl | hx,
  { exact (not_mem_empty z hz).elim },
  { exact (mem_sInter hx).1 hy z hz }
end

theorem mem_sUnion_of_mem {x y z : Set} (hy : y ∈ z) (hz : z ∈ x) : y ∈ ⋃₀ x :=
mem_sUnion.2 ⟨z, hz, hy⟩

theorem not_mem_sInter_of_not_mem {x y z : Set} (hy : ¬ y ∈ z) (hz : z ∈ x) : ¬ y ∈ ⋂₀ x :=
λ hx, hy $ mem_of_mem_sInter hx hz

@[simp] theorem sUnion_singleton {x : Set.{u}} : ⋃₀ ({x} : Set) = x :=
ext $ λ y, by simp_rw [mem_sUnion, exists_prop, mem_singleton, exists_eq_left]

@[simp] theorem sInter_singleton {x : Set.{u}} : ⋂₀ ({x} : Set) = x :=
ext $ λ y, by simp_rw [mem_sInter (singleton_nonempty x), mem_singleton, forall_eq]

@[simp] theorem to_set_sUnion (x : Set.{u}) : (⋃₀ x).to_set = ⋃₀ (to_set '' x.to_set) :=
by { ext, simp }

theorem to_set_sInter {x : Set.{u}} (h : x.nonempty) : (⋂₀ x).to_set = ⋂₀ (to_set '' x.to_set) :=
by { ext, simp [mem_sInter h] }

theorem singleton_injective : function.injective (@singleton Set Set _) :=
λ x y H, let this := congr_arg sUnion H in by rwa [sUnion_singleton, sUnion_singleton] at this

@[simp] theorem singleton_inj {x y : Set} : ({x} : Set) = {y} ↔ x = y := singleton_injective.eq_iff

/-- The binary union operation -/
protected def union (x y : Set.{u}) : Set.{u} := ⋃₀ {x, y}

/-- The binary intersection operation -/
protected def inter (x y : Set.{u}) : Set.{u} := {z ∈ x | z ∈ y}

/-- The set difference operation -/
protected def diff (x y : Set.{u}) : Set.{u} := {z ∈ x | z ∉ y}

instance : has_union Set := ⟨Set.union⟩
instance : has_inter Set := ⟨Set.inter⟩
instance : has_sdiff Set := ⟨Set.diff⟩

@[simp] theorem to_set_union (x y : Set.{u}) : (x ∪ y).to_set = x.to_set ∪ y.to_set :=
by { unfold has_union.union, rw Set.union, simp }

@[simp] theorem to_set_inter (x y : Set.{u}) : (x ∩ y).to_set = x.to_set ∩ y.to_set :=
by { unfold has_inter.inter, rw Set.inter, ext, simp }

@[simp] theorem to_set_sdiff (x y : Set.{u}) : (x \ y).to_set = x.to_set \ y.to_set :=
by { change {z ∈ x | z ∉ y}.to_set = _, ext, simp }

@[simp] theorem mem_union {x y z : Set.{u}} : z ∈ x ∪ y ↔ z ∈ x ∨ z ∈ y :=
by { rw ←mem_to_set, simp }

@[simp] theorem mem_inter {x y z : Set.{u}} : z ∈ x ∩ y ↔ z ∈ x ∧ z ∈ y :=
@@mem_sep (λ z : Set.{u}, z ∈ y)

@[simp] theorem mem_diff {x y z : Set.{u}} : z ∈ x \ y ↔ z ∈ x ∧ z ∉ y :=
@@mem_sep (λ z : Set.{u}, z ∉ y)

@[simp] theorem sUnion_pair {x y : Set.{u}} : ⋃₀ ({x, y} : Set.{u}) = x ∪ y :=
begin
  ext,
  simp_rw [mem_union, mem_sUnion, mem_pair],
  split,
  { rintro ⟨w, (rfl | rfl), hw⟩,
    { exact or.inl hw },
    { exact or.inr hw } },
  { rintro (hz | hz),
    { exact ⟨x, or.inl rfl, hz⟩ },
    { exact ⟨y, or.inr rfl, hz⟩ } }
end

theorem mem_wf : @well_founded Set (∈) :=
well_founded_lift₂_iff.mpr pSet.mem_wf

/-- Induction on the `∈` relation. -/
@[elab_as_eliminator]
theorem induction_on {p : Set → Prop} (x) (h : ∀ x, (∀ y ∈ x, p y) → p x) : p x :=
mem_wf.induction x h

instance : has_well_founded Set := ⟨_, mem_wf⟩

instance : is_asymm Set (∈) := mem_wf.is_asymm

theorem mem_asymm {x y : Set} : x ∈ y → y ∉ x := asymm
theorem mem_irrefl (x : Set) : x ∉ x := irrefl x

theorem regularity (x : Set.{u}) (h : x ≠ ∅) : ∃ y ∈ x, x ∩ y = ∅ :=
classical.by_contradiction $ λ ne, h $ (eq_empty x).2 $ λ y,
induction_on y $ λ z (IH : ∀ w : Set.{u}, w ∈ z → w ∉ x), show z ∉ x, from λ zx,
ne ⟨z, zx, (eq_empty _).2 (λ w wxz, let ⟨wx, wz⟩ := mem_inter.1 wxz in IH w wz wx)⟩

/-- The image of a (definable) ZFC set function -/
def image (f : Set → Set) [H : definable 1 f] : Set → Set :=
let r := @definable.resp 1 f _ in
resp.eval 1 ⟨image r.1, λ x y e, mem.ext $ λ z,
  iff.trans (mem_image r.2) $ iff.trans (by exact
   ⟨λ ⟨w, h1, h2⟩, ⟨w, (mem.congr_right e).1 h1, h2⟩,
    λ ⟨w, h1, h2⟩, ⟨w, (mem.congr_right e).2 h1, h2⟩⟩) $
  iff.symm (mem_image r.2)⟩

theorem image.mk :
  Π (f : Set.{u} → Set.{u}) [H : definable 1 f] (x) {y} (h : y ∈ x), f y ∈ @image f H x
| ._ ⟨F⟩ x y := quotient.induction_on₂ x y $ λ ⟨α, A⟩ y ⟨a, ya⟩, ⟨a, F.2 _ _ ya⟩

@[simp] theorem mem_image : Π {f : Set.{u} → Set.{u}} [H : definable 1 f] {x y : Set.{u}},
  y ∈ @image f H x ↔ ∃ z ∈ x, f z = y
| ._ ⟨F⟩ x y := quotient.induction_on₂ x y $ λ ⟨α, A⟩ y,
  ⟨λ ⟨a, ya⟩, ⟨⟦A a⟧, mem.mk A a, eq.symm $ quotient.sound ya⟩,
  λ ⟨z, hz, e⟩, e ▸ image.mk _ _ hz⟩

@[simp] theorem to_set_image (f : Set → Set) [H : definable 1 f] (x : Set) :
  (image f x).to_set = f '' x.to_set :=
by { ext, simp }

/-- The range of an indexed family of sets. The universes allow for a more general index type
  without manual use of `ulift`. -/
noncomputable def range {α : Type u} (f : α → Set.{max u v}) : Set.{max u v} :=
⟦⟨ulift α, quotient.out ∘ f ∘ ulift.down⟩⟧

@[simp] theorem mem_range {α : Type u} {f : α → Set.{max u v}} {x : Set.{max u v}} :
  x ∈ range f ↔ x ∈ set.range f :=
quotient.induction_on x (λ y, begin
  split,
  { rintro ⟨z, hz⟩,
    exact ⟨z.down, quotient.eq_mk_iff_out.2 hz.symm⟩ },
  { rintro ⟨z, hz⟩,
    use z,
    simpa [hz] using pSet.equiv.symm (quotient.mk_out y) }
end)

@[simp] theorem to_set_range {α : Type u} (f : α → Set.{max u v}) :
  (range f).to_set = set.range f :=
by { ext, simp }

/-- Kuratowski ordered pair -/
def pair (x y : Set.{u}) : Set.{u} := {{x}, {x, y}}

@[simp] theorem to_set_pair (x y : Set.{u}) : (pair x y).to_set = {{x}, {x, y}} := by simp [pair]

/-- A subset of pairs `{(a, b) ∈ x × y | p a b}` -/
def pair_sep (p : Set.{u} → Set.{u} → Prop) (x y : Set.{u}) : Set.{u} :=
{z ∈ powerset (powerset (x ∪ y)) | ∃ a ∈ x, ∃ b ∈ y, z = pair a b ∧ p a b}

@[simp] theorem mem_pair_sep {p} {x y z : Set.{u}} :
  z ∈ pair_sep p x y ↔ ∃ a ∈ x, ∃ b ∈ y, z = pair a b ∧ p a b :=
begin
  refine mem_sep.trans ⟨and.right, λ e, ⟨_, e⟩⟩,
  rcases e with ⟨a, ax, b, bY, rfl, pab⟩,
  simp only [mem_powerset, subset_def, mem_union, pair, mem_pair],
  rintros u (rfl|rfl) v; simp only [mem_singleton, mem_pair],
  { rintro rfl, exact or.inl ax },
  { rintro (rfl|rfl); [left, right]; assumption }
end

theorem pair_injective : function.injective2 pair :=
λ x x' y y' H, begin
  have ae := ext_iff.1 H,
  simp only [pair, mem_pair] at ae,
  obtain rfl : x = x',
  { cases (ae {x}).1 (by simp) with h h,
    { exact singleton_injective h },
    { have m : x' ∈ ({x} : Set),
      { simp [h] },
      rw mem_singleton.mp m } },
  have he : x = y → y = y',
  { rintro rfl,
    cases (ae {x, y'}).2 (by simp only [eq_self_iff_true, or_true]) with xy'x xy'xx,
    { rw [eq_comm, ←mem_singleton, ←xy'x, mem_pair],
      exact or.inr rfl },
    { simpa [eq_comm] using (ext_iff.1 xy'xx y').1 (by simp) } },
  obtain xyx | xyy' := (ae {x, y}).1 (by simp),
  { obtain rfl := mem_singleton.mp ((ext_iff.1 xyx y).1 $ by simp),
    simp [he rfl] },
  { obtain rfl | yy' := mem_pair.mp ((ext_iff.1 xyy' y).1 $ by simp),
    { simp [he rfl] },
    { simp [yy'] } }
end

@[simp] theorem pair_inj {x y x' y' : Set} : pair x y = pair x' y' ↔ x = x' ∧ y = y' :=
pair_injective.eq_iff

/-- The cartesian product, `{(a, b) | a ∈ x, b ∈ y}` -/
def prod : Set.{u} → Set.{u} → Set.{u} := pair_sep (λ a b, true)

@[simp] theorem mem_prod {x y z : Set.{u}} : z ∈ prod x y ↔ ∃ a ∈ x, ∃ b ∈ y, z = pair a b :=
by simp [prod]

@[simp] theorem pair_mem_prod {x y a b : Set.{u}} : pair a b ∈ prod x y ↔ a ∈ x ∧ b ∈ y :=
⟨λ h, let ⟨a', a'x, b', b'y, e⟩ := mem_prod.1 h in
  match a', b', pair_injective e, a'x, b'y with ._, ._, ⟨rfl, rfl⟩, ax, bY := ⟨ax, bY⟩ end,
λ ⟨ax, bY⟩, mem_prod.2 ⟨a, ax, b, bY, rfl⟩⟩

/-- `is_func x y f` is the assertion that `f` is a subset of `x × y` which relates to each element
of `x` a unique element of `y`, so that we can consider `f`as a ZFC function `x → y`. -/
def is_func (x y f : Set.{u}) : Prop :=
f ⊆ prod x y ∧ ∀ z : Set.{u}, z ∈ x → ∃! w, pair z w ∈ f

/-- `funs x y` is `y ^ x`, the set of all set functions `x → y` -/
def funs (x y : Set.{u}) : Set.{u} :=
{f ∈ powerset (prod x y) | is_func x y f}

@[simp] theorem mem_funs {x y f : Set.{u}} : f ∈ funs x y ↔ is_func x y f :=
by simp [funs, is_func]

-- TODO(Mario): Prove this computably
noncomputable instance map_definable_aux (f : Set → Set) [H : definable 1 f] :
  definable 1 (λ y, pair y (f y)) :=
@classical.all_definable 1 _

/-- Graph of a function: `map f x` is the ZFC function which maps `a ∈ x` to `f a` -/
noncomputable def map (f : Set → Set) [H : definable 1 f] : Set → Set :=
image (λ y, pair y (f y))

@[simp] theorem mem_map {f : Set → Set} [H : definable 1 f] {x y : Set} :
  y ∈ map f x ↔ ∃ z ∈ x, pair z (f z) = y :=
mem_image

theorem map_unique {f : Set.{u} → Set.{u}} [H : definable 1 f] {x z : Set.{u}} (zx : z ∈ x) :
  ∃! w, pair z w ∈ map f x :=
⟨f z, image.mk _ _ zx, λ y yx, let ⟨w, wx, we⟩ := mem_image.1 yx, ⟨wz, fy⟩ := pair_injective we in
  by rw[←fy, wz]⟩

@[simp] theorem map_is_func {f : Set → Set} [H : definable 1 f] {x y : Set} :
  is_func x y (map f x) ↔ ∀ z ∈ x, f z ∈ y :=
⟨λ ⟨ss, h⟩ z zx, let ⟨t, t1, t2⟩ := h z zx in
  (t2 (f z) (image.mk _ _ zx)).symm ▸ (pair_mem_prod.1 (ss t1)).right,
λ h, ⟨λ y yx, let ⟨z, zx, ze⟩ := mem_image.1 yx in ze ▸ pair_mem_prod.2 ⟨zx, h z zx⟩,
     λ z, map_unique⟩⟩

/-- Given a predicate `p` on ZFC sets. `hereditarily p x` means that `x` has property `p` and the
members of `x` are all `hereditarily p`. -/
def hereditarily (p : Set → Prop) : Set → Prop
| x := p x ∧ ∀ y ∈ x, hereditarily y
using_well_founded { dec_tac := `[assumption] }

section hereditarily

variables {p : Set.{u} → Prop} {x y : Set.{u}}

alias hereditarily_iff ↔ hereditarily.def _

lemma hereditarily.self (h : x.hereditarily p) : p x := h.def.1
lemma hereditarily.mem (h : x.hereditarily p) (hy : y ∈ x) : y.hereditarily p := h.def.2 _ hy

lemma hereditarily.empty : hereditarily p x → p ∅ :=
begin
  apply x.induction_on,
  intros y IH h,
  rcases Set.eq_empty_or_nonempty y with (rfl|⟨a, ha⟩),
  { exact h.self },
  { exact IH a ha (h.mem ha) }
end

end hereditarily

end Set

/-- The collection of all classes.

We define `Class` as `set Set`, as this allows us to get many instances automatically. However, in
practice, we treat it as (the definitionally equal) `Set → Prop`. This means, the preferred way to
state that `x : Set` belongs to `A : Class` is to write `A x`. -/
@[derive [has_subset, has_sep Set, has_emptyc, inhabited, has_insert Set, has_union, has_inter,
  has_compl, has_sdiff]]
def Class := set Set

namespace Class

@[ext] theorem ext {x y : Class.{u}} : (∀ z : Set.{u}, x z ↔ y z) → x = y := set.ext

theorem ext_iff {x y : Class.{u}} : x = y ↔ ∀ z, x z ↔ y z := set.ext_iff

/-- Coerce a ZFC set into a class -/
def of_Set (x : Set.{u}) : Class.{u} := {y | y ∈ x}
instance : has_coe Set Class := ⟨of_Set⟩

/-- The universal class -/
def univ : Class := set.univ

/-- Assert that `A` is a ZFC set satisfying `B` -/
def to_Set (B : Class.{u}) (A : Class.{u}) : Prop := ∃ x, ↑x = A ∧ B x

/-- `A ∈ B` if `A` is a ZFC set which satisfies `B` -/
protected def mem (A B : Class.{u}) : Prop := to_Set.{u} B A
instance : has_mem Class Class := ⟨Class.mem⟩

theorem mem_def (A B : Class.{u}) : A ∈ B ↔ ∃ x, ↑x = A ∧ B x := iff.rfl

@[simp] theorem not_mem_empty (x : Class.{u}) : x ∉ (∅ : Class.{u}) := λ ⟨_, _, h⟩, h

@[simp] theorem not_empty_hom (x : Set.{u}) : ¬ (∅ : Class.{u}) x := id

@[simp] theorem mem_univ {A : Class.{u}} : A ∈ univ.{u} ↔ ∃ x : Set.{u}, ↑x = A :=
exists_congr $ λ x, and_true _

@[simp] theorem mem_univ_hom (x : Set.{u}) : univ.{u} x := trivial

theorem eq_univ_iff_forall {A : Class.{u}} : A = univ ↔ ∀ x : Set, A x := set.eq_univ_iff_forall
theorem eq_univ_of_forall {A : Class.{u}} : (∀ x : Set, A x) → A = univ := set.eq_univ_of_forall

theorem mem_wf : @well_founded Class.{u} (∈) :=
⟨begin
  have H : ∀ x : Set.{u}, @acc Class.{u} (∈) ↑x,
  { refine λ a, Set.induction_on a (λ x IH, ⟨x, _⟩),
    rintros A ⟨z, rfl, hz⟩,
    exact IH z hz },
  { refine λ A, ⟨A, _⟩,
    rintros B ⟨x, rfl, hx⟩,
    exact H x }
end⟩

instance : has_well_founded Class := ⟨_, mem_wf⟩
instance : is_asymm Class (∈) := mem_wf.is_asymm

theorem mem_asymm {x y : Class} : x ∈ y → y ∉ x := asymm
theorem mem_irrefl (x : Class) : x ∉ x := irrefl x

/-- **There is no universal set.**

This is stated as `univ ∉ univ`, meaning that `univ` (the class of all sets) is proper (does not
belong to the class of all sets). -/
theorem univ_not_mem_univ : univ ∉ univ := mem_irrefl _

/-- Convert a conglomerate (a collection of classes) into a class -/
def Cong_to_Class (x : set Class.{u}) : Class.{u} := {y | ↑y ∈ x}

@[simp] theorem Cong_to_Class_empty : Cong_to_Class ∅ = ∅ :=
by { ext, simp [Cong_to_Class] }

/-- Convert a class into a conglomerate (a collection of classes) -/
def Class_to_Cong (x : Class.{u}) : set Class.{u} := {y | y ∈ x}

@[simp] theorem Class_to_Cong_empty : Class_to_Cong ∅ = ∅ :=
by { ext, simp [Class_to_Cong] }

/-- The power class of a class is the class of all subclasses that are ZFC sets -/
def powerset (x : Class) : Class := Cong_to_Class (set.powerset x)

/-- The union of a class is the class of all members of ZFC sets in the class -/
def sUnion (x : Class) : Class := ⋃₀ (Class_to_Cong x)

prefix (name := Class.sUnion) `⋃₀ `:110 := Class.sUnion

/-- The intersection of a class is the class of all members of ZFC sets in the class -/
def sInter (x : Class) : Class := ⋂₀ Class_to_Cong x

prefix (name := Class.sInter) `⋂₀ `:110 := Class.sInter

theorem of_Set.inj {x y : Set.{u}} (h : (x : Class.{u}) = y) : x = y :=
Set.ext $ λ z, by { change (x : Class.{u}) z ↔ (y : Class.{u}) z, rw h }

@[simp] theorem to_Set_of_Set (A : Class.{u}) (x : Set.{u}) : to_Set A x ↔ A x :=
⟨λ ⟨y, yx, py⟩, by rwa of_Set.inj yx at py, λ px, ⟨x, rfl, px⟩⟩

@[simp, norm_cast] theorem coe_mem {x : Set.{u}} {A : Class.{u}} : (x : Class.{u}) ∈ A ↔ A x :=
to_Set_of_Set _ _

@[simp] theorem coe_apply {x y : Set.{u}} : (y : Class.{u}) x ↔ x ∈ y := iff.rfl

@[simp, norm_cast] theorem coe_subset (x y : Set.{u}) : (x : Class.{u}) ⊆ y ↔ x ⊆ y := iff.rfl

@[simp, norm_cast] theorem coe_sep (p : Class.{u}) (x : Set.{u}) :
  (↑{y ∈ x | p y} : Class.{u}) = {y ∈ x | p y} :=
ext $ λ y, Set.mem_sep

@[simp, norm_cast] theorem coe_empty : ↑(∅ : Set.{u}) = (∅ : Class.{u}) :=
ext $ λ y, (iff_false _).2 $ Set.not_mem_empty y

@[simp, norm_cast] theorem coe_insert (x y : Set.{u}) :
  ↑(insert x y) = @insert Set.{u} Class.{u} _ x y :=
ext $ λ z, Set.mem_insert_iff

@[simp, norm_cast] theorem coe_union (x y : Set.{u}) : ↑(x ∪ y) = (x : Class.{u}) ∪ y :=
ext $ λ z, Set.mem_union

@[simp, norm_cast] theorem coe_inter (x y : Set.{u}) : ↑(x ∩ y) = (x : Class.{u}) ∩ y :=
ext $ λ z, Set.mem_inter

@[simp, norm_cast] theorem coe_diff (x y : Set.{u}) : ↑(x \ y) = (x : Class.{u}) \ y :=
ext $ λ z, Set.mem_diff

@[simp, norm_cast] theorem coe_powerset (x : Set.{u}) : ↑x.powerset = powerset.{u} x :=
ext $ λ z, Set.mem_powerset

@[simp] theorem powerset_apply {A : Class.{u}} {x : Set.{u}} : powerset A x ↔ ↑x ⊆ A := iff.rfl

@[simp] theorem sUnion_apply {x : Class} {y : Set} : (⋃₀ x) y ↔ ∃ z : Set, x z ∧ y ∈ z :=
begin
  split,
  { rintro ⟨-, ⟨z, rfl, hxz⟩, hyz⟩,
    exact ⟨z, hxz, hyz⟩ },
  { exact λ ⟨z, hxz, hyz⟩, ⟨_, coe_mem.2 hxz, hyz⟩ }
end

@[simp, norm_cast] theorem coe_sUnion (x : Set.{u}) : ↑(⋃₀ x) = ⋃₀ (x : Class.{u}) :=
ext $ λ y, Set.mem_sUnion.trans (sUnion_apply.trans $ by simp_rw [coe_apply, exists_prop]).symm

@[simp] theorem mem_sUnion {x y : Class.{u}} : y ∈ ⋃₀ x ↔ ∃ z, z ∈ x ∧ y ∈ z :=
begin
  split,
  { rintro ⟨w, rfl, z, hzx, hwz⟩,
    exact ⟨z, hzx, coe_mem.2 hwz⟩ },
  { rintro ⟨w, hwx, z, rfl, hwz⟩,
    exact ⟨z, rfl, w, hwx, hwz⟩ }
end

@[simp] theorem sInter_apply {x : Class.{u}} {y : Set.{u}} :
  (⋂₀ x) y ↔ ∀ z : Set.{u}, x z → y ∈ z :=
begin
  refine ⟨λ hxy z hxz, hxy _ ⟨z, rfl, hxz⟩, _⟩,
  rintro H - ⟨z, rfl, hxz⟩,
  exact H _ hxz
end

@[simp, norm_cast] theorem sInter_coe {x : Set.{u}} (h : x.nonempty) : ⋂₀ (x : Class.{u}) = ⋂₀ x :=
set.ext $ λ y, sInter_apply.trans (Set.mem_sInter h).symm

theorem mem_of_mem_sInter {x y z : Class} (hy : y ∈ ⋂₀ x) (hz : z ∈ x) : y ∈ z :=
by { obtain ⟨w, rfl, hw⟩ := hy, exact coe_mem.2 (hw z hz) }

theorem mem_sInter {x y : Class.{u}} (h : x.nonempty) : y ∈ ⋂₀ x ↔ ∀ z, z ∈ x → y ∈ z :=
begin
  refine ⟨λ hy z, mem_of_mem_sInter hy, λ H, _⟩,
  simp_rw [mem_def, sInter_apply],
  obtain ⟨z, hz⟩ := h,
  obtain ⟨y, rfl, hzy⟩ := H z (coe_mem.2 hz),
  refine ⟨y, rfl, λ w hxw, _⟩,
  simpa only [coe_mem, coe_apply] using H w (coe_mem.2 hxw),
end

@[simp] theorem sUnion_empty : ⋃₀ (∅ : Class.{u}) = ∅ := by { ext, simp }
@[simp] theorem sInter_empty : ⋂₀ (∅ : Class.{u}) = univ := by { ext, simp [sInter, ←univ] }

/-- An induction principle for sets. If every subset of a class is a member, then the class is
  universal. -/
theorem eq_univ_of_powerset_subset {A : Class} (hA : powerset A ⊆ A) : A = univ :=
eq_univ_of_forall begin
  by_contra' hnA,
  exact well_founded.min_mem Set.mem_wf _ hnA (hA $ λ x hx, not_not.1 $
    λ hB, well_founded.not_lt_min Set.mem_wf _ hnA hB $ coe_apply.1 hx)
end

/-- The definite description operator, which is `{x}` if `{y | A y} = {x}` and `∅` otherwise. -/
def iota (A : Class) : Class := ⋃₀ {x | ∀ y, A y ↔ y = x}

theorem iota_val (A : Class) (x : Set) (H : ∀ y, A y ↔ y = x) : iota A = ↑x :=
ext $ λ y, ⟨λ ⟨._, ⟨x', rfl, h⟩, yx'⟩, by rwa ←((H x').1 $ (h x').2 rfl),
  λ yx, ⟨_, ⟨x, rfl, H⟩, yx⟩⟩

/-- Unlike the other set constructors, the `iota` definite descriptor
  is a set for any set input, but not constructively so, so there is no
  associated `Class → Set` function. -/
theorem iota_ex (A) : iota.{u} A ∈ univ.{u} :=
mem_univ.2 $ or.elim (classical.em $ ∃ x, ∀ y, A y ↔ y = x)
 (λ ⟨x, h⟩, ⟨x, eq.symm $ iota_val A x h⟩)
 (λ hn, ⟨∅, ext (λ z, coe_empty.symm ▸ ⟨false.rec _, λ ⟨._, ⟨x, rfl, H⟩, zA⟩, hn ⟨x, H⟩⟩)⟩)

/-- Function value -/
def fval (F A : Class.{u}) : Class.{u} := iota (λ y, to_Set (λ x, F (Set.pair x y)) A)
infixl ` ′ `:100 := fval

theorem fval_ex (F A : Class.{u}) : F ′ A ∈ univ.{u} := iota_ex _

end Class

namespace Set

@[simp] theorem map_fval {f : Set.{u} → Set.{u}} [H : pSet.definable 1 f]
  {x y : Set.{u}} (h : y ∈ x) :
  (Set.map f x ′ y : Class.{u}) = f y :=
Class.iota_val _ _ (λ z, by { rw [Class.to_Set_of_Set, Class.coe_apply, mem_map], exact
  ⟨λ ⟨w, wz, pr⟩, let ⟨wy, fw⟩ := Set.pair_injective pr in by rw[←fw, wy],
  λ e, by { subst e, exact ⟨_, h, rfl⟩ }⟩ })

variables (x : Set.{u}) (h : ∅ ∉ x)

/-- A choice function on the class of nonempty ZFC sets. -/
noncomputable def choice : Set :=
@map (λ y, classical.epsilon (λ z, z ∈ y)) (classical.all_definable _) x

include h
theorem choice_mem_aux (y : Set.{u}) (yx : y ∈ x) : classical.epsilon (λ z : Set.{u}, z ∈ y) ∈ y :=
@classical.epsilon_spec _ (λ z : Set.{u}, z ∈ y) $ classical.by_contradiction $ λ n, h $
by rwa ←((eq_empty y).2 $ λ z zx, n ⟨z, zx⟩)

theorem choice_is_func : is_func x (⋃₀ x) (choice x) :=
(@map_is_func _ (classical.all_definable _) _ _).2 $
  λ y yx, mem_sUnion.2 ⟨y, yx, choice_mem_aux x h y yx⟩

theorem choice_mem (y : Set.{u}) (yx : y ∈ x) : (choice x ′ y : Class.{u}) ∈ (y : Class.{u}) :=
begin
  delta choice,
  rw [map_fval yx, Class.coe_mem, Class.coe_apply],
  exact choice_mem_aux x h y yx
end

end Set


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

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

instance has_mem : has_mem α (option α) := ⟨λ a b, b = some a⟩

@[simp] theorem mem_def {a : α} {b : option α} : a ∈ b ↔ b = some a :=
iff.rfl

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

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

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

theorem some_inj {a b : α} : some a = some b ↔ a = b := by simp

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

theorem is_none_iff_eq_none {o : option α} : o.is_none ↔ o = none :=
⟨option.eq_none_of_is_none, λ e, e.symm ▸ rfl⟩

instance decidable_eq_none {o : option α} : decidable (o = none) :=
decidable_of_bool _ is_none_iff_eq_none

instance decidable_forall_mem {p : α → Prop} [decidable_pred p] :
  ∀ o : option α, decidable (∀ a ∈ o, p a)
| none     := is_true (by simp)
| (some a) := decidable_of_iff (p a) (by simp)

instance decidable_exists_mem {p : α → Prop} [decidable_pred p] :
  ∀ o : option α, decidable (∃ a ∈ o, p a)
| none     := is_false (by simp)
| (some a) := decidable_of_iff (p a) (by simp)

/-- inhabited `get` function. Returns `a` if the input is `some a`,
  otherwise returns `default`. -/
@[reducible] def iget [inhabited α] : option α → α
| (some x) := x
| none     := default α

@[simp] theorem iget_some [inhabited α] {a : α} : (some a).iget = a := rfl

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

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

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

/-- `guard p a` returns `some a` if `p a` holds, otherwise `none`. -/
def guard (p : α → Prop) [decidable_pred p] (a : α) : option α :=
if p a then some a else none

/-- `filter p o` returns `some a` if `o` is `some a`
  and `p a` holds, otherwise `none`. -/
def filter (p : α → Prop) [decidable_pred p] (o : option α) : option α :=
o.bind (guard p)

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

def to_list : option α → list α
| none     := []
| (some a) := [a]

@[simp] theorem mem_to_list {a : α} {o : option α} : a ∈ to_list o ↔ a ∈ o :=
by cases o; simp [to_list, eq_comm]

def lift_or_get (f : α → α → α) : option α → option α → option α
| none     none     := none
| (some a) none     := some a       -- get a
| none     (some b) := some b       -- get b
| (some a) (some b) := some (f a b) -- lift f

instance lift_or_get_comm (f : α → α → α) [h : is_commutative α f] :
  is_commutative (option α) (lift_or_get f) :=
⟨λ a b, by cases a; cases b; simp [lift_or_get, h.comm]⟩

instance lift_or_get_assoc (f : α → α → α) [h : is_associative α f] :
  is_associative (option α) (lift_or_get f) :=
⟨λ a b c, by cases a; cases b; cases c; simp [lift_or_get, h.assoc]⟩

instance lift_or_get_idem (f : α → α → α) [h : is_idempotent α f] :
  is_idempotent (option α) (lift_or_get f) :=
⟨λ a, by cases a; simp [lift_or_get, h.idempotent]⟩

instance lift_or_get_is_left_id (f : α → α → α) :
  is_left_id (option α) (lift_or_get f) none :=
⟨λ a, by cases a; simp [lift_or_get]⟩

instance lift_or_get_is_right_id (f : α → α → α) :
  is_right_id (option α) (lift_or_get f) none :=
⟨λ a, by cases a; simp [lift_or_get]⟩

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

inductive rel (r : α → β → Prop) : option α → option β → Prop
| some {a b} : r a b → rel (some a) (some b)
| none {}    : rel none none

end rel

end option


import Mathlib.Data.Nat.Basic
import Mathlib.Init.Algebra.Order
import Mathlib.Init.Data.Nat.Basic
import Mathlib.Init.Data.Nat.Lemmas
import Mathlib.Init.Data.Int.Basic
import Mathlib.Data.String.Defs
import Mathlib.Data.String.Lemmas
import Mathlib.Data.Equiv.Basic
import Timelib.Util
import Timelib.NanoPrecision.Duration.SignedDuration
import Timelib.NanoPrecision.Duration.UnsignedDuration
import Timelib.NanoPrecision.DateTime.NaiveDateTime
import Timelib.NanoPrecision.TimeZone.Basic
import Lean.Data.Json

/-
I think you want a TAI type for the marker aspect if nothing else.
-/
structure Offset extends TimeZone where
  identifier : String
  leapSecondsToApply : NaiveDateTime → SignedDuration
  leapSecondsToRemove : NaiveDateTime → SignedDuration

abbrev Offset.timeZoneOffset (ω : Offset) := ω.toTimeZone.offset
abbrev Offset.taiToUtc (ω : Offset) (t : NaiveDateTime) := t + (ω.leapSecondsToApply t)
abbrev Offset.utcToTai (ω : Offset) (t : NaiveDateTime) := t + (ω.leapSecondsToRemove t)

/--
An `Offset` is lawful if the functions returning leap seconds to remove
and apply are isomorphic.
-/
class LawfulOffset (ω : Offset) where
  applyRemoveIso : ω.taiToUtc ∘ ω.utcToTai = id
  removeApplyIso : ω.utcToTai ∘ ω.taiToUtc = id

/--
The integer numberof TAI nanoseconds, relative to a zero of Janauary 1, year 1 in the Gregorian calendar.
If positive, the underlying number of TAI nanoseconds greater than the dawn of 1/1/1.
If negative, the number of TAI nanoseconds less than the dawn of 1/1/1.
-/
structure DateTime (ω : Offset) where
  naive : NaiveDateTime
deriving DecidableEq, Repr, Hashable, Lean.FromJson, Lean.ToJson

instance {ω : Offset} : Inhabited (DateTime ω) where
  default := ⟨Inhabited.default⟩

/--
This is a safe conversion since the underlying time is tracked
using a `NaiveDateTime` that represents a TAI date/time.
-/
def DateTime.changeOffset {ω : Offset} (t : DateTime ω) (π : Offset) : DateTime π := ⟨t.naive⟩

section DateTimeStuff

variable {ω π : Offset}

theorem DateTime.eq_of_val_eq : ∀ {d₁ d₂ : DateTime ω} (_ : d₁.naive = d₂.naive), d₁ = d₂
| ⟨_⟩, _, rfl => rfl

theorem DateTime.val_ne_of_ne : ∀ {d₁ d₂ : DateTime ω} (_ : d₁ ≠ d₂), d₁.naive ≠ d₂.naive
| ⟨x⟩, ⟨y⟩, h => by intro hh; apply h; exact congrArg DateTime.mk hh

/-- Compares the underlying naive/TAI DateTime -/
instance : LT (DateTime ω) where
  lt := InvImage (instLTNaiveDateTime.lt) DateTime.naive

/-- Compares the underlying naive/TAI DateTime -/
instance : LE (DateTime ω) where
  le := InvImage (instLENaiveDateTime.le) DateTime.naive

@[simp] theorem DateTime.le_def (d₁ d₂ : DateTime ω) : (d₁ <= d₂) = (d₁.naive <= d₂.naive) := rfl
@[simp] theorem DateTime.lt_def (d₁ d₂ : DateTime ω) : (d₁ < d₂) = (d₁.naive < d₂.naive) := rfl

instance instDecidableLEDateTime (d₁ d₂ : DateTime ω) : Decidable (d₁ <= d₂) := inferInstanceAs (Decidable (d₁.naive <= d₂.naive))
instance instDecidableLTDateTime (d₁ d₂ : DateTime ω) : Decidable (d₁ < d₂) := inferInstanceAs (Decidable <| d₁.naive < d₂.naive)

instance : LinearOrder (DateTime ω) where
  le_refl (a) := le_refl a.naive
  le_trans (a b c) := Int.le_trans
  lt_iff_le_not_le (a b) := Int.lt_iff_le_not_le
  le_antisymm (a b h1 h2) := by
    rw [DateTime.le_def] at h1 h2
    exact DateTime.eq_of_val_eq (le_antisymm h1 h2)
  le_total := by simp [DateTime.le_def, le_total]
  decidable_le := inferInstance

instance : HAdd (DateTime ω) SignedDuration (DateTime ω) where
  hAdd da du := ⟨da.naive + du⟩

instance : HAdd SignedDuration (DateTime ω) (DateTime ω)  where
  hAdd du da := da + du

theorem DateTime.hAdd_signed_def (d : DateTime ω) (dur : SignedDuration) : d + dur = ⟨d.naive + dur⟩ := rfl
theorem DateTime.hAdd_signed_def_rev (d : DateTime ω) (dur : SignedDuration) : dur + d = ⟨dur + d.naive⟩ := rfl

instance : HSub (DateTime ω) SignedDuration (DateTime ω) where
  hSub d dur := d + -dur

theorem DateTime.hSub_signed_def (d : DateTime ω) (dur : SignedDuration) : d - dur = d + -dur := rfl

instance : HAdd (DateTime ω) UnsignedDuration (DateTime ω) where
  hAdd da du := ⟨da.naive + du⟩

instance : HAdd UnsignedDuration (DateTime ω) (DateTime ω)  where
  hAdd du da := da + du

theorem DateTime.hAdd_def_unsigned (d : DateTime ω) (dur : UnsignedDuration) : d + dur = ⟨d.naive + dur⟩ := rfl

@[defaultInstance]
instance : HSub (DateTime ω) UnsignedDuration (DateTime ω) where
  hSub d dur := d - (dur : SignedDuration)

theorem DateTime.hSub_def_unsigned (d : DateTime ω) (dur : UnsignedDuration) : d - dur = d + -(dur : SignedDuration) := rfl

theorem DateTime.hAdd_signed_assoc (d : DateTime ω) (dur₁ dur₂ : SignedDuration) : d + dur₁ + dur₂ = d + (dur₁ + dur₂) := by
  simp [DateTime.hAdd_signed_def, NaiveDateTime.hAdd_signed_def]
  exact Int.add_assoc _ _ _

theorem DateTime.hAdd_signed_comm (d : DateTime ω) (dur : SignedDuration) : d + dur = dur + d := by
  simp [DateTime.hAdd_signed_def, NaiveDateTime.hAdd_signed_def, DateTime.hAdd_signed_def_rev, NaiveDateTime.hAdd_signed_def_rev]

/--
Incorporate the relevant leap seconds and the timezone offset, creating
a `NaiveDateTime` that carries the local number of nanos.
-/
def DateTime.toLocalNaive (t : DateTime ω) : NaiveDateTime :=
  /- The utc time; the naive time + leap seconds -/
  let utc := t.naive + (ω.leapSecondsToApply t.naive)
  utc + ω.timeZoneOffset

/--
Convert a `NaiveDateTime` representing a
-/
--def DateTime.fromTai (t : TaiDateTime) : DateTime ω := ⟨t⟩
-- vv This definition sort of makes more sense
def DateTime.fromTai (t : NaiveDateTime) : DateTime ω := ⟨t⟩
/--
Convert a `NaiveDateTime` that is local (has leap seconds and timezone offset applied)
and convert it to a `DateTime`.
-/
def DateTime.fromLocalNaive (t : NaiveDateTime) : DateTime ω :=
  /- Remove the timezone offset to get utc -/
  let utc := t - ω.timeZoneOffset
  /- Add whatever the corresponding `leapSecondsToRemove` value is -/
  ⟨utc + ω.leapSecondsToRemove utc⟩

/--
-/
def DateTime.fromLocalYmdsn
  (y : Year)
  (m : Month)
  (d : Nat)
  (s : Nat)
  (n : Nat)
  (hd : 1 <= d ∧ d <= m.numDays y := by decide) : DateTime ω :=
  DateTime.fromLocalNaive (NaiveDateTime.fromYmdsn y m d s n hd)

/--
Set the local clock time without changing the date.

For example
t : DateTime ω := LOCAL 2022/6/12 @ 11:00:00.0
t.setLocalClockTime (3:00:00.0)
= LOCAL 2022/6/12 @ 3:00:00.0
-/
def DateTime.setLocalClockTime (t : DateTime ω) (c : NaiveClockTime) : DateTime ω :=
  DateTime.fromLocalNaive (t.toLocalNaive.setClockTime c)

/--
Use cases for this are probably rare, so make sure you know what you're getting.

`compareLocalTimes` compares the literal calendar/wall clock datetimes from two time
stamps, without any regard for what underlying time they represent.
-/
def DateTime.compareLocal (t₁ : DateTime ω) (t₂ : DateTime π) : Ordering :=
  Ord.compare t₁.toLocalNaive t₂.toLocalNaive

def DateTime.localScalarDate (t : DateTime ω) : ScalarDate := t.toLocalNaive.toScalarDate
def DateTime.localYmd (t : DateTime ω) : Ymd := t.toLocalNaive.toYmd
def DateTime.localYear (t : DateTime ω) : Year := t.localScalarDate.year

end DateTimeStuff

@[reducible]
def Offset.tai : Offset := {
  name := "International Atomic Time"
  abbreviation := "TAI"
  offset := 0
  identifier := ""
  leapSecondsToApply := fun _ => 0
  leapSecondsToRemove := fun _ => 0
}

instance : LawfulOffset Offset.tai where
  applyRemoveIso := by
    apply funext; simp [Offset.leapSecondsToApply, Offset.leapSecondsToRemove, NaiveDateTime.hAdd_signed_def]
  removeApplyIso := by
    apply funext; simp [Offset.leapSecondsToApply, Offset.leapSecondsToRemove, NaiveDateTime.hAdd_signed_def]

/--
The `leapSmear` offset should NOT be used as a way of representing TAI time, or another
time metric that ignores leap seconds (for that, see )
While leap smearing ostensibly looks the same as TAI, there's a specific connotation
in the type, which is that the oracle/reference being used IS actually accounting for some
agreed-upon number of leap seconds and incorporating them into the time-stamps.

LeapSmear has a specific connotation, particularly in that it shouldn't display
"60" as a number of seconds.
-/
@[reducible]
def Offset.leapSmear (tz : TimeZone) : Offset := {
  name := ""
  abbreviation := ""
  offset := tz.offset
  -- This identifier should be changed to the user's preference; users will want to use this to identify the
  -- oracle that's being used for the smear values.
  identifier := ""
  leapSecondsToApply := fun _ => 0
  leapSecondsToRemove := fun _ => 0
}

instance {tz : TimeZone} : LawfulOffset (Offset.leapSmear tz) where
  applyRemoveIso := by
    apply funext; simp [Offset.leapSecondsToApply, Offset.leapSecondsToRemove, NaiveDateTime.hAdd_signed_def]
  removeApplyIso := by
    apply funext; simp [Offset.leapSecondsToApply, Offset.leapSecondsToRemove, NaiveDateTime.hAdd_signed_def]

/-
This definition of TAI time is convenient because it allows for comparison with other elements of `DateTime ω`,
and preserves type safety relative to `NaiveDateTime`, which carries no assertion that it represents
a TAI date/time element.
-/
@[reducible]
def TaiDateTime := DateTime Offset.tai


/-
Copyright (c) 2020 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.algebra.category.Module.basic
import Mathlib.algebra.category.Group.limits
import Mathlib.algebra.direct_limit
import Mathlib.PostPort

universes u v u_1

namespace Mathlib

/-!
# The category of R-modules has all limits

Further, these limits are preserved by the forgetful functor --- that is,
the underlying types are just the limits in the category of types.
-/

namespace Module

protected instance add_comm_group_obj {R : Type u} [ring R] {J : Type v} [category_theory.small_category J] (F : J ⥤ Module R) (j : J) : add_comm_group (category_theory.functor.obj (F ⋙ category_theory.forget (Module R)) j) :=
  id (is_add_comm_group (category_theory.functor.obj F j))

protected instance module_obj {R : Type u} [ring R] {J : Type v} [category_theory.small_category J] (F : J ⥤ Module R) (j : J) : module R (category_theory.functor.obj (F ⋙ category_theory.forget (Module R)) j) :=
  id (is_module (category_theory.functor.obj F j))

/--
The flat sections of a functor into `Module R` form a submodule of all sections.
-/
def sections_submodule {R : Type u} [ring R] {J : Type v} [category_theory.small_category J] (F : J ⥤ Module R) : submodule R ((j : J) → ↥(category_theory.functor.obj F j)) :=
  submodule.mk (category_theory.functor.sections (F ⋙ category_theory.forget (Module R))) sorry sorry sorry

protected instance limit_add_comm_group {R : Type u} [ring R] {J : Type v} [category_theory.small_category J] (F : J ⥤ Module R) : add_comm_group
  (category_theory.limits.cone.X (category_theory.limits.types.limit_cone (F ⋙ category_theory.forget (Module R)))) :=
  id (submodule.add_comm_group (sections_submodule F))

protected instance limit_module {R : Type u} [ring R] {J : Type v} [category_theory.small_category J] (F : J ⥤ Module R) : module R
  (category_theory.limits.cone.X (category_theory.limits.types.limit_cone (F ⋙ category_theory.forget (Module R)))) :=
  id (submodule.semimodule (sections_submodule F))

/-- `limit.π (F ⋙ forget Ring) j` as a `ring_hom`. -/
def limit_π_linear_map {R : Type u} [ring R] {J : Type v} [category_theory.small_category J] (F : J ⥤ Module R) (j : J) : linear_map R
  (category_theory.limits.cone.X (category_theory.limits.types.limit_cone (F ⋙ category_theory.forget (Module R))))
  (category_theory.functor.obj (F ⋙ category_theory.forget (Module R)) j) :=
  linear_map.mk
    (category_theory.nat_trans.app
      (category_theory.limits.cone.π (category_theory.limits.types.limit_cone (F ⋙ category_theory.forget (Module R)))) j)
    sorry sorry

namespace has_limits

-- The next two definitions are used in the construction of `has_limits (Module R)`.

-- After that, the limits should be constructed using the generic limits API,

-- e.g. `limit F`, `limit.cone F`, and `limit.is_limit F`.

/--
Construction of a limit cone in `Module R`.
(Internal use only; use the limits API.)
-/
def limit_cone {R : Type u} [ring R] {J : Type v} [category_theory.small_category J] (F : J ⥤ Module R) : category_theory.limits.cone F :=
  category_theory.limits.cone.mk
    (of R
      (category_theory.limits.cone.X (category_theory.limits.types.limit_cone (F ⋙ category_theory.forget (Module R)))))
    (category_theory.nat_trans.mk (limit_π_linear_map F))

/--
Witness that the limit cone in `Module R` is a limit cone.
(Internal use only; use the limits API.)
-/
def limit_cone_is_limit {R : Type u} [ring R] {J : Type v} [category_theory.small_category J] (F : J ⥤ Module R) : category_theory.limits.is_limit (limit_cone F) :=
  category_theory.limits.is_limit.of_faithful (category_theory.forget (Module R))
    (category_theory.limits.types.limit_cone_is_limit (F ⋙ category_theory.forget (Module R)))
    (fun (s : category_theory.limits.cone F) =>
      linear_map.mk
        (fun
          (v : category_theory.limits.cone.X (category_theory.functor.map_cone (category_theory.forget (Module R)) s)) =>
          { val :=
              fun (j : J) =>
                category_theory.nat_trans.app
                  (category_theory.limits.cone.π (category_theory.functor.map_cone (category_theory.forget (Module R)) s))
                  j v,
            property := sorry })
        sorry sorry)
    sorry

end has_limits

/-- The category of R-modules has all limits. -/
protected instance has_limits {R : Type u} [ring R] : category_theory.limits.has_limits (Module R) :=
  category_theory.limits.has_limits.mk
    fun (J : Type v) (𝒥 : category_theory.small_category J) =>
      category_theory.limits.has_limits_of_shape.mk
        fun (F : J ⥤ Module R) => category_theory.limits.has_limit.mk (category_theory.limits.limit_cone.mk sorry sorry)

/--
An auxiliary declaration to speed up typechecking.
-/
def forget₂_AddCommGroup_preserves_limits_aux {R : Type u} [ring R] {J : Type v} [category_theory.small_category J] (F : J ⥤ Module R) : category_theory.limits.is_limit
  (category_theory.functor.map_cone (category_theory.forget₂ (Module R) AddCommGroup) (has_limits.limit_cone F)) :=
  AddCommGroup.limit_cone_is_limit (F ⋙ category_theory.forget₂ (Module R) AddCommGroup)

/--
The forgetful functor from R-modules to abelian groups preserves all limits.
-/
protected instance forget₂_AddCommGroup_preserves_limits {R : Type u} [ring R] : category_theory.limits.preserves_limits (category_theory.forget₂ (Module R) AddCommGroup) :=
  category_theory.limits.preserves_limits.mk
    fun (J : Type v) (𝒥 : category_theory.small_category J) =>
      category_theory.limits.preserves_limits_of_shape.mk
        fun (F : J ⥤ Module R) =>
          category_theory.limits.preserves_limit_of_preserves_limit_cone (has_limits.limit_cone_is_limit F)
            (forget₂_AddCommGroup_preserves_limits_aux F)

/--
The forgetful functor from R-modules to types preserves all limits.
-/
protected instance forget_preserves_limits {R : Type u} [ring R] : category_theory.limits.preserves_limits (category_theory.forget (Module R)) :=
  category_theory.limits.preserves_limits.mk
    fun (J : Type u_1) (𝒥 : category_theory.small_category J) =>
      category_theory.limits.preserves_limits_of_shape.mk
        fun (F : J ⥤ Module R) =>
          category_theory.limits.preserves_limit_of_preserves_limit_cone (has_limits.limit_cone_is_limit F)
            (category_theory.limits.types.limit_cone_is_limit (F ⋙ category_theory.forget (Module R)))

/-- The diagram (in the sense of `category_theory`)
 of an unbundled `direct_limit` of modules. -/
@[simp] theorem direct_limit_diagram_map {R : Type u} [ring R] {ι : Type v} [directed_order ι] (G : ι → Type v) [(i : ι) → add_comm_group (G i)] [(i : ι) → module R (G i)] (f : (i j : ι) → i ≤ j → linear_map R (G i) (G j)) [module.directed_system G f] (i : ι) (j : ι) (hij : i ⟶ j) : category_theory.functor.map (direct_limit_diagram G f) hij = f i j (direct_limit_diagram._proof_1 i j hij) :=
  Eq.refl (category_theory.functor.map (direct_limit_diagram G f) hij)

/-- The `cocone` on `direct_limit_diagram` corresponding to
the unbundled `direct_limit` of modules.

In `direct_limit_is_colimit` we show that it is a colimit cocone. -/
@[simp] theorem direct_limit_cocone_ι_app {R : Type u} [ring R] {ι : Type v} [directed_order ι] (G : ι → Type v) [(i : ι) → add_comm_group (G i)] [(i : ι) → module R (G i)] (f : (i j : ι) → i ≤ j → linear_map R (G i) (G j)) [module.directed_system G f] [DecidableEq ι] (i : ι) : category_theory.nat_trans.app (category_theory.limits.cocone.ι (direct_limit_cocone G f)) i =
  module.direct_limit.of R ι G f i :=
  Eq.refl (category_theory.nat_trans.app (category_theory.limits.cocone.ι (direct_limit_cocone G f)) i)

/-- The unbundled `direct_limit` of modules is a colimit
in the sense of `category_theory`. -/
def direct_limit_is_colimit {R : Type u} [ring R] {ι : Type v} [directed_order ι] (G : ι → Type v) [(i : ι) → add_comm_group (G i)] [(i : ι) → module R (G i)] (f : (i j : ι) → i ≤ j → linear_map R (G i) (G j)) [module.directed_system G f] [DecidableEq ι] [Nonempty ι] : category_theory.limits.is_colimit (direct_limit_cocone G f) :=
  category_theory.limits.is_colimit.mk
    fun (s : category_theory.limits.cocone (direct_limit_diagram G f)) =>
      module.direct_limit.lift R ι G f (category_theory.nat_trans.app (category_theory.limits.cocone.ι s)) sorry


/-
Copyright (c) 2018 Jeremy Avigad. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Author: Jeremy Avigad, Simon Hudon
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.control.functor.multivariate
import Mathlib.data.pfunctor.multivariate.basic
import Mathlib.data.pfunctor.multivariate.M
import Mathlib.data.qpf.multivariate.basic
import Mathlib.PostPort

universes u u_1

namespace Mathlib

/-!
# The final co-algebra of a multivariate qpf is again a qpf.

For a `(n+1)`-ary QPF `F (α₀,..,αₙ)`, we take the least fixed point of `F` with
regards to its last argument `αₙ`. The result is a `n`-ary functor: `fix F (α₀,..,αₙ₋₁)`.
Making `fix F` into a functor allows us to take the fixed point, compose with other functors
and take a fixed point again.

## Main definitions

 * `cofix.mk`     - constructor
 * `cofix.dest    - destructor
 * `cofix.corec`  - corecursor: useful for formulating infinite, productive computations
 * `cofix.bisim`  - bisimulation: proof technique to show the equality of possibly infinite values
                    of `cofix F α`

## Implementation notes

For `F` a QPF`, we define `cofix F α` in terms of the M-type of the polynomial functor `P` of `F`.
We define the relation `Mcongr` and take its quotient as the definition of `cofix F α`.

`Mcongr` is taken as the weakest bisimulation on M-type.  See
[avigad-carneiro-hudon2019] for more details.

## Reference

 * [Jeremy Avigad, Mario M. Carneiro and Simon Hudon, *Data Types as Quotients of Polynomial Functors*][avigad-carneiro-hudon2019]
-/

namespace mvqpf

/-- `corecF` is used as a basis for defining the corecursor of `cofix F α`. `corecF`
uses corecursion to construct the M-type generated by `q.P` and uses function on `F`
as a corecursive step -/
def corecF {n : ℕ} {F : typevec (n + 1) → Type u} [mvfunctor F] [q : mvqpf F] {α : typevec n} {β : Type u} (g : β → F (α ::: β)) : β → mvpfunctor.M (P F) α :=
  mvpfunctor.M.corec (P F) fun (x : β) => repr (g x)

theorem corecF_eq {n : ℕ} {F : typevec (n + 1) → Type u} [mvfunctor F] [q : mvqpf F] {α : typevec n} {β : Type u} (g : β → F (α ::: β)) (x : β) : mvpfunctor.M.dest (P F) (corecF g x) = mvfunctor.map (typevec.id ::: corecF g) (repr (g x)) := sorry

/-- Characterization of desirable equivalence relations on M-types -/
def is_precongr {n : ℕ} {F : typevec (n + 1) → Type u} [mvfunctor F] [q : mvqpf F] {α : typevec n} (r : mvpfunctor.M (P F) α → mvpfunctor.M (P F) α → Prop) :=
  ∀ {x y : mvpfunctor.M (P F) α},
    r x y →
      abs (mvfunctor.map (typevec.id ::: Quot.mk r) (mvpfunctor.M.dest (P F) x)) =
        abs (mvfunctor.map (typevec.id ::: Quot.mk r) (mvpfunctor.M.dest (P F) y))

/-- Equivalence relation on M-types representing a value of type `cofix F` -/
def Mcongr {n : ℕ} {F : typevec (n + 1) → Type u} [mvfunctor F] [q : mvqpf F] {α : typevec n} (x : mvpfunctor.M (P F) α) (y : mvpfunctor.M (P F) α) :=
  ∃ (r : mvpfunctor.M (P F) α → mvpfunctor.M (P F) α → Prop), is_precongr r ∧ r x y

/-- Greatest fixed point of functor F. The result is a functor with one fewer parameters
than the input. For `F a b c` a ternary functor, fix F is a binary functor such that

```lean
cofix F a b = F a b (cofix F a b)
```
-/
def cofix {n : ℕ} (F : typevec (n + 1) → Type u) [mvfunctor F] [q : mvqpf F] (α : typevec n) :=
  Quot Mcongr

protected instance cofix.inhabited {n : ℕ} {F : typevec (n + 1) → Type u} [mvfunctor F] [q : mvqpf F] {α : typevec n} [Inhabited (mvpfunctor.A (P F))] [(i : fin2 n) → Inhabited (α i)] : Inhabited (cofix F α) :=
  { default := Quot.mk Mcongr Inhabited.default }

/-- maps every element of the W type to a canonical representative -/
def Mrepr {n : ℕ} {F : typevec (n + 1) → Type u} [mvfunctor F] [q : mvqpf F] {α : typevec n} : mvpfunctor.M (P F) α → mvpfunctor.M (P F) α :=
  corecF (abs ∘ mvpfunctor.M.dest (P F))

/-- the map function for the functor `cofix F` -/
def cofix.map {n : ℕ} {F : typevec (n + 1) → Type u} [mvfunctor F] [q : mvqpf F] {α : typevec n} {β : typevec n} (g : typevec.arrow α β) : cofix F α → cofix F β :=
  Quot.lift (fun (x : mvpfunctor.M (P F) α) => Quot.mk Mcongr (mvfunctor.map g x)) sorry

protected instance cofix.mvfunctor {n : ℕ} {F : typevec (n + 1) → Type u} [mvfunctor F] [q : mvqpf F] : mvfunctor (cofix F) :=
  mvfunctor.mk cofix.map

/-- Corecursor for `cofix F` -/
def cofix.corec {n : ℕ} {F : typevec (n + 1) → Type u} [mvfunctor F] [q : mvqpf F] {α : typevec n} {β : Type u} (g : β → F (α ::: β)) : β → cofix F α :=
  fun (x : β) => Quot.mk Mcongr (corecF g x)

/-- Destructor for `cofix F` -/
def cofix.dest {n : ℕ} {F : typevec (n + 1) → Type u} [mvfunctor F] [q : mvqpf F] {α : typevec n} : cofix F α → F (α ::: cofix F α) :=
  Quot.lift
    (fun (x : mvpfunctor.M (P F) α) => mvfunctor.map (typevec.id ::: Quot.mk Mcongr) (abs (mvpfunctor.M.dest (P F) x)))
    sorry

/-- Abstraction function for `cofix F α` -/
def cofix.abs {n : ℕ} {F : typevec (n + 1) → Type u} [mvfunctor F] [q : mvqpf F] {α : typevec n} : mvpfunctor.M (P F) α → cofix F α :=
  Quot.mk Mcongr

/-- Representation function for `cofix F α` -/
def cofix.repr {n : ℕ} {F : typevec (n + 1) → Type u} [mvfunctor F] [q : mvqpf F] {α : typevec n} : cofix F α → mvpfunctor.M (P F) α :=
  mvpfunctor.M.corec (P F) (repr ∘ cofix.dest)

/-- Corecursor for `cofix F` -/
def cofix.corec'₁ {n : ℕ} {F : typevec (n + 1) → Type u} [mvfunctor F] [q : mvqpf F] {α : typevec n} {β : Type u} (g : {X : Type u} → (β → X) → F (α ::: X)) (x : β) : cofix F α :=
  cofix.corec (fun (x : β) => g id) x

/-- More flexible corecursor for `cofix F`. Allows the return of a fully formed
value instead of making a recursive call -/
def cofix.corec' {n : ℕ} {F : typevec (n + 1) → Type u} [mvfunctor F] [q : mvqpf F] {α : typevec n} {β : Type u} (g : β → F (α ::: (cofix F α ⊕ β))) (x : β) : cofix F α :=
  let f : typevec.arrow (α ::: cofix F α) (α ::: (cofix F α ⊕ β)) := typevec.id ::: sum.inl;
  cofix.corec (sum.elim (mvfunctor.map f ∘ cofix.dest) g) (sum.inr x)

/-- Corecursor for `cofix F`. The shape allows recursive calls to
look like recursive calls. -/
def cofix.corec₁ {n : ℕ} {F : typevec (n + 1) → Type u} [mvfunctor F] [q : mvqpf F] {α : typevec n} {β : Type u} (g : {X : Type u} → (cofix F α → X) → (β → X) → β → F (α ::: X)) (x : β) : cofix F α :=
  cofix.corec' (fun (x : β) => g sum.inl sum.inr x) x

theorem cofix.dest_corec {n : ℕ} {F : typevec (n + 1) → Type u} [mvfunctor F] [q : mvqpf F] {α : typevec n} {β : Type u} (g : β → F (α ::: β)) (x : β) : cofix.dest (cofix.corec g x) = mvfunctor.map (typevec.id ::: cofix.corec g) (g x) := sorry

/-- constructor for `cofix F` -/
def cofix.mk {n : ℕ} {F : typevec (n + 1) → Type u} [mvfunctor F] [q : mvqpf F] {α : typevec n} : F (α ::: cofix F α) → cofix F α :=
  cofix.corec fun (x : F (α ::: cofix F α)) => mvfunctor.map (typevec.id ::: fun (i : cofix F α) => cofix.dest i) x

/-!
## Bisimulation principles for `cofix F`

The following theorems are bisimulation principles. The general idea
is to use a bisimulation relation to prove the equality between
specific values of type `cofix F α`.

A bisimulation relation `R` for values `x y : cofix F α`:

 * holds for `x y`: `R x y`
 * for any values `x y` that satisfy `R`, their root has the same shape
   and their children can be paired in such a way that they satisfy `R`.

-/

/-- Bisimulation principle using `map` and `quot.mk` to match and relate children of two trees. -/
theorem cofix.bisim_rel {n : ℕ} {F : typevec (n + 1) → Type u} [mvfunctor F] [q : mvqpf F] {α : typevec n} (r : cofix F α → cofix F α → Prop) (h : ∀ (x y : cofix F α),
  r x y →
    mvfunctor.map (typevec.id ::: Quot.mk r) (cofix.dest x) = mvfunctor.map (typevec.id ::: Quot.mk r) (cofix.dest y)) (x : cofix F α) (y : cofix F α) : r x y → x = y := sorry

/-- Bisimulation principle using `liftr` to match and relate children of two trees. -/
theorem cofix.bisim {n : ℕ} {F : typevec (n + 1) → Type u} [mvfunctor F] [q : mvqpf F] {α : typevec n} (r : cofix F α → cofix F α → Prop) (h : ∀ (x y : cofix F α), r x y → mvfunctor.liftr (typevec.rel_last α r) (cofix.dest x) (cofix.dest y)) (x : cofix F α) (y : cofix F α) : r x y → x = y := sorry

/-- Bisimulation principle using `liftr'` to match and relate children of two trees. -/
theorem cofix.bisim₂ {n : ℕ} {F : typevec (n + 1) → Type u} [mvfunctor F] [q : mvqpf F] {α : typevec n} (r : cofix F α → cofix F α → Prop) (h : ∀ (x y : cofix F α), r x y → mvfunctor.liftr' (typevec.rel_last' α r) (cofix.dest x) (cofix.dest y)) (x : cofix F α) (y : cofix F α) : r x y → x = y := sorry

/-- Bisimulation principle the values `⟨a,f⟩` of the polynomial functor representing
`cofix F α` as well as an invariant `Q : β → Prop` and a state `β` generating the
left-hand side and right-hand side of the equality through functions `u v : β → cofix F α` -/
theorem cofix.bisim' {n : ℕ} {F : typevec (n + 1) → Type u} [mvfunctor F] [q : mvqpf F] {α : typevec n} {β : Type u_1} (Q : β → Prop) (u : β → cofix F α) (v : β → cofix F α) (h : ∀ (x : β),
  Q x →
    ∃ (a : mvpfunctor.A (P F)),
      ∃ (f' : typevec.arrow (mvpfunctor.B (mvpfunctor.drop (P F)) a) α),
        ∃ (f₀ : pfunctor.B (mvpfunctor.last (P F)) a → cofix F α),
          ∃ (f₁ : pfunctor.B (mvpfunctor.last (P F)) a → cofix F α),
            cofix.dest (u x) = abs (sigma.mk a (mvpfunctor.append_contents (P F) f' f₀)) ∧
              cofix.dest (v x) = abs (sigma.mk a (mvpfunctor.append_contents (P F) f' f₁)) ∧
                ∀ (i : pfunctor.B (mvpfunctor.last (P F)) a), ∃ (x' : β), Q x' ∧ f₀ i = u x' ∧ f₁ i = v x') (x : β) : Q x → u x = v x := sorry

theorem cofix.mk_dest {n : ℕ} {F : typevec (n + 1) → Type u} [mvfunctor F] [q : mvqpf F] {α : typevec n} (x : cofix F α) : cofix.mk (cofix.dest x) = x := sorry

theorem cofix.dest_mk {n : ℕ} {F : typevec (n + 1) → Type u} [mvfunctor F] [q : mvqpf F] {α : typevec n} (x : F (α ::: cofix F α)) : cofix.dest (cofix.mk x) = x := sorry

theorem cofix.ext {n : ℕ} {F : typevec (n + 1) → Type u} [mvfunctor F] [q : mvqpf F] {α : typevec n} (x : cofix F α) (y : cofix F α) (h : cofix.dest x = cofix.dest y) : x = y :=
  eq.mpr (id (Eq._oldrec (Eq.refl (x = y)) (Eq.symm (cofix.mk_dest x))))
    (eq.mpr (id (Eq._oldrec (Eq.refl (cofix.mk (cofix.dest x) = y)) h))
      (eq.mpr (id (Eq._oldrec (Eq.refl (cofix.mk (cofix.dest y) = y)) (cofix.mk_dest y))) (Eq.refl y)))

theorem cofix.ext_mk {n : ℕ} {F : typevec (n + 1) → Type u} [mvfunctor F] [q : mvqpf F] {α : typevec n} (x : F (α ::: cofix F α)) (y : F (α ::: cofix F α)) (h : cofix.mk x = cofix.mk y) : x = y :=
  eq.mpr (id (Eq._oldrec (Eq.refl (x = y)) (Eq.symm (cofix.dest_mk x))))
    (eq.mpr (id (Eq._oldrec (Eq.refl (cofix.dest (cofix.mk x) = y)) h))
      (eq.mpr (id (Eq._oldrec (Eq.refl (cofix.dest (cofix.mk y) = y)) (cofix.dest_mk y))) (Eq.refl y)))

/-!
`liftr_map`, `liftr_map_last` and `liftr_map_last'` are useful for reasoning about
the induction step in bisimulation proofs.
-/

theorem liftr_map {n : ℕ} {α : typevec n} {β : typevec n} {F' : typevec n → Type u} [mvfunctor F'] [is_lawful_mvfunctor F'] (R : typevec.arrow (typevec.prod β β) (typevec.repeat n Prop)) (x : F' α) (f : typevec.arrow α β) (g : typevec.arrow α β) (h : typevec.arrow α (typevec.subtype_ R)) (hh : typevec.comp (typevec.subtype_val R) h = typevec.comp (typevec.prod.map f g) typevec.prod.diag) : mvfunctor.liftr' R (mvfunctor.map f x) (mvfunctor.map g x) := sorry

theorem liftr_map_last {n : ℕ} {F : typevec (n + 1) → Type u} [mvfunctor F] [is_lawful_mvfunctor F] {α : typevec n} {ι : Type u} {ι' : Type u} (R : ι' → ι' → Prop) (x : F (α ::: ι)) (f : ι → ι') (g : ι → ι') (hh : ∀ (x : ι), R (f x) (g x)) : mvfunctor.liftr' (typevec.rel_last' α R) (mvfunctor.map (typevec.id ::: f) x) (mvfunctor.map (typevec.id ::: g) x) := sorry

theorem liftr_map_last' {n : ℕ} {F : typevec (n + 1) → Type u} [mvfunctor F] [is_lawful_mvfunctor F] {α : typevec n} {ι : Type u} (R : ι → ι → Prop) (x : F (α ::: ι)) (f : ι → ι) (hh : ∀ (x : ι), R (f x) x) : mvfunctor.liftr' (typevec.rel_last' α R) (mvfunctor.map (typevec.id ::: f) x) x := sorry

theorem cofix.abs_repr {n : ℕ} {F : typevec (n + 1) → Type u} [mvfunctor F] [q : mvqpf F] {α : typevec n} (x : cofix F α) : Quot.mk Mcongr (cofix.repr x) = x := sorry

/-- tactic for proof by bisimulation -/
theorem corec_roll {n : ℕ} {F : typevec (n + 1) → Type u} [mvfunctor F] [q : mvqpf F] {α : typevec n} {X : Type u} {Y : Type u} {x₀ : X} (f : X → Y) (g : Y → F (α ::: X)) : cofix.corec (g ∘ f) x₀ = cofix.corec (mvfunctor.map (typevec.id ::: f) ∘ g) (f x₀) := sorry

theorem cofix.dest_corec' {n : ℕ} {F : typevec (n + 1) → Type u} [mvfunctor F] [q : mvqpf F] {α : typevec n} {β : Type u} (g : β → F (α ::: (cofix F α ⊕ β))) (x : β) : cofix.dest (cofix.corec' g x) = mvfunctor.map (typevec.id ::: sum.elim id (cofix.corec' g)) (g x) := sorry

theorem cofix.dest_corec₁ {n : ℕ} {F : typevec (n + 1) → Type u} [mvfunctor F] [q : mvqpf F] {α : typevec n} {β : Type u} (g : {X : Type u} → (cofix F α → X) → (β → X) → β → F (α ::: X)) (x : β) (h : ∀ (X Y : Type u) (f : cofix F α → X) (f' : β → X) (k : X → Y),
  g (k ∘ f) (k ∘ f') x = mvfunctor.map (typevec.id ::: k) (g f f' x)) : cofix.dest (cofix.corec₁ g x) = g id (cofix.corec₁ g) x := sorry

protected instance mvqpf_cofix {n : ℕ} {F : typevec (n + 1) → Type u} [mvfunctor F] [q : mvqpf F] : mvqpf (cofix F) :=
  mk (mvpfunctor.Mp (P F)) (fun (α : typevec n) => Quot.mk Mcongr) (fun (α : typevec n) => cofix.repr) sorry sorry


theorem Array.sizeOf_lt_of_mem' [DecidableEq α] [SizeOf α] {as : Array α} (h : a ∈ as) : sizeOf a < sizeOf as := by
  simp [Membership.mem, contains, any, Id.run, BEq.beq, anyM] at h
  let rec aux (j : Nat) : anyM.loop (m := Id) (fun b => decide (a = b)) as as.size (Nat.le_refl ..) j = true → sizeOf a < sizeOf as := by
    unfold anyM.loop
    intro h
    split at h
    · simp [Bind.bind, pure] at h; split at h
      next he => subst a; apply sizeOf_get_lt
      next => have ih := aux (j+1) h; assumption
    · contradiction
  apply aux 0 h
termination_by aux j => as.size - j


import analysis.calculus.bump_function_inner
import analysis.calculus.cont_diff
import to_mathlib.topology.misc
import to_mathlib.topology.algebra.module

noncomputable theory

open set function filter
open_locale topology

namespace real

lemma smooth_transition_proj_I {x : ℝ} :
  smooth_transition (proj_I x) = smooth_transition x :=
begin
  cases le_total (0 : ℝ) x with hx hx,
  cases le_total (1 : ℝ) x with h2x h2x,
  { rw [proj_I_eq_one.mpr h2x, smooth_transition.one_of_one_le h2x, smooth_transition.one], },
  { rw [proj_I_eq_self.mpr ⟨hx, h2x⟩] },
  { rw [proj_I_eq_zero.mpr hx, smooth_transition.zero_of_nonpos hx, smooth_transition.zero], }
end

lemma smooth_transition.continuous_at {x : ℝ} : continuous_at smooth_transition x :=
smooth_transition.continuous.continuous_at

end real

-- section cont_diff_fderiv
/-! In this section we prove that the derivative of a parametric function is smooth, assuming the
  input function is smooth enough. We also do this for `cont_diff_within_at` and `fderiv_within`
  (needed for manifolds)
  We also need some random other lemmas that we didn't bother to put in the right place yet. -/

section fderiv

variables {𝕜 : Type*} [nontrivially_normed_field 𝕜]
variables {E : Type*} [normed_add_comm_group E] [normed_space 𝕜 E]
variables {F : Type*} [normed_add_comm_group F] [normed_space 𝕜 F]
variables {G : Type*} [normed_add_comm_group G] [normed_space 𝕜 G]
variables {X : Type*} [normed_add_comm_group X] [normed_space 𝕜 X]
variables {G' : Type*} [normed_add_comm_group G'] [normed_space 𝕜 G']
variables {f : E → F} {g : E → F} {u : set (E × F)} {s : set E} {x : E} {t : set F} {n m : ℕ∞}

-- the following version is not exactly ported
lemma cont_diff_within_at_fderiv_within {f : E → F → G}
  (hf : cont_diff_within_at 𝕜 n (function.uncurry f) u (x, g x))
  (hg : cont_diff_within_at 𝕜 m g s x)
  (ht : unique_diff_on 𝕜 t)
  (hmn : m + 1 ≤ n) (hx : x ∈ s)
  (hst : s ×ˢ t ⊆ u)
  (hgx : ∀ᶠ x' in 𝓝[s] x, g x' ∈ t)
  (hgt : t ∈ 𝓝[g '' s] g x)
  :
  cont_diff_within_at 𝕜 m (λ x, fderiv_within 𝕜 (f x) t (g x)) s x :=
by { rw [← insert_eq_self.mpr hx] at hst hgx,
  exact (hf.mono hst).fderiv_within'' hg (hgx.mono (λ y hy, ht _ hy)) hmn hgt }

end fderiv

section calculus
open continuous_linear_map
variables {𝕜 : Type*} [nontrivially_normed_field 𝕜]
          {E : Type*} [normed_add_comm_group E] [normed_space 𝕜 E]
          {E₁ : Type*} [normed_add_comm_group E₁] [normed_space 𝕜 E₁]
          {E₂ : Type*} [normed_add_comm_group E₂] [normed_space 𝕜 E₂]
          {E' : Type*} [normed_add_comm_group E'] [normed_space 𝕜 E']
          {F : Type*} [normed_add_comm_group F] [normed_space 𝕜 F]
          {G : Type*} [normed_add_comm_group G] [normed_space 𝕜 G]
          {n : ℕ∞}

lemma cont_diff_at.comp₂ {g : E₁ × E₂ → G} {f₁ : F → E₁} {f₂ : F → E₂} {x : F}
  (hg : cont_diff_at 𝕜 n g (f₁ x, f₂ x)) (hf₁ : cont_diff_at 𝕜 n f₁ x)
  (hf₂ : cont_diff_at 𝕜 n f₂ x) : cont_diff_at 𝕜 n (λ x, g (f₁ x, f₂ x)) x :=
hg.comp x $ hf₁.prod hf₂

lemma cont_diff_at.clm_comp {g : E' → F →L[𝕜] G} {f : E' → E →L[𝕜] F} {n : ℕ∞} {x : E'}
  (hg : cont_diff_at 𝕜 n g x) (hf : cont_diff_at 𝕜 n f x) :
  cont_diff_at 𝕜 n (λ x, g x ∘L f x) x :=
is_bounded_bilinear_map_comp.cont_diff.cont_diff_at.comp₂ hg hf

lemma fderiv_comp {g : F → G} {f : E → F} (x : E)
  (hg : differentiable_at 𝕜 g (f x)) (hf : differentiable_at 𝕜 f x) :
  fderiv 𝕜 (g ∘ f) x = (fderiv 𝕜 g (f x)).comp (fderiv 𝕜 f x) :=
(hg.has_fderiv_at.comp x hf.has_fderiv_at).fderiv

lemma fderiv_prod_left {x₀ : E} {y₀ : F} :
  fderiv 𝕜 (λ x, (x, y₀)) x₀ = continuous_linear_map.inl 𝕜 E F :=
begin
  refine (differentiable_at_id.fderiv_prod (differentiable_at_const y₀)).trans _,
  rw [fderiv_id, fderiv_const],
  refl
end

lemma fderiv_prod_right {x₀ : E} {y₀ : F} :
  fderiv 𝕜 (λ y, (x₀, y)) y₀ = continuous_linear_map.inr 𝕜 E F :=
begin
  refine ((differentiable_at_const x₀).fderiv_prod differentiable_at_id).trans _,
  rw [fderiv_id, fderiv_const],
  refl
end

lemma fderiv_prod_eq_add {f : E × F → G} {p : E × F} (hf : differentiable_at 𝕜 f p) :
  fderiv 𝕜 f p =
  fderiv 𝕜 (λ (z : E × F), f (z.1, p.2)) p + fderiv 𝕜 (λ (z : E × F), f (p.1, z.2)) p :=
begin
  rw [← @prod.mk.eta _ _ p] at hf,
  rw [fderiv_comp p (by apply hf) (differentiable_at_fst.prod $ differentiable_at_const _),
    fderiv_comp p (by apply hf) ((differentiable_at_const _).prod differentiable_at_snd),
    ← continuous_linear_map.comp_add,
    differentiable_at_fst.fderiv_prod (differentiable_at_const _),
    (differentiable_at_const _).fderiv_prod differentiable_at_snd,
    fderiv_fst, fderiv_snd, fderiv_const, fderiv_const],
  dsimp only [pi.zero_apply],
  rw [prod.mk.eta, continuous_linear_map.fst_prod_zero_add_zero_prod_snd,
    continuous_linear_map.comp_id]
end

lemma has_fderiv_at.partial_fst {φ : E → F → G} {φ' : E × F →L[𝕜] G} {e₀ : E} {f₀ : F}
  (h : has_fderiv_at (uncurry φ) φ' (e₀, f₀)) :
  has_fderiv_at (λ e, φ e f₀) (φ'.comp (inl 𝕜 E F)) e₀ :=
h.comp e₀ $ has_fderiv_at_prod_mk_left e₀ f₀

lemma has_fderiv_at.partial_snd {φ : E → F → G} {φ' : E × F →L[𝕜] G} {e₀ : E} {f₀ : F}
  (h : has_fderiv_at (uncurry φ) φ' (e₀, f₀)) :
  has_fderiv_at (λ f, φ e₀ f) (φ'.comp (inr 𝕜 E F)) f₀ :=
h.comp f₀ $ has_fderiv_at_prod_mk_right e₀ f₀

variable (𝕜)

/-- The first partial derivative of a binary function. -/
def partial_fderiv_fst {F : Type*} (φ : E → F → G) : E → F → E →L[𝕜] G :=
λ (e₀ : E) (f₀ : F), fderiv 𝕜 (λ e, φ e f₀) e₀

/-- The second partial derivative of a binary function. -/
def partial_fderiv_snd {E : Type*} (φ : E → F → G) : E → F → F →L[𝕜] G :=
λ (e₀ : E) (f₀ : F), fderiv 𝕜 (λ f, φ e₀ f) f₀

local notation `∂₁` := partial_fderiv_fst
local notation `∂₂` := partial_fderiv_snd

variable {𝕜}

lemma fderiv_partial_fst {φ : E → F → G} {φ' : E × F →L[𝕜] G} {e₀ : E} {f₀ : F}
  (h : has_fderiv_at (uncurry φ) φ' (e₀, f₀)) :
  ∂₁ 𝕜 φ e₀ f₀ = φ'.comp (inl 𝕜 E F) :=
h.partial_fst.fderiv

lemma fderiv_partial_snd {φ : E → F → G} {φ' : E × F →L[𝕜] G} {e₀ : E} {f₀ : F}
  (h : has_fderiv_at (uncurry φ) φ' (e₀, f₀)) :
  ∂₂ 𝕜 φ e₀ f₀ = φ'.comp (inr 𝕜 E F) :=
h.partial_snd.fderiv

lemma differentiable_at.has_fderiv_at_partial_fst {φ : E → F → G} {e₀ : E} {f₀ : F}
  (h : differentiable_at 𝕜 (uncurry φ) (e₀, f₀)) :
  has_fderiv_at (λ e, φ e f₀) (partial_fderiv_fst 𝕜 φ e₀ f₀) e₀ :=
(h.comp e₀ $ differentiable_at_id.prod $ differentiable_at_const f₀).has_fderiv_at

lemma differentiable_at.has_fderiv_at_partial_snd {φ : E → F → G} {e₀ : E} {f₀ : F}
  (h : differentiable_at 𝕜 (uncurry φ) (e₀, f₀)) :
has_fderiv_at (λ f, φ e₀ f) (partial_fderiv_snd 𝕜 φ e₀ f₀) f₀ :=
begin
  rw fderiv_partial_snd h.has_fderiv_at,
  exact h.has_fderiv_at.partial_snd
end

lemma cont_diff.partial_fst {φ : E → F → G} {n : ℕ∞}
  (h : cont_diff 𝕜 n $ uncurry φ) (f₀ : F) : cont_diff 𝕜 n (λ e, φ e f₀) :=
h.comp $ cont_diff_prod_mk_left f₀

lemma cont_diff.partial_snd {φ : E → F → G} {n : ℕ∞}
  (h : cont_diff 𝕜 n $ uncurry φ) (e₀ : E) : cont_diff 𝕜 n (λ f, φ e₀ f) :=
h.comp $ cont_diff_prod_mk_right e₀

/-- Precomposition by a continuous linear map as a continuous linear map between spaces of
continuous linear maps. -/
def continuous_linear_map.comp_rightL (φ : E →L[𝕜] F) : (F →L[𝕜] G) →L[𝕜] (E →L[𝕜] G) :=
(compL 𝕜 E F G).flip φ

/-- Postcomposition by a continuous linear map as a continuous linear map between spaces of
continuous linear maps. -/
def continuous_linear_map.comp_leftL (φ : F →L[𝕜] G) : (E →L[𝕜] F) →L[𝕜] (E →L[𝕜] G) :=
compL 𝕜 E F G φ

lemma differentiable.fderiv_partial_fst {φ : E → F → G} (hF : differentiable 𝕜 (uncurry φ)) :
  ↿(∂₁ 𝕜 φ) = (λ ψ : E × F →L[𝕜] G, ψ.comp (inl 𝕜 E F)) ∘ (fderiv 𝕜 $ uncurry φ) :=
by { ext1 ⟨y, t⟩, exact fderiv_partial_fst (hF ⟨y, t⟩).has_fderiv_at }

lemma differentiable.fderiv_partial_snd {φ : E → F → G} (hF : differentiable 𝕜 (uncurry φ)) :
  ↿(∂₂ 𝕜 φ) = (λ ψ : E × F →L[𝕜] G, ψ.comp (inr 𝕜 E F)) ∘ (fderiv 𝕜 $ uncurry φ) :=
by { ext1 ⟨y, t⟩, exact fderiv_partial_snd (hF ⟨y, t⟩).has_fderiv_at }

/-- The first partial derivative of `φ : 𝕜 → F → G` seen as a function from `𝕜 → F → G`-/
def partial_deriv_fst (φ : 𝕜 → F → G) : 𝕜 → F → G := λ k f, ∂₁ 𝕜 φ k f 1

/-- The second partial derivative of `φ : E → 𝕜 → G` seen as a function from `E → 𝕜 → G`-/
def partial_deriv_snd (φ : E → 𝕜 → G) : E → 𝕜 → G := λ e k, ∂₂ 𝕜 φ e k 1

lemma partial_fderiv_fst_eq_smul_right (φ : 𝕜 → F → G) (k : 𝕜) (f : F) :
  ∂₁ 𝕜 φ k f = smul_right (1 : 𝕜 →L[𝕜] 𝕜) (partial_deriv_fst φ k f) := deriv_fderiv.symm

@[simp]
lemma partial_fderiv_fst_one (φ : 𝕜 → F → G) (k : 𝕜) (f : F) :
  ∂₁ 𝕜 φ k f 1 = partial_deriv_fst φ k f :=
by simp only [partial_fderiv_fst_eq_smul_right, smul_right_apply, one_apply, one_smul]

lemma partial_fderiv_snd_eq_smul_right (φ : E → 𝕜 → G) (e : E) (k : 𝕜) :
  ∂₂ 𝕜 φ e k  = smul_right (1 : 𝕜 →L[𝕜] 𝕜) (partial_deriv_snd φ e k) := deriv_fderiv.symm

lemma partial_fderiv_snd_one (φ : E → 𝕜 → G) (e : E) (k : 𝕜) :
  ∂₂ 𝕜 φ e k 1 = partial_deriv_snd φ e k :=
by simp only [partial_fderiv_snd_eq_smul_right, smul_right_apply, one_apply, one_smul]

@[to_additive]
lemma with_top.le_mul_self {α : Type*} [canonically_ordered_monoid α] (n m : α) :
  (n : with_top α) ≤ (m * n : α) :=
with_top.coe_le_coe.mpr le_mul_self

@[to_additive]
lemma with_top.le_self_mul {α : Type*} [canonically_ordered_monoid α] (n m : α) :
  (n : with_top α) ≤ (n * m : α) :=
with_top.coe_le_coe.mpr le_self_mul

lemma cont_diff.cont_diff_partial_fst {φ : E → F → G} {n : ℕ}
  (hF : cont_diff 𝕜 (n + 1) (uncurry φ)) : cont_diff 𝕜 n ↿(∂₁ 𝕜 φ) :=
cont_diff.fderiv (hF.comp $ cont_diff_snd.prod cont_diff_fst.snd) cont_diff_fst le_rfl

lemma cont_diff.cont_diff_partial_fst_apply {φ : E → F → G} {n : ℕ}
  (hF : cont_diff 𝕜 (n + 1) (uncurry φ)) {x : E} : cont_diff 𝕜 n ↿(λ x' y, ∂₁ 𝕜 φ x' y x) :=
(continuous_linear_map.apply 𝕜 G x).cont_diff.comp hF.cont_diff_partial_fst

lemma cont_diff.continuous_partial_fst {φ : E → F → G} {n : ℕ}
  (h : cont_diff 𝕜 ((n + 1 : ℕ) : ℕ∞) $ uncurry φ) : continuous ↿(∂₁ 𝕜 φ) :=
h.cont_diff_partial_fst.continuous

lemma cont_diff.cont_diff_top_partial_fst {φ : E → F → G} (hF : cont_diff 𝕜 ⊤ (uncurry φ)) :
  cont_diff 𝕜 ⊤ ↿(∂₁ 𝕜 φ) :=
cont_diff_top.mpr (λ n, (cont_diff_top.mp hF (n + 1)).cont_diff_partial_fst)

lemma cont_diff.cont_diff_partial_snd {φ : E → F → G} {n : ℕ}
  (hF : cont_diff 𝕜 (n + 1) (uncurry φ)) : cont_diff 𝕜 n ↿(∂₂ 𝕜 φ) :=
cont_diff.fderiv (hF.comp $ cont_diff_fst.fst.prod cont_diff_snd) cont_diff_snd le_rfl

lemma cont_diff.cont_diff_partial_snd_apply {φ : E → F → G} {n : ℕ}
  (hF : cont_diff 𝕜 (n + 1) (uncurry φ)) {y : F} : cont_diff 𝕜 n ↿(λ x y', ∂₂ 𝕜 φ x y' y) :=
(continuous_linear_map.apply 𝕜 G y).cont_diff.comp hF.cont_diff_partial_snd

lemma cont_diff.continuous_partial_snd {φ : E → F → G} {n : ℕ}
  (h : cont_diff 𝕜 ((n + 1 : ℕ) : ℕ∞) $ uncurry φ) : continuous ↿(∂₂ 𝕜 φ) :=
h.cont_diff_partial_snd.continuous

lemma cont_diff.cont_diff_top_partial_snd {φ : E → F → G} (hF : cont_diff 𝕜 ⊤ (uncurry φ)) :
  cont_diff 𝕜 ⊤ ↿(∂₂ 𝕜 φ) :=
cont_diff_top.mpr (λ n, (cont_diff_top.mp hF (n + 1)).cont_diff_partial_snd)

end calculus

section real_calculus
open continuous_linear_map
variables {E : Type*} [normed_add_comm_group E] [normed_space ℝ E]
          {F : Type*} [normed_add_comm_group F] [normed_space ℝ F]

lemma cont_diff.lipschitz_on_with {s : set E} {f : E → F} {n} (hf : cont_diff ℝ n f) (hn : 1 ≤ n)
  (hs : convex ℝ s) (hs' : is_compact s) : ∃ K, lipschitz_on_with K f s :=
begin
  rcases (bdd_above_iff_exists_ge 0).mp (hs'.image (hf.continuous_fderiv hn).norm).bdd_above with
    ⟨M, M_nonneg, hM⟩,
  simp_rw [ball_image_iff] at hM,
  use ⟨M, M_nonneg⟩,
  exact convex.lipschitz_on_with_of_nnnorm_fderiv_le (λ x x_in, hf.differentiable hn x) hM hs
end

end real_calculus

open filter

/-
The lemma below is ridiculously painful, but Patrick isn't patient enough.
-/
lemma const_mul_one_div_lt {ε : ℝ} (ε_pos : 0 < ε) (C : ℝ) : ∀ᶠ (N : ℝ) in at_top, C*‖1/N‖ < ε :=
begin
  have : tendsto (λ N : ℝ, 1/N) at_top (𝓝 0),
  { rw show (λ N : ℝ, 1/N) = λ N, N^(-(1 : ℤ)), by simp,
    exact tendsto_pow_neg_at_top one_ne_zero },
  rw tendsto_iff_norm_tendsto_zero at this,
  simp only [sub_zero] at this,
  have key := this.const_mul C,
  rw mul_zero at key,
  apply (normed_add_comm_group.tendsto_nhds_zero.mp key ε ε_pos).mono,
  intros N hN,
  cases le_or_lt (C * ‖1 / N‖) 0 with h h,
  { exact h.trans_lt ε_pos },
  { rwa real.norm_of_nonneg h.le at hN },
end