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

A model of ZFC in Lean.
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.data.set.basic
import Mathlib.PostPort

universes u u_1 l u_2 u_3 v

namespace Mathlib

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

namespace arity

/-- Constant `n`-ary function with value `a`. -/
def const {α : Type u} (a : α) (n : ℕ) : arity α n :=
  sorry

protected instance arity.inhabited {α : Type u_1} {n : ℕ} [Inhabited α] : Inhabited (arity α n) :=
  { default := const Inhabited.default n }

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
where
| mk : (α : Type u) → (α → pSet) → pSet

namespace pSet

/-- The underlying type of a pre-set -/
def type : pSet → Type u :=
  sorry

/-- The underlying pre-set family of a pre-set -/
def func (x : pSet) : type x → pSet :=
  sorry

theorem mk_type_func (x : pSet) : mk (type x) (func x) = x :=
  pSet.cases_on x
    fun (x_α : Type u_1) (x_A : x_α → pSet) =>
      idRhs (mk (type (mk x_α x_A)) (func (mk x_α x_A)) = mk (type (mk x_α x_A)) (func (mk x_α 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 : pSet) (y : pSet) :=
  pSet.rec (fun (α : Type u_1) (z : α → pSet) (m : α → pSet → Prop) (_x : pSet) => sorry) x y

theorem equiv.refl (x : pSet) : equiv x x :=
  pSet.rec_on x
    fun (α : Type u_1) (A : α → pSet) (IH : ∀ (ᾰ : α), equiv (A ᾰ) (A ᾰ)) =>
      { left := fun (a : α) => Exists.intro a (IH a), right := fun (a : α) => Exists.intro a (IH a) }

theorem equiv.euc {x : pSet} {y : pSet} {z : pSet} : equiv x y → equiv z y → equiv x z := sorry

theorem equiv.symm {x : pSet} {y : pSet} : equiv x y → equiv y x :=
  equiv.euc (equiv.refl y)

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

protected instance setoid : setoid pSet :=
  setoid.mk equiv sorry

protected def subset : pSet → pSet → Prop :=
  sorry

protected instance has_subset : has_subset pSet :=
  has_subset.mk pSet.subset

theorem equiv.ext (x : pSet) (y : pSet) : equiv x y ↔ x ⊆ y ∧ y ⊆ x := sorry

theorem subset.congr_left {x : pSet} {y : pSet} {z : pSet} : equiv x y → (x ⊆ z ↔ y ⊆ z) := sorry

theorem subset.congr_right {x : pSet} {y : pSet} {z : pSet} : equiv x y → (z ⊆ x ↔ z ⊆ y) := sorry

/-- `x ∈ y` as pre-sets if `x` is extensionally equivalent to a member
  of the family `y`. -/
def mem : pSet → pSet → Prop :=
  sorry

protected instance has_mem : has_mem pSet pSet :=
  has_mem.mk mem

theorem mem.mk {α : Type u} (A : α → pSet) (a : α) : A a ∈ mk α A :=
  (fun (this : mem (A a) (mk α A)) => this) (Exists.intro a (equiv.refl (A a)))

theorem mem.ext {x : pSet} {y : pSet} : (∀ (w : pSet), w ∈ x ↔ w ∈ y) → equiv x y := sorry

theorem mem.congr_right {x : pSet} {y : pSet} : equiv x y → ∀ {w : pSet}, w ∈ x ↔ w ∈ y := sorry

theorem equiv_iff_mem {x : pSet} {y : pSet} : equiv x y ↔ ∀ {w : pSet}, w ∈ x ↔ w ∈ y := sorry

theorem mem.congr_left {x : pSet} {y : pSet} : equiv x y → ∀ {w : pSet}, x ∈ w ↔ y ∈ w := sorry

/-- Convert a pre-set to a `set` of pre-sets. -/
def to_set (u : pSet) : set pSet :=
  set_of fun (x : pSet) => x ∈ u

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

protected instance set.has_coe : has_coe pSet (set pSet) :=
  has_coe.mk to_set

/-- The empty pre-set -/
protected def empty : pSet :=
  mk (ulift empty) fun (e : ulift empty) => sorry

protected instance has_emptyc : has_emptyc pSet :=
  has_emptyc.mk pSet.empty

protected instance inhabited : Inhabited pSet :=
  { default := ∅ }

theorem mem_empty (x : pSet) : ¬x ∈ ∅ := sorry

/-- Insert an element into a pre-set -/
protected def insert : pSet → pSet → pSet :=
  sorry

protected instance has_insert : has_insert pSet pSet :=
  has_insert.mk pSet.insert

protected instance has_singleton : has_singleton pSet pSet :=
  has_singleton.mk fun (s : pSet) => insert s ∅

protected instance is_lawful_singleton : is_lawful_singleton pSet pSet :=
  is_lawful_singleton.mk fun (_x : pSet) => rfl

/-- The n-th von Neumann ordinal -/
def of_nat : ℕ → pSet :=
  sorry

/-- The von Neumann ordinal ω -/
def omega : pSet :=
  mk (ulift ℕ) fun (n : ulift ℕ) => of_nat (ulift.down n)

/-- The separation operation `{x ∈ a | p x}` -/
protected def sep (p : set pSet) : pSet → pSet :=
  sorry

protected instance has_sep : has_sep pSet pSet :=
  has_sep.mk pSet.sep

/-- The powerset operator -/
def powerset : pSet → pSet :=
  sorry

theorem mem_powerset {x : pSet} {y : pSet} : y ∈ powerset x ↔ y ⊆ x := sorry

/-- The set union operator -/
def Union : pSet → pSet :=
  sorry

theorem mem_Union {x : pSet} {y : pSet} : y ∈ Union x ↔ ∃ (z : pSet), ∃ (_x : z ∈ x), y ∈ z := sorry

/-- The image of a function -/
def image (f : pSet → pSet) : pSet → pSet :=
  sorry

theorem mem_image {f : pSet → pSet} (H : ∀ {x y : pSet}, equiv x y → equiv (f x) (f y)) {x : pSet} {y : pSet} : y ∈ image f x ↔ ∃ (z : pSet), ∃ (H : z ∈ x), equiv y (f z) := sorry

/-- Universe lift operation -/
protected def lift : pSet → pSet :=
  sorry

/-- Embedding of one universe in another -/
def embed : pSet :=
  mk (ulift pSet) fun (_x : ulift pSet) => sorry

theorem lift_mem_embed (x : pSet) : pSet.lift x ∈ embed :=
  Exists.intro (ulift.up x) (equiv.refl (pSet.lift x))

/-- 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 n → arity pSet n → Prop :=
  sorry

theorem arity.equiv_const {a : pSet} (n : ℕ) : arity.equiv (arity.const a n) (arity.const a n) := sorry

/-- `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 : ℕ) :=
  Subtype fun (x : arity pSet n) => arity.equiv x x

protected instance resp.inhabited {n : ℕ} : Inhabited (resp n) :=
  { default := { val := arity.const Inhabited.default n, property := sorry } }

def resp.f {n : ℕ} (f : resp (n + 1)) (x : pSet) : resp n :=
  { val := subtype.val f x, property := sorry }

def resp.equiv {n : ℕ} (a : resp n) (b : resp n) :=
  arity.equiv (subtype.val a) (subtype.val b)

theorem resp.refl {n : ℕ} (a : resp n) : resp.equiv a a :=
  subtype.property a

theorem resp.euc {n : ℕ} {a : resp n} {b : resp n} {c : resp n} : resp.equiv a b → resp.equiv c b → resp.equiv a c := sorry

protected instance resp.setoid {n : ℕ} : setoid (resp n) :=
  setoid.mk resp.equiv sorry

end pSet

/-- The ZFC universe of sets consists of the type of pre-sets,
  quotiented by extensional equivalence. -/
def Set :=
  quotient pSet.setoid

namespace pSet

namespace resp

def eval_aux {n : ℕ} : Subtype fun (f : resp n → arity Set n) => ∀ (a b : resp n), equiv a b → f a = f b :=
  sorry

/-- An equivalence-respecting function yields an n-ary Set function. -/
def eval (n : ℕ) : resp n → arity Set n :=
  subtype.val eval_aux

theorem eval_val {n : ℕ} {f : resp (n + 1)} {x : pSet} : eval (n + 1) f (quotient.mk x) = eval n (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 n → Type (u + 1)
where
| mk : (f : resp n) → definable n (resp.eval n f)

def definable.eq_mk {n : ℕ} (f : resp n) {s : arity Set n} (H : resp.eval n f = s) : definable n s :=
  sorry

def definable.resp {n : ℕ} (s : arity Set n) [definable n s] : resp n :=
  sorry

theorem definable.eq {n : ℕ} (s : arity Set n) [H : definable n s] : resp.eval n (definable.resp s) = s := sorry

end pSet

namespace classical

def all_definable {n : ℕ} (F : arity Set n) : pSet.definable n F :=
  sorry

end classical

namespace Set

def mk : pSet → Set :=
  quotient.mk

@[simp] theorem mk_eq (x : pSet) : quotient.mk x = mk x :=
  rfl

@[simp] theorem eval_mk {n : ℕ} {f : pSet.resp (n + 1)} {x : pSet} : pSet.resp.eval (n + 1) f (mk x) = pSet.resp.eval n (pSet.resp.f f x) :=
  rfl

def mem : Set → Set → Prop :=
  quotient.lift₂ pSet.mem sorry

protected instance has_mem : has_mem Set Set :=
  has_mem.mk mem

/-- Convert a ZFC set into a `set` of sets -/
def to_set (u : Set) : set Set :=
  set_of fun (x : Set) => x ∈ u

protected def subset (x : Set) (y : Set) :=
  ∀ {z : Set}, z ∈ x → z ∈ y

protected instance has_subset : has_subset Set :=
  has_subset.mk Set.subset

theorem subset_def {x : Set} {y : Set} : x ⊆ y ↔ ∀ {z : Set}, z ∈ x → z ∈ y :=
  iff.rfl

theorem subset_iff (x : pSet) (y : pSet) : mk x ⊆ mk y ↔ x ⊆ y := sorry

theorem ext {x : Set} {y : Set} : (∀ (z : Set), z ∈ x ↔ z ∈ y) → x = y :=
  quotient.induction_on₂ x y
    fun (u v : pSet) (h : ∀ (z : Set), z ∈ quotient.mk u ↔ z ∈ quotient.mk v) =>
      quotient.sound (pSet.mem.ext fun (w : pSet) => h (quotient.mk w))

theorem ext_iff {x : Set} {y : Set} : (∀ (z : Set), z ∈ x ↔ z ∈ y) ↔ x = y := sorry

/-- The empty set -/
def empty : Set :=
  mk ∅

protected instance has_emptyc : has_emptyc Set :=
  has_emptyc.mk empty

protected instance inhabited : Inhabited Set :=
  { default := ∅ }

@[simp] theorem mem_empty (x : Set) : ¬x ∈ ∅ :=
  quotient.induction_on x pSet.mem_empty

theorem eq_empty (x : Set) : x = ∅ ↔ ∀ (y : Set), ¬y ∈ x := sorry

/-- `insert x y` is the set `{x} ∪ y` -/
protected def insert : Set → Set → Set :=
  pSet.resp.eval (bit0 1) { val := pSet.insert, property := sorry }

protected instance has_insert : has_insert Set Set :=
  has_insert.mk Set.insert

protected instance has_singleton : has_singleton Set Set :=
  has_singleton.mk fun (x : Set) => insert x ∅

protected instance is_lawful_singleton : is_lawful_singleton Set Set :=
  is_lawful_singleton.mk fun (x : Set) => rfl

@[simp] theorem mem_insert {x : Set} {y : Set} {z : Set} : x ∈ insert y z ↔ x = y ∨ x ∈ z := sorry

@[simp] theorem mem_singleton {x : Set} {y : Set} : x ∈ singleton y ↔ x = y :=
  iff.trans mem_insert
    { mp := fun (o : x = y ∨ x ∈ ∅) => Or._oldrec (fun (h : x = y) => h) (fun (n : x ∈ ∅) => absurd n (mem_empty x)) o,
      mpr := Or.inl }

@[simp] theorem mem_pair {x : Set} {y : Set} {z : Set} : x ∈ insert y (singleton z) ↔ x = y ∨ x = z :=
  iff.trans mem_insert (or_congr iff.rfl mem_singleton)

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

@[simp] theorem omega_zero : ∅ ∈ omega :=
  (fun (this : pSet.mem ∅ pSet.omega) => this) (Exists.intro (ulift.up 0) (pSet.equiv.refl ∅))

@[simp] theorem omega_succ {n : Set} : n ∈ omega → insert n n ∈ omega := sorry

/-- `{x ∈ a | p x}` is the set of elements in `a` satisfying `p` -/
protected def sep (p : Set → Prop) : Set → Set :=
  pSet.resp.eval 1 { val := pSet.sep fun (y : pSet) => p (quotient.mk y), property := sorry }

protected instance has_sep : has_sep Set Set :=
  has_sep.mk Set.sep

@[simp] theorem mem_sep {p : Set → Prop} {x : Set} {y : Set} : y ∈ has_sep.sep (fun (y : Set) => p y) x ↔ y ∈ x ∧ p y := sorry

/-- The powerset operation, the collection of subsets of a set -/
def powerset : Set → Set :=
  pSet.resp.eval 1 { val := pSet.powerset, property := sorry }

@[simp] theorem mem_powerset {x : Set} {y : Set} : y ∈ powerset x ↔ y ⊆ x := sorry

theorem Union_lem {α : Type u} {β : Type u} (A : α → pSet) (B : β → pSet) (αβ : ∀ (a : α), ∃ (b : β), pSet.equiv (A a) (B b)) (a : pSet.type (pSet.Union (pSet.mk α A))) : ∃ (b : pSet.type (pSet.Union (pSet.mk β B))),
  pSet.equiv (pSet.func (pSet.Union (pSet.mk α A)) a) (pSet.func (pSet.Union (pSet.mk β B)) b) := sorry

/-- The union operator, the collection of elements of elements of a set -/
def Union : Set → Set :=
  pSet.resp.eval 1 { val := pSet.Union, property := sorry }

notation:1024 "⋃" => Mathlib.Set.Union

@[simp] theorem mem_Union {x : Set} {y : Set} : y ∈ ⋃ ↔ ∃ (z : Set), ∃ (H : z ∈ x), y ∈ z := sorry

@[simp] theorem Union_singleton {x : Set} : ⋃ = x := sorry

theorem singleton_inj {x : Set} {y : Set} (H : singleton x = singleton y) : x = y :=
  let this : ⋃ = ⋃ := congr_arg ⋃ H;
  eq.mp (Eq._oldrec (Eq.refl (x = ⋃)) Union_singleton) (eq.mp (Eq._oldrec (Eq.refl (⋃ = ⋃)) Union_singleton) this)

/-- The binary union operation -/
protected def union (x : Set) (y : Set) : Set :=
  ⋃

/-- The binary intersection operation -/
protected def inter (x : Set) (y : Set) : Set :=
  has_sep.sep (fun (z : Set) => z ∈ y) x

/-- The set difference operation -/
protected def diff (x : Set) (y : Set) : Set :=
  has_sep.sep (fun (z : Set) => ¬z ∈ y) x

protected instance has_union : has_union Set :=
  has_union.mk Set.union

protected instance has_inter : has_inter Set :=
  has_inter.mk Set.inter

protected instance has_sdiff : has_sdiff Set :=
  has_sdiff.mk Set.diff

@[simp] theorem mem_union {x : Set} {y : Set} {z : Set} : z ∈ x ∪ y ↔ z ∈ x ∨ z ∈ y := sorry

@[simp] theorem mem_inter {x : Set} {y : Set} {z : Set} : z ∈ x ∩ y ↔ z ∈ x ∧ z ∈ y :=
  mem_sep

@[simp] theorem mem_diff {x : Set} {y : Set} {z : Set} : z ∈ x \ y ↔ z ∈ x ∧ ¬z ∈ y :=
  mem_sep

theorem induction_on {p : Set → Prop} (x : Set) (h : ∀ (x : Set), (∀ (y : Set), y ∈ x → p y) → p x) : p x := sorry

theorem regularity (x : Set) (h : x ≠ ∅) : ∃ (y : Set), ∃ (H : y ∈ x), x ∩ y = ∅ := sorry

/-- The image of a (definable) set function -/
def image (f : Set → Set) [H : pSet.definable 1 f] : Set → Set :=
  let r : pSet.resp 1 := pSet.definable.resp f;
  pSet.resp.eval 1 { val := pSet.image (subtype.val r), property := sorry }

theorem image.mk (f : Set → Set) [H : pSet.definable 1 f] (x : Set) {y : Set} (h : y ∈ x) : f y ∈ image f x := sorry

@[simp] theorem mem_image {f : Set → Set} [H : pSet.definable 1 f] {x : Set} {y : Set} : y ∈ image f x ↔ ∃ (z : Set), ∃ (H : z ∈ x), f z = y := sorry

/-- Kuratowski ordered pair -/
def pair (x : Set) (y : Set) : Set :=
  insert (singleton x) (singleton (insert x (singleton y)))

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

@[simp] theorem mem_pair_sep {p : Set → Set → Prop} {x : Set} {y : Set} {z : Set} : z ∈ pair_sep p x y ↔ ∃ (a : Set), ∃ (H : a ∈ x), ∃ (b : Set), ∃ (H : b ∈ y), z = pair a b ∧ p a b := sorry

theorem pair_inj {x : Set} {y : Set} {x' : Set} {y' : Set} (H : pair x y = pair x' y') : x = x' ∧ y = y' := sorry

/-- The cartesian product, `{(a, b) | a ∈ x, b ∈ y}` -/
def prod : Set → Set → Set :=
  pair_sep fun (a b : Set) => True

@[simp] theorem mem_prod {x : Set} {y : Set} {z : Set} : z ∈ prod x y ↔ ∃ (a : Set), ∃ (H : a ∈ x), ∃ (b : Set), ∃ (H : b ∈ y), z = pair a b := sorry

@[simp] theorem pair_mem_prod {x : Set} {y : Set} {a : Set} {b : Set} : pair a b ∈ prod x y ↔ a ∈ x ∧ b ∈ y := sorry

/-- `is_func x y f` is the assertion `f : x → y` where `f` is a ZFC function
  (a set of ordered pairs) -/
def is_func (x : Set) (y : Set) (f : Set) :=
  f ⊆ prod x y ∧ ∀ (z : Set), z ∈ x → exists_unique fun (w : Set) => pair z w ∈ f

/-- `funs x y` is `y ^ x`, the set of all set functions `x → y` -/
def funs (x : Set) (y : Set) : Set :=
  has_sep.sep (fun (f : Set) => is_func x y f) (powerset (prod x y))

@[simp] theorem mem_funs {x : Set} {y : Set} {f : Set} : f ∈ funs x y ↔ is_func x y f := sorry

-- TODO(Mario): Prove this computably

protected instance map_definable_aux (f : Set → Set) [H : pSet.definable 1 f] : pSet.definable 1 fun (y : Set) => pair y (f y) :=
  classical.all_definable fun (y : Set) => pair y (f y)

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

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

theorem map_unique {f : Set → Set} [H : pSet.definable 1 f] {x : Set} {z : Set} (zx : z ∈ x) : exists_unique fun (w : Set) => pair z w ∈ map f x := sorry

@[simp] theorem map_is_func {f : Set → Set} [H : pSet.definable 1 f] {x : Set} {y : Set} : is_func x y (map f x) ↔ ∀ (z : Set), z ∈ x → f z ∈ y := sorry

end Set

def Class :=
  set Set

namespace Class

protected instance has_subset : has_subset Class :=
  has_subset.mk set.subset

protected instance has_sep : has_sep Set Class :=
  has_sep.mk set.sep

protected instance has_emptyc : has_emptyc Class :=
  has_emptyc.mk fun (a : Set) => False

protected instance inhabited : Inhabited Class :=
  { default := ∅ }

protected instance has_insert : has_insert Set Class :=
  has_insert.mk set.insert

protected instance has_union : has_union Class :=
  has_union.mk set.union

protected instance has_inter : has_inter Class :=
  has_inter.mk set.inter

protected instance has_neg : Neg Class :=
  { neg := set.compl }

protected instance has_sdiff : has_sdiff Class :=
  has_sdiff.mk set.diff

/-- Coerce a set into a class -/
def of_Set (x : Set) : Class :=
  set_of fun (y : Set) => y ∈ x

protected instance has_coe : has_coe Set Class :=
  has_coe.mk of_Set

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

/-- Assert that `A` is a set satisfying `p` -/
def to_Set (p : Set → Prop) (A : Class) :=
  ∃ (x : Set), ↑x = A ∧ p x

/-- `A ∈ B` if `A` is a set which is a member of `B` -/
protected def mem (A : Class) (B : Class) :=
  to_Set B A

protected instance has_mem : has_mem Class Class :=
  has_mem.mk Class.mem

theorem mem_univ {A : Class} : A ∈ univ ↔ ∃ (x : Set), ↑x = A :=
  exists_congr fun (x : Set) => and_true (↑x = A)

/-- Convert a conglomerate (a collection of classes) into a class -/
def Cong_to_Class (x : set Class) : Class :=
  set_of fun (y : Set) => ↑y ∈ x

/-- Convert a class into a conglomerate (a collection of classes) -/
def Class_to_Cong (x : Class) : set Class :=
  set_of fun (y : Class) => y ∈ x

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

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

notation:1024 "⋃" => Mathlib.Class.Union

theorem of_Set.inj {x : Set} {y : Set} (h : ↑x = ↑y) : x = y := sorry

@[simp] theorem to_Set_of_Set (p : Set → Prop) (x : Set) : to_Set p ↑x ↔ p x := sorry

@[simp] theorem mem_hom_left (x : Set) (A : Class) : ↑x ∈ A ↔ A x :=
  to_Set_of_Set (fun (x : Set) => A x) x

@[simp] theorem mem_hom_right (x : Set) (y : Set) : coe y x ↔ x ∈ y :=
  iff.rfl

@[simp] theorem subset_hom (x : Set) (y : Set) : ↑x ⊆ ↑y ↔ x ⊆ y :=
  iff.rfl

@[simp] theorem sep_hom (p : Set → Prop) (x : Set) : ↑(has_sep.sep (fun (y : Set) => p y) x) = has_sep.sep (fun (y : Set) => p y) ↑x :=
  set.ext fun (y : Set) => Set.mem_sep

@[simp] theorem empty_hom : ↑∅ = ∅ :=
  set.ext
    fun (y : Set) => (fun (this : y ∈ ↑∅ ↔ False) => this) (eq.mpr (id (propext (iff_false (y ∈ ↑∅)))) (Set.mem_empty y))

@[simp] theorem insert_hom (x : Set) (y : Set) : insert x ↑y = ↑(insert x y) :=
  set.ext fun (z : Set) => iff.symm Set.mem_insert

@[simp] theorem union_hom (x : Set) (y : Set) : ↑x ∪ ↑y = ↑(x ∪ y) :=
  set.ext fun (z : Set) => iff.symm Set.mem_union

@[simp] theorem inter_hom (x : Set) (y : Set) : ↑x ∩ ↑y = ↑(x ∩ y) :=
  set.ext fun (z : Set) => iff.symm Set.mem_inter

@[simp] theorem diff_hom (x : Set) (y : Set) : ↑x \ ↑y = ↑(x \ y) :=
  set.ext fun (z : Set) => iff.symm Set.mem_diff

@[simp] theorem powerset_hom (x : Set) : powerset ↑x = ↑(Set.powerset x) :=
  set.ext fun (z : Set) => iff.symm Set.mem_powerset

@[simp] theorem Union_hom (x : Set) : ⋃ = ↑⋃ := sorry

/-- The definite description operator, which is {x} if `{a | p a} = {x}`
  and ∅ otherwise -/
def iota (p : Set → Prop) : Class :=
  ⋃

theorem iota_val (p : Set → Prop) (x : Set) (H : ∀ (y : Set), p y ↔ y = x) : iota p = ↑x := sorry

/-- 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 `(Set → Prop) → Set` function. -/
theorem iota_ex (p : Set → Prop) : iota p ∈ univ := sorry

/-- Function value -/
def fval (F : Class) (A : Class) : Class :=
  iota fun (y : Set) => to_Set (fun (x : Set) => F (Set.pair x y)) A

infixl:100 "′" => Mathlib.Class.fval

theorem fval_ex (F : Class) (A : Class) : F′A ∈ univ :=
  iota_ex fun (y : Set) => to_Set (fun (x : Set) => F (Set.pair x y)) A

end Class

namespace Set

@[simp] theorem map_fval {f : Set → Set} [H : pSet.definable 1 f] {x : Set} {y : Set} (h : y ∈ x) : ↑(map f x)′↑y = ↑(f y) := sorry

/-- A choice function on the set of nonempty sets `x` -/
def choice (x : Set) : Set :=
  map (fun (y : Set) => classical.epsilon fun (z : Set) => z ∈ y) x

theorem choice_mem_aux (x : Set) (h : ¬∅ ∈ x) (y : Set) (yx : y ∈ x) : (classical.epsilon fun (z : Set) => z ∈ y) ∈ y := sorry

theorem choice_is_func (x : Set) (h : ¬∅ ∈ x) : is_func x ⋃ (choice x) := sorry

theorem choice_mem (x : Set) (h : ¬∅ ∈ x) (y : Set) (yx : y ∈ x) : ↑(choice x)′↑y ∈ ↑y := sorry


/-
Copyright (c) 2016 Microsoft Corporation. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Leonardo de Moura

Converter monad for building simplifiers.

! This file was ported from Lean 3 source module init.meta.converter.conv
! leanprover-community/mathlib commit e83eca1fc5eda5ec3e0926a6913e02d9a574bf9e
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
prelude
import Leanbin.Init.Meta.Tactic
import Leanbin.Init.Meta.SimpTactic
import Leanbin.Init.Meta.Interactive
import Leanbin.Init.Meta.CongrLemma
import Leanbin.Init.Meta.MatchTactic

open Tactic

def Tactic.IdTag.conv : Unit :=
  ()
#align tactic.id_tag.conv Tactic.IdTag.conv

universe u

/--
`conv α` is a tactic for discharging goals of the form `lhs ~ rhs` for some relation `~` (usually equality) and fixed lhs, rhs.
Known in the literature as a __conversion__ tactic.
So for example, if one had the lemma `p : x = y`, then the conversion for `p` would be one that solves `p`.
-/
unsafe def conv (α : Type u) :=
  tactic α
#align conv conv

unsafe instance : Monad conv := by dsimp only [conv] <;> infer_instance

unsafe instance : MonadFail conv := by dsimp only [conv] <;> infer_instance

unsafe instance : Alternative conv := by dsimp only [conv] <;> infer_instance

namespace Conv

/--
Applies the conversion `c`. Returns `(rhs,p)` where `p : r lhs rhs`. Throws away the return value of `c`.-/
unsafe def convert (c : conv Unit) (lhs : expr) (rel : Name := `eq) : tactic (expr × expr) := do
  let lhs_type ← infer_type lhs
  let rhs ← mk_meta_var lhs_type
  let new_target ← mk_app Rel [lhs, rhs]
  let new_g ← mk_meta_var new_target
  let gs ← get_goals
  set_goals [new_g]
  c
  try <| any_goals reflexivity
  let n ← num_goals
  when (n ≠ 0) (fail "convert tactic failed, there are unsolved goals")
  set_goals gs
  let rhs ← instantiate_mvars rhs
  let new_g ← instantiate_mvars new_g
  return (rhs, new_g)
#align conv.convert conv.convert

unsafe def lhs : conv expr := do
  let (_, lhs, rhs) ← target_lhs_rhs
  return lhs
#align conv.lhs conv.lhs

unsafe def rhs : conv expr := do
  let (_, lhs, rhs) ← target_lhs_rhs
  return rhs
#align conv.rhs conv.rhs

/-- `⊢ lhs = rhs` ~~> `⊢ lhs' = rhs` using `h : lhs = lhs'`. -/
unsafe def update_lhs (new_lhs : expr) (h : expr) : conv Unit := do
  transitivity
  rhs >>= unify new_lhs
  exact h
  let t ← target >>= instantiate_mvars
  change t
#align conv.update_lhs conv.update_lhs

/-- Change `lhs` to something definitionally equal to it. -/
unsafe def change (new_lhs : expr) : conv Unit := do
  let (r, lhs, rhs) ← target_lhs_rhs
  let new_target ← mk_app r [new_lhs, rhs]
  tactic.change new_target
#align conv.change conv.change

/-- Use reflexivity to prove. -/
unsafe def skip : conv Unit :=
  reflexivity
#align conv.skip conv.skip

/-- Put LHS in WHNF. -/
unsafe def whnf : conv Unit :=
  lhs >>= tactic.whnf >>= change
#align conv.whnf conv.whnf

/-- dsimp the LHS. -/
unsafe def dsimp (s : Option simp_lemmas := none) (u : List Name := []) (cfg : DsimpConfig := { }) :
    conv Unit := do
  let s ←
    match s with
      | some s => return s
      | none => simp_lemmas.mk_default
  let l ← lhs
  s u l cfg >>= change
#align conv.dsimp conv.dsimp

private unsafe def congr_aux : List CongrArgKind → List expr → tactic (List expr × List expr)
  | [], [] => return ([], [])
  | k :: ks, a :: as => do
    let (gs, largs) ← congr_aux ks as
    match k with
      |-- parameter for the congruence lemma
        CongrArgKind.fixed =>
        return <| (gs, a :: largs)
      |-- parameter which is a subsingleton
        CongrArgKind.fixed_no_param =>
        return <| (gs, largs)
      | CongrArgKind.eq => do
        let a_type ← infer_type a
        let rhs ← mk_meta_var a_type
        let g_type ← mk_app `eq [a, rhs]
        let g ← mk_meta_var g_type
        -- proof that `a = rhs`
            return
            (g :: gs, a :: rhs :: g :: largs)
      | CongrArgKind.cast => return <| (gs, a :: largs)
      | _ => fail "congr tactic failed, unsupported congruence lemma"
  | ks, as => fail "congr tactic failed, unsupported congruence lemma"
#align conv.congr_aux conv.congr_aux

/--
Take the target equality `f x y = X` and try to apply the congruence lemma for `f` to it (namely `x = x' → y = y' → f x y = f x' y'`). -/
unsafe def congr : conv Unit := do
  let (r, lhs, rhs) ← target_lhs_rhs
  guard (r = `eq)
  let fn := lhs.get_app_fn
  let args := lhs.get_app_args
  let cgr_lemma ← mk_congr_lemma_simp fn (some args.length)
  let g :: gs ← get_goals
  let (new_gs, lemma_args) ← congr_aux cgr_lemma.arg_kinds args
  let g_val := cgr_lemma.proof.mk_app lemma_args
  unify g g_val
  set_goals <| new_gs ++ gs
  return ()
#align conv.congr conv.congr

/-- Create a conversion from the function extensionality tactic.-/
unsafe def funext : conv Unit :=
  iterate' do
    let (r, lhs, rhs) ← target_lhs_rhs
    guard (r = `eq)
    let expr.lam n _ _ _ ← return lhs
    tactic.applyc `funext
    intro n
    return ()
#align conv.funext conv.funext

end Conv


/-
Copyright (c) 2016 Microsoft Corporation. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Leonardo de Moura
-/
prelude
import init.data.repr init.data.prod init.data.sum.basic

universes u v

inductive ordering
| lt | eq | gt

instance : has_repr ordering :=
⟨(λ s, match s with | ordering.lt := "lt" | ordering.eq := "eq" | ordering.gt := "gt" end)⟩

namespace ordering
def swap : ordering → ordering
| lt := gt
| eq := eq
| gt := lt

@[inline] def or_else : ordering → ordering → ordering
| lt _ := lt
| eq o := o
| gt _ := gt

theorem swap_swap : ∀ (o : ordering), o.swap.swap = o
| lt := rfl
| eq := rfl
| gt := rfl
end ordering

def cmp_using {α : Type u} (lt : α → α → Prop) [decidable_rel lt] (a b : α) : ordering :=
if lt a b      then ordering.lt
else if lt b a then ordering.gt
else                ordering.eq

def cmp {α : Type u} [has_lt α] [decidable_rel ((<) : α → α → Prop)] (a b : α) : ordering :=
cmp_using (<) a b

instance : decidable_eq ordering :=
λ a b,
  match a with
  | ordering.lt :=
    match b with
    | ordering.lt := is_true rfl
    | ordering.eq := is_false (λ h, ordering.no_confusion h)
    | ordering.gt := is_false (λ h, ordering.no_confusion h)
    end
  | ordering.eq :=
    match b with
    | ordering.lt := is_false (λ h, ordering.no_confusion h)
    | ordering.eq := is_true rfl
    | ordering.gt := is_false (λ h, ordering.no_confusion h)
    end
  | ordering.gt :=
    match b with
    | ordering.lt := is_false (λ h, ordering.no_confusion h)
    | ordering.eq := is_false (λ h, ordering.no_confusion h)
    | ordering.gt := is_true rfl
    end
  end


/-
Copyright (c) 2019 Microsoft Corporation. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Leonardo de Moura
-/
import Lean.Meta.WHNF
import Lean.Meta.DiscrTreeTypes

namespace Lean.Meta.DiscrTree
/-!
  (Imperfect) discrimination trees.
  We use a hybrid representation.
  - A `PersistentHashMap` for the root node which usually contains many children.
  - A sorted array of key/node pairs for inner nodes.

  The edges are labeled by keys:
  - Constant names (and arity). Universe levels are ignored.
  - Free variables (and arity). Thus, an entry in the discrimination tree
    may reference hypotheses from the local context.
  - Literals
  - Star/Wildcard. We use them to represent metavariables and terms
    we want to ignore. We ignore implicit arguments and proofs.
  - Other. We use to represent other kinds of terms (e.g., nested lambda, forall, sort, etc).

  We reduce terms using `TransparencyMode.reducible`. Thus, all reducible
  definitions in an expression `e` are unfolded before we insert it into the
  discrimination tree.

  Recall that projections from classes are **NOT** reducible.
  For example, the expressions `Add.add α (ringAdd ?α ?s) ?x ?x`
  and `Add.add Nat Nat.hasAdd a b` generates paths with the following keys
  respctively
  ```
  ⟨Add.add, 4⟩, *, *, *, *
  ⟨Add.add, 4⟩, *, *, ⟨a,0⟩, ⟨b,0⟩
  ```

  That is, we don't reduce `Add.add Nat inst a b` into `Nat.add a b`.
  We say the `Add.add` applications are the de-facto canonical forms in
  the metaprogramming framework.
  Moreover, it is the metaprogrammer's responsibility to re-pack applications such as
  `Nat.add a b` into `Add.add Nat inst a b`.

  Remark: we store the arity in the keys
  1- To be able to implement the "skip" operation when retrieving "candidate"
     unifiers.
  2- Distinguish partial applications `f a`, `f a b`, and `f a b c`.
-/

def Key.ctorIdx : Key s → Nat
  | .star     => 0
  | .other    => 1
  | .lit ..   => 2
  | .fvar ..  => 3
  | .const .. => 4
  | .arrow    => 5
  | .proj ..  => 6

def Key.lt : Key s → Key s → Bool
  | .lit v₁,        .lit v₂        => v₁ < v₂
  | .fvar n₁ a₁,    .fvar n₂ a₂    => Name.quickLt n₁.name n₂.name || (n₁ == n₂ && a₁ < a₂)
  | .const n₁ a₁,   .const n₂ a₂   => Name.quickLt n₁ n₂ || (n₁ == n₂ && a₁ < a₂)
  | .proj s₁ i₁ a₁, .proj s₂ i₂ a₂ => Name.quickLt s₁ s₂ || (s₁ == s₂ && i₁ < i₂) || (s₁ == s₂ && i₁ == i₂ && a₁ < a₂)
  | k₁,             k₂             => k₁.ctorIdx < k₂.ctorIdx

instance : LT (Key s) := ⟨fun a b => Key.lt a b⟩
instance (a b : Key s) : Decidable (a < b) := inferInstanceAs (Decidable (Key.lt a b))

def Key.format : Key s → Format
  | .star                   => "*"
  | .other                  => "◾"
  | .lit (Literal.natVal v) => Std.format v
  | .lit (Literal.strVal v) => repr v
  | .const k _              => Std.format k
  | .proj s i _             => Std.format s ++ "." ++ Std.format i
  | .fvar k _               => Std.format k.name
  | .arrow                  => "→"

instance : ToFormat (Key s) := ⟨Key.format⟩

def Key.arity : (Key s) → Nat
  | .const _ a  => a
  | .fvar _ a   => a
  | .arrow      => 2
  | .proj _ _ a => 1 + a
  | _           => 0

instance : Inhabited (Trie α s) := ⟨.node #[] #[]⟩

def empty : DiscrTree α s := { root := {} }

partial def Trie.format [ToFormat α] : Trie α s → Format
  | .node vs cs => Format.group $ Format.paren $
    "node" ++ (if vs.isEmpty then Format.nil else " " ++ Std.format vs)
    ++ Format.join (cs.toList.map fun ⟨k, c⟩ => Format.line ++ Format.paren (Std.format k ++ " => " ++ format c))

instance [ToFormat α] : ToFormat (Trie α s) := ⟨Trie.format⟩

partial def format [ToFormat α] (d : DiscrTree α s) : Format :=
  let (_, r) := d.root.foldl
    (fun (p : Bool × Format) k c =>
      (false, p.2 ++ (if p.1 then Format.nil else Format.line) ++ Format.paren (Std.format k ++ " => " ++ Std.format c)))
    (true, Format.nil)
  Format.group r

instance [ToFormat α] : ToFormat (DiscrTree α s) := ⟨format⟩

/-- The discrimination tree ignores implicit arguments and proofs.
   We use the following auxiliary id as a "mark". -/
private def tmpMVarId : MVarId := { name := `_discr_tree_tmp }
private def tmpStar := mkMVar tmpMVarId

instance : Inhabited (DiscrTree α s) where
  default := {}

/--
  Return true iff the argument should be treated as a "wildcard" by the discrimination tree.

  - We ignore proofs because of proof irrelevance. It doesn't make sense to try to
    index their structure.

  - We ignore instance implicit arguments (e.g., `[Add α]`) because they are "morally" canonical.
    Moreover, we may have many definitionally equal terms floating around.
    Example: `Ring.hasAdd Int Int.isRing` and `Int.hasAdd`.

  - We considered ignoring implicit arguments (e.g., `{α : Type}`) since users don't "see" them,
    and may not even understand why some simplification rule is not firing.
    However, in type class resolution, we have instance such as `Decidable (@Eq Nat x y)`,
    where `Nat` is an implicit argument. Thus, we would add the path
    ```
    Decidable -> Eq -> * -> * -> * -> [Nat.decEq]
    ```
    to the discrimination tree IF we ignored the implict `Nat` argument.
    This would be BAD since **ALL** decidable equality instances would be in the same path.
    So, we index implicit arguments if they are types.
    This setting seems sensible for simplification theorems such as:
    ```
    forall (x y : Unit), (@Eq Unit x y) = true
    ```
    If we ignore the implicit argument `Unit`, the `DiscrTree` will say it is a candidate
    simplification theorem for any equality in our goal.

  Remark: if users have problems with the solution above, we may provide a `noIndexing` annotation,
  and `ignoreArg` would return true for any term of the form `noIndexing t`.
-/
private def ignoreArg (a : Expr) (i : Nat) (infos : Array ParamInfo) : MetaM Bool := do
  if h : i < infos.size then
    let info := infos.get ⟨i, h⟩
    if info.isInstImplicit then
      return true
    else if info.isImplicit || info.isStrictImplicit then
      return not (← isType a)
    else
      isProof a
  else
    isProof a

private partial def pushArgsAux (infos : Array ParamInfo) : Nat → Expr → Array Expr → MetaM (Array Expr)
  | i, .app f a, todo => do
    if (← ignoreArg a i infos) then
      pushArgsAux infos (i-1) f (todo.push tmpStar)
    else
      pushArgsAux infos (i-1) f (todo.push a)
  | _, _, todo => return todo

/--
  Return true if `e` is one of the following
  - A nat literal (numeral)
  - `Nat.zero`
  - `Nat.succ x` where `isNumeral x`
  - `OfNat.ofNat _ x _` where `isNumeral x` -/
private partial def isNumeral (e : Expr) : Bool :=
  if e.isNatLit then true
  else
    let f := e.getAppFn
    if !f.isConst then false
    else
      let fName := f.constName!
      if fName == ``Nat.succ && e.getAppNumArgs == 1 then isNumeral e.appArg!
      else if fName == ``OfNat.ofNat && e.getAppNumArgs == 3 then isNumeral (e.getArg! 1)
      else if fName == ``Nat.zero && e.getAppNumArgs == 0 then true
      else false

private def isNatType (e : Expr) : MetaM Bool :=
  return (← whnf e).isConstOf ``Nat

/--
  Return true if `e` is one of the following
  - `Nat.add _ k` where `isNumeral k`
  - `Add.add Nat _ _ k` where `isNumeral k`
  - `HAdd.hAdd _ Nat _ _ k` where `isNumeral k`
  - `Nat.succ _`
  This function assumes `e.isAppOf fName`
-/
private def isOffset (fName : Name) (e : Expr) : MetaM Bool := do
  if fName == ``Nat.add && e.getAppNumArgs == 2 then
    return isNumeral e.appArg!
  else if fName == ``Add.add && e.getAppNumArgs == 4 then
    if (← isNatType (e.getArg! 0)) then return isNumeral e.appArg! else return false
  else if fName == ``HAdd.hAdd && e.getAppNumArgs == 6 then
    if (← isNatType (e.getArg! 1)) then return isNumeral e.appArg! else return false
  else
    return fName == ``Nat.succ && e.getAppNumArgs == 1

/--
  TODO: add hook for users adding their own functions for controlling `shouldAddAsStar`
  Different `DiscrTree` users may populate this set using, for example, attributes.

  Remark: we currently tag `Nat.zero` and "offset" terms to avoid having to add special
  support for `Expr.lit` and offset terms.
  Example, suppose the discrimination tree contains the entry
  `Nat.succ ?m |-> v`, and we are trying to retrieve the matches for `Expr.lit (Literal.natVal 1) _`.
  In this scenario, we want to retrieve `Nat.succ ?m |-> v` -/
private def shouldAddAsStar (fName : Name) (e : Expr) : MetaM Bool := do
  if fName == ``Nat.zero then
    return true
  else
    isOffset fName e

def mkNoindexAnnotation (e : Expr) : Expr :=
  mkAnnotation `noindex e

def hasNoindexAnnotation (e : Expr) : Bool :=
  annotation? `noindex e |>.isSome

/--
Reduction procedure for the discrimination tree indexing.
The parameter `simpleReduce` controls how aggressive the term is reduced.
The parameter at type `DiscrTree` controls this value.
See comment at `DiscrTree`.
-/
partial def reduce (e : Expr) (simpleReduce : Bool) : MetaM Expr := do
  let e ← whnfCore e (simpleReduceOnly := simpleReduce)
  match (← unfoldDefinition? e) with
  | some e => reduce e simpleReduce
  | none => match e.etaExpandedStrict? with
    | some e => reduce e simpleReduce
    | none   => return e

/--
  Return `true` if `fn` is a "bad" key. That is, `pushArgs` would add `Key.other` or `Key.star`.
  We use this function when processing "root terms, and will avoid unfolding terms.
  Note that without this trick the pattern `List.map f ∘ List.map g` would be mapped into the key `Key.other`
  since the function composition `∘` would be unfolded and we would get `fun x => List.map g (List.map f x)`
-/
private def isBadKey (fn : Expr) : Bool :=
  match fn with
  | .lit ..   => false
  | .const .. => false
  | .fvar ..  => false
  | .proj ..  => false
  | .forallE _ _ b _ => b.hasLooseBVars
  | _ => true

/--
  Reduce `e` until we get an irreducible term (modulo current reducibility setting) or the resulting term
  is a bad key (see comment at `isBadKey`).
  We use this method instead of `reduce` for root terms at `pushArgs`. -/
private partial def reduceUntilBadKey (e : Expr) (simpleReduce : Bool) : MetaM Expr := do
  let e ← step e
  match e.etaExpandedStrict? with
  | some e => reduceUntilBadKey e simpleReduce
  | none   => return e
where
  step (e : Expr) := do
    let e ← whnfCore e (simpleReduceOnly := simpleReduce)
    match (← unfoldDefinition? e) with
    | some e' => if isBadKey e'.getAppFn then return e else step e'
    | none    => return e

/-- whnf for the discrimination tree module -/
def reduceDT (e : Expr) (root : Bool) (simpleReduce : Bool) : MetaM Expr :=
  if root then reduceUntilBadKey e simpleReduce else reduce e simpleReduce

/- Remark: we use `shouldAddAsStar` only for nested terms, and `root == false` for nested terms -/

private def pushArgs (root : Bool) (todo : Array Expr) (e : Expr) : MetaM (Key s × Array Expr) := do
  if hasNoindexAnnotation e then
    return (.star, todo)
  else
    let e ← reduceDT e root (simpleReduce := s)
    let fn := e.getAppFn
    let push (k : Key s) (nargs : Nat) (todo : Array Expr): MetaM (Key s × Array Expr) := do
      let info ← getFunInfoNArgs fn nargs
      let todo ← pushArgsAux info.paramInfo (nargs-1) e todo
      return (k, todo)
    match fn with
    | .lit v         => return (.lit v, todo)
    | .const c _     =>
      unless root do
        if (← shouldAddAsStar c e) then
          return (.star, todo)
      let nargs := e.getAppNumArgs
      push (.const c nargs) nargs todo
    | .proj s i a =>
      /-
      If `s` is a class, then `a` is an instance. Thus, we annotate `a` with `no_index` since we do not
      index instances. This should only happen if users mark a class projection function as `[reducible]`.

      TODO: add better support for projections that are functions
      -/
      let a := if isClass (← getEnv) s then mkNoindexAnnotation a else a
      let nargs := e.getAppNumArgs
      push (.proj s i nargs) nargs (todo.push a)
    | .fvar fvarId   =>
      let nargs := e.getAppNumArgs
      push (.fvar fvarId nargs) nargs todo
    | .mvar mvarId   =>
      if mvarId == tmpMVarId then
        -- We use `tmp to mark implicit arguments and proofs
        return (.star, todo)
      else if (← mvarId.isReadOnlyOrSyntheticOpaque) then
        return (.other, todo)
      else
        return (.star, todo)
    | .forallE _ d b _ =>
      if b.hasLooseBVars then
        return (.other, todo)
      else
        return (.arrow, todo.push d |>.push b)
    | _ =>
      return (.other, todo)

partial def mkPathAux (root : Bool) (todo : Array Expr) (keys : Array (Key s)) : MetaM (Array (Key s)) := do
  if todo.isEmpty then
    return keys
  else
    let e    := todo.back
    let todo := todo.pop
    let (k, todo) ← pushArgs root todo e
    mkPathAux false todo (keys.push k)

private def initCapacity := 8

def mkPath (e : Expr) : MetaM (Array (Key s)) := do
  withReducible do
    let todo : Array Expr := .mkEmpty initCapacity
    let keys : Array (Key s) := .mkEmpty initCapacity
    mkPathAux (root := true) (todo.push e) keys

private partial def createNodes (keys : Array (Key s)) (v : α) (i : Nat) : Trie α s :=
  if h : i < keys.size then
    let k := keys.get ⟨i, h⟩
    let c := createNodes keys v (i+1)
    .node #[] #[(k, c)]
  else
    .node #[v] #[]

private def insertVal [BEq α] (vs : Array α) (v : α) : Array α :=
  if vs.contains v then vs else vs.push v

private partial def insertAux [BEq α] (keys : Array (Key s)) (v : α) : Nat → Trie α s → Trie α s
  | i, .node vs cs =>
    if h : i < keys.size then
      let k := keys.get ⟨i, h⟩
      let c := Id.run $ cs.binInsertM
          (fun a b => a.1 < b.1)
          (fun ⟨_, s⟩ => let c := insertAux keys v (i+1) s; (k, c)) -- merge with existing
          (fun _ => let c := createNodes keys v (i+1); (k, c))
          (k, default)
      .node vs c
    else
      .node (insertVal vs v) cs

def insertCore [BEq α] (d : DiscrTree α s) (keys : Array (Key s)) (v : α) : DiscrTree α s :=
  if keys.isEmpty then panic! "invalid key sequence"
  else
    let k := keys[0]!
    match d.root.find? k with
    | none =>
      let c := createNodes keys v 1
      { root := d.root.insert k c }
    | some c =>
      let c := insertAux keys v 1 c
      { root := d.root.insert k c }

def insert [BEq α] (d : DiscrTree α s) (e : Expr) (v : α) : MetaM (DiscrTree α s) := do
  let keys ← mkPath e
  return d.insertCore keys v

private def getKeyArgs (e : Expr) (isMatch root : Bool) : MetaM (Key s × Array Expr) := do
  let e ← reduceDT e root (simpleReduce := s)
  match e.getAppFn with
  | .lit v         => return (.lit v, #[])
  | .const c _     =>
    if (← getConfig).isDefEqStuckEx && e.hasExprMVar then
      if (← isReducible c) then
        /- `e` is a term `c ...` s.t. `c` is reducible and `e` has metavariables, but it was not unfolded.
           This can happen if the metavariables in `e` are "blocking" smart unfolding.
           If `isDefEqStuckEx` is enabled, then we must throw the `isDefEqStuck` exception to postpone TC resolution.
           Here is an example. Suppose we have
           ```
            inductive Ty where
              | bool | fn (a ty : Ty)

            @[reducible] def Ty.interp : Ty → Type
              | bool   => Bool
              | fn a b => a.interp → b.interp
           ```
           and we are trying to synthesize `BEq (Ty.interp ?m)`
        -/
        Meta.throwIsDefEqStuck
      else if let some matcherInfo := isMatcherAppCore? (← getEnv) e then
        -- A matcher application is stuck is one of the discriminants has a metavariable
        let args := e.getAppArgs
        for arg in args[matcherInfo.getFirstDiscrPos: matcherInfo.getFirstDiscrPos + matcherInfo.numDiscrs] do
          if arg.hasExprMVar then
            Meta.throwIsDefEqStuck
      else if (← isRec c) then
        /- Similar to the previous case, but for `match` and recursor applications. It may be stuck (i.e., did not reduce)
           because of metavariables. -/
        Meta.throwIsDefEqStuck
    let nargs := e.getAppNumArgs
    return (.const c nargs, e.getAppRevArgs)
  | .fvar fvarId   =>
    let nargs := e.getAppNumArgs
    return (.fvar fvarId nargs, e.getAppRevArgs)
  | .mvar mvarId   =>
    if isMatch then
      return (.other, #[])
    else do
      let ctx ← read
      if ctx.config.isDefEqStuckEx then
        /-
          When the configuration flag `isDefEqStuckEx` is set to true,
          we want `isDefEq` to throw an exception whenever it tries to assign
          a read-only metavariable.
          This feature is useful for type class resolution where
          we may want to notify the caller that the TC problem may be solveable
          later after it assigns `?m`.
          The method `DiscrTree.getUnify e` returns candidates `c` that may "unify" with `e`.
          That is, `isDefEq c e` may return true. Now, consider `DiscrTree.getUnify d (Add ?m)`
          where `?m` is a read-only metavariable, and the discrimination tree contains the keys
          `HadAdd Nat` and `Add Int`. If `isDefEqStuckEx` is set to true, we must treat `?m` as
          a regular metavariable here, otherwise we return the empty set of candidates.
          This is incorrect because it is equivalent to saying that there is no solution even if
          the caller assigns `?m` and try again. -/
        return (.star, #[])
      else if (← mvarId.isReadOnlyOrSyntheticOpaque) then
        return (.other, #[])
      else
        return (.star, #[])
  | .proj s i a .. =>
    let nargs := e.getAppNumArgs
    return (.proj s i nargs, #[a] ++ e.getAppRevArgs)
  | .forallE _ d b _ =>
    if b.hasLooseBVars then
      return (.other, #[])
    else
      return (.arrow, #[d, b])
  | _ =>
    return (.other, #[])

private abbrev getMatchKeyArgs (e : Expr) (root : Bool) : MetaM (Key s × Array Expr) :=
  getKeyArgs e (isMatch := true) (root := root)

private abbrev getUnifyKeyArgs (e : Expr) (root : Bool) : MetaM (Key s × Array Expr) :=
  getKeyArgs e (isMatch := false) (root := root)

private def getStarResult (d : DiscrTree α s) : Array α :=
  let result : Array α := .mkEmpty initCapacity
  match d.root.find? .star with
  | none                  => result
  | some (.node vs _) => result ++ vs

private abbrev findKey (cs : Array (Key s × Trie α s)) (k : Key s) : Option (Key s × Trie α s) :=
  cs.binSearch (k, default) (fun a b => a.1 < b.1)

private partial def getMatchLoop (todo : Array Expr) (c : Trie α s) (result : Array α) : MetaM (Array α) := do
  match c with
  | .node vs cs =>
    if todo.isEmpty then
      return result ++ vs
    else if cs.isEmpty then
      return result
    else
      let e     := todo.back
      let todo  := todo.pop
      let first := cs[0]! /- Recall that `Key.star` is the minimal key -/
      let (k, args) ← getMatchKeyArgs e (root := false)
      /- We must always visit `Key.star` edges since they are wildcards.
         Thus, `todo` is not used linearly when there is `Key.star` edge
         and there is an edge for `k` and `k != Key.star`. -/
      let visitStar (result : Array α) : MetaM (Array α) :=
        if first.1 == .star then
          getMatchLoop todo first.2 result
        else
          return result
      let visitNonStar (k : Key s) (args : Array Expr) (result : Array α) : MetaM (Array α) :=
        match findKey cs k with
        | none   => return result
        | some c => getMatchLoop (todo ++ args) c.2 result
      let result ← visitStar result
      match k with
      | .star  => return result
      /-
        Note: dep-arrow vs arrow
        Recall that dependent arrows are `(Key.other, #[])`, and non-dependent arrows are `(Key.arrow, #[a, b])`.
        A non-dependent arrow may be an instance of a dependent arrow (stored at `DiscrTree`). Thus, we also visit the `Key.other` child.
      -/
      | .arrow => visitNonStar .other #[] (← visitNonStar k args result)
      | _      => visitNonStar k args result

private def getMatchRoot (d : DiscrTree α s) (k : Key s) (args : Array Expr) (result : Array α) : MetaM (Array α) :=
  match d.root.find? k with
  | none   => return result
  | some c => getMatchLoop args c result

private def getMatchCore (d : DiscrTree α s) (e : Expr) : MetaM (Key s × Array α) :=
  withReducible do
    let result := getStarResult d
    let (k, args) ← getMatchKeyArgs e (root := true)
    match k with
    | .star  => return (k, result)
    /- See note about "dep-arrow vs arrow" at `getMatchLoop` -/
    | .arrow => return (k, (← getMatchRoot d k args (← getMatchRoot d .other #[] result)))
    | _      => return (k, (← getMatchRoot d k args result))

/--
  Find values that match `e` in `d`.
-/
def getMatch (d : DiscrTree α s) (e : Expr) : MetaM (Array α) :=
  return (← getMatchCore d e).2

/--
  Similar to `getMatch`, but returns solutions that are prefixes of `e`.
  We store the number of ignored arguments in the result.-/
partial def getMatchWithExtra (d : DiscrTree α s) (e : Expr) : MetaM (Array (α × Nat)) := do
  let (k, result) ← getMatchCore d e
  let result := result.map (·, 0)
  if !e.isApp then
    return result
  else if !(← mayMatchPrefix k) then
    return result
  else
    go e.appFn! 1 result
where
  mayMatchPrefix (k : Key s) : MetaM Bool :=
    let cont (k : Key s) : MetaM Bool :=
      if d.root.find? k |>.isSome then
        return true
      else
        mayMatchPrefix k
    match k with
    | .const f (n+1)  => cont (.const f n)
    | .fvar f (n+1)   => cont (.fvar f n)
    | .proj s i (n+1) => cont (.proj s i n)
    | _               => return false

  go (e : Expr) (numExtra : Nat) (result : Array (α × Nat)) : MetaM (Array (α × Nat)) := do
    let result := result ++ (← getMatch d e).map (., numExtra)
    if e.isApp then
      go e.appFn! (numExtra + 1) result
    else
      return result

partial def getUnify (d : DiscrTree α s) (e : Expr) : MetaM (Array α) :=
  withReducible do
    let (k, args) ← getUnifyKeyArgs e (root := true)
    match k with
    | .star => d.root.foldlM (init := #[]) fun result k c => process k.arity #[] c result
    | _ =>
      let result := getStarResult d
      match d.root.find? k with
      | none   => return result
      | some c => process 0 args c result
where
  process (skip : Nat) (todo : Array Expr) (c : Trie α s) (result : Array α) : MetaM (Array α) := do
    match skip, c with
    | skip+1, .node _  cs =>
      if cs.isEmpty then
        return result
      else
        cs.foldlM (init := result) fun result ⟨k, c⟩ => process (skip + k.arity) todo c result
    | 0, .node vs cs => do
      if todo.isEmpty then
        return result ++ vs
      else if cs.isEmpty then
        return result
      else
        let e     := todo.back
        let todo  := todo.pop
        let (k, args) ← getUnifyKeyArgs e (root := false)
        let visitStar (result : Array α) : MetaM (Array α) :=
          let first := cs[0]!
          if first.1 == .star then
            process 0 todo first.2 result
          else
            return result
        let visitNonStar (k : Key s) (args : Array Expr) (result : Array α) : MetaM (Array α) :=
          match findKey cs k with
          | none   => return result
          | some c => process 0 (todo ++ args) c.2 result
        match k with
        | .star  => cs.foldlM (init := result) fun result ⟨k, c⟩ => process k.arity todo c result
        -- See comment a `getMatch` regarding non-dependent arrows vs dependent arrows
        | .arrow => visitNonStar .other #[] (← visitNonStar k args (← visitStar result))
        | _      => visitNonStar k args (← visitStar result)

end Lean.Meta.DiscrTree


/-
Copyright (c) 2022 Andrew Yang. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Andrew Yang
-/
import algebraic_geometry.morphisms.basic
import topology.spectral.hom
import algebraic_geometry.limits

/-!
# Quasi-compact morphisms

A morphism of schemes is quasi-compact if the preimages of quasi-compact open sets are
quasi-compact.

It suffices to check that preimages of affine open sets are compact
(`quasi_compact_iff_forall_affine`).

-/

noncomputable theory

open category_theory category_theory.limits opposite topological_space

universe u

open_locale algebraic_geometry

namespace algebraic_geometry

variables {X Y : Scheme.{u}} (f : X ⟶ Y)

/--
A morphism is `quasi-compact` if the underlying map of topological spaces is, i.e. if the preimages
of quasi-compact open sets are quasi-compact.
-/
@[mk_iff]
class quasi_compact (f : X ⟶ Y) : Prop :=
(is_compact_preimage : ∀ U : set Y.carrier, is_open U → is_compact U → is_compact (f.1.base ⁻¹' U))

lemma quasi_compact_iff_spectral : quasi_compact f ↔ is_spectral_map f.1.base :=
⟨λ ⟨h⟩, ⟨by continuity, h⟩, λ h, ⟨h.2⟩⟩

/-- The `affine_target_morphism_property` corresponding to `quasi_compact`, asserting that the
domain is a quasi-compact scheme. -/
def quasi_compact.affine_property : affine_target_morphism_property :=
λ X Y f hf, compact_space X.carrier

@[priority 900]
instance quasi_compact_of_is_iso {X Y : Scheme} (f : X ⟶ Y) [is_iso f] : quasi_compact f :=
begin
  constructor,
  intros U hU hU',
  convert hU'.image (inv f.1.base).continuous_to_fun using 1,
  rw set.image_eq_preimage_of_inverse,
  delta function.left_inverse,
  exacts [is_iso.inv_hom_id_apply f.1.base, is_iso.hom_inv_id_apply f.1.base]
end

instance quasi_compact_comp {X Y Z : Scheme} (f : X ⟶ Y) (g : Y ⟶ Z)
  [quasi_compact f] [quasi_compact g] : quasi_compact (f ≫ g) :=
begin
  constructor,
  intros U hU hU',
  rw [Scheme.comp_val_base, coe_comp, set.preimage_comp],
  apply quasi_compact.is_compact_preimage,
  { exact continuous.is_open_preimage (by continuity) _ hU },
  apply quasi_compact.is_compact_preimage; assumption
end

lemma is_compact_open_iff_eq_finset_affine_union {X : Scheme} (U : set X.carrier) :
  is_compact U ∧ is_open U ↔
    ∃ (s : set X.affine_opens), s.finite ∧ U = ⋃ (i : X.affine_opens) (h : i ∈ s), i :=
begin
  apply opens.is_basis.is_compact_open_iff_eq_finite_Union
    (coe : X.affine_opens → opens X.carrier),
  { rw subtype.range_coe, exact is_basis_affine_open X },
  { exact λ i, i.2.is_compact }
end

lemma is_compact_open_iff_eq_basic_open_union {X : Scheme} [is_affine X] (U : set X.carrier) :
  is_compact U ∧ is_open U ↔
    ∃ (s : set (X.presheaf.obj (op ⊤))), s.finite ∧
      U = ⋃ (i : X.presheaf.obj (op ⊤)) (h : i ∈ s), X.basic_open i :=
(is_basis_basic_open X).is_compact_open_iff_eq_finite_Union _
  (λ i, ((top_is_affine_open _).basic_open_is_affine _).is_compact) _

lemma quasi_compact_iff_forall_affine : quasi_compact f ↔
  ∀ U : opens Y.carrier, is_affine_open U → is_compact (f.1.base ⁻¹' (U : set Y.carrier)) :=
begin
  rw quasi_compact_iff,
  refine ⟨λ H U hU, H U U.is_open hU.is_compact, _⟩,
  intros H U hU hU',
  obtain ⟨S, hS, rfl⟩ := (is_compact_open_iff_eq_finset_affine_union U).mp ⟨hU', hU⟩,
  simp only [set.preimage_Union, subtype.val_eq_coe],
  exact hS.is_compact_bUnion (λ i _, H i i.prop)
end

@[simp] lemma quasi_compact.affine_property_to_property {X Y : Scheme} (f : X ⟶ Y) :
  (quasi_compact.affine_property : _).to_property f ↔
    is_affine Y ∧ compact_space X.carrier :=
by { delta affine_target_morphism_property.to_property quasi_compact.affine_property, simp }

lemma quasi_compact_iff_affine_property :
  quasi_compact f ↔ target_affine_locally quasi_compact.affine_property f :=
begin
  rw quasi_compact_iff_forall_affine,
  transitivity (∀ U : Y.affine_opens, is_compact (f.1.base ⁻¹' (U : set Y.carrier))),
  { exact ⟨λ h U, h U U.prop, λ h U hU, h ⟨U, hU⟩⟩ },
  apply forall_congr,
  exact λ _, is_compact_iff_compact_space,
end

lemma quasi_compact_eq_affine_property :
  @quasi_compact = target_affine_locally quasi_compact.affine_property :=
by { ext, exact quasi_compact_iff_affine_property _ }

lemma is_compact_basic_open (X : Scheme) {U : opens X.carrier} (hU : is_compact (U : set X.carrier))
   (f : X.presheaf.obj (op U)) : is_compact (X.basic_open f : set X.carrier) :=
begin
  classical,
  refine ((is_compact_open_iff_eq_finset_affine_union _).mpr _).1,
  obtain ⟨s, hs, e⟩ := (is_compact_open_iff_eq_finset_affine_union _).mp ⟨hU, U.is_open⟩,
  let g : s → X.affine_opens,
  { intro V,
    use V.1 ⊓ X.basic_open f,
    have : V.1.1 ⟶ U,
    { apply hom_of_le, change _ ⊆ (U : set X.carrier), rw e,
      convert @set.subset_Union₂ _ _ _ (λ (U : X.affine_opens) (h : U ∈ s), ↑U) V V.prop using 1,
      refl },
    erw ← X.to_LocallyRingedSpace.to_RingedSpace.basic_open_res this.op,
    exact is_affine_open.basic_open_is_affine V.1.prop _ },
  haveI : finite s := hs.to_subtype,
  refine ⟨set.range g, set.finite_range g, _⟩,
  refine (set.inter_eq_right_iff_subset.mpr (set_like.coe_subset_coe.2 $
    RingedSpace.basic_open_le _ _)).symm.trans _,
  rw [e, set.Union₂_inter],
  apply le_antisymm; apply set.Union₂_subset,
  { intros i hi,
    refine set.subset.trans _ (set.subset_Union₂ _ (set.mem_range_self ⟨i, hi⟩)),
    exact set.subset.rfl },
  { rintro ⟨i, hi⟩ ⟨⟨j, hj⟩, hj'⟩,
    rw ← hj',
    refine set.subset.trans _ (set.subset_Union₂ j hj),
    exact set.subset.rfl }
end

lemma quasi_compact.affine_property_is_local :
  (quasi_compact.affine_property : _).is_local :=
begin
  split,
  { apply affine_target_morphism_property.respects_iso_mk; rintros X Y Z _ _ _ H,
    exacts [@@homeomorph.compact_space _ _ H (Top.homeo_of_iso (as_iso e.inv.1.base)), H] },
  { introv H,
    delta quasi_compact.affine_property at H ⊢,
    change compact_space ((opens.map f.val.base).obj (Y.basic_open r)),
    rw Scheme.preimage_basic_open f r,
    erw ← is_compact_iff_compact_space,
    rw ← is_compact_univ_iff at H,
    exact is_compact_basic_open X H _ },
  { rintros X Y H f S hS hS',
    resetI,
    rw ← is_affine_open.basic_open_union_eq_self_iff at hS,
    delta quasi_compact.affine_property,
    rw ← is_compact_univ_iff,
    change is_compact ((opens.map f.val.base).obj ⊤).1,
    rw ← hS,
    dsimp [opens.map],
    simp only [opens.coe_supr, set.preimage_Union, subtype.val_eq_coe],
    exacts [is_compact_Union (λ i, is_compact_iff_compact_space.mpr (hS' i)),
      top_is_affine_open _] }
end

lemma quasi_compact.affine_open_cover_tfae {X Y : Scheme.{u}} (f : X ⟶ Y) :
  tfae [quasi_compact f,
    ∃ (𝒰 : Scheme.open_cover.{u} Y) [∀ i, is_affine (𝒰.obj i)],
      ∀ (i : 𝒰.J), compact_space (pullback f (𝒰.map i)).carrier,
    ∀ (𝒰 : Scheme.open_cover.{u} Y) [∀ i, is_affine (𝒰.obj i)] (i : 𝒰.J),
      compact_space (pullback f (𝒰.map i)).carrier,
    ∀ {U : Scheme} (g : U ⟶ Y) [is_affine U] [is_open_immersion g],
      compact_space (pullback f g).carrier,
    ∃ {ι : Type u} (U : ι → opens Y.carrier) (hU : supr U = ⊤) (hU' : ∀ i, is_affine_open (U i)),
      ∀ i, compact_space (f.1.base ⁻¹' (U i).1)] :=
quasi_compact_eq_affine_property.symm ▸
  quasi_compact.affine_property_is_local.affine_open_cover_tfae f

lemma quasi_compact.is_local_at_target :
  property_is_local_at_target @quasi_compact :=
quasi_compact_eq_affine_property.symm ▸
  quasi_compact.affine_property_is_local.target_affine_locally_is_local

lemma quasi_compact.open_cover_tfae {X Y : Scheme.{u}} (f : X ⟶ Y) :
  tfae [quasi_compact f,
    ∃ (𝒰 : Scheme.open_cover.{u} Y), ∀ (i : 𝒰.J),
      quasi_compact (pullback.snd : (𝒰.pullback_cover f).obj i ⟶ 𝒰.obj i),
    ∀ (𝒰 : Scheme.open_cover.{u} Y) (i : 𝒰.J),
      quasi_compact (pullback.snd : (𝒰.pullback_cover f).obj i ⟶ 𝒰.obj i),
    ∀ (U : opens Y.carrier), quasi_compact (f ∣_ U),
    ∀ {U : Scheme} (g : U ⟶ Y) [is_open_immersion g],
      quasi_compact (pullback.snd : pullback f g ⟶ _),
    ∃ {ι : Type u} (U : ι → opens Y.carrier) (hU : supr U = ⊤), ∀ i, quasi_compact (f ∣_ (U i))] :=
quasi_compact_eq_affine_property.symm ▸
  quasi_compact.affine_property_is_local.target_affine_locally_is_local.open_cover_tfae f

lemma quasi_compact_over_affine_iff {X Y : Scheme} (f : X ⟶ Y) [is_affine Y] :
  quasi_compact f ↔ compact_space X.carrier :=
quasi_compact_eq_affine_property.symm ▸
  quasi_compact.affine_property_is_local.affine_target_iff f

lemma compact_space_iff_quasi_compact (X : Scheme) :
  compact_space X.carrier ↔ quasi_compact (terminal.from X) :=
(quasi_compact_over_affine_iff _).symm

lemma quasi_compact.affine_open_cover_iff {X Y : Scheme.{u}} (𝒰 : Scheme.open_cover.{u} Y)
  [∀ i, is_affine (𝒰.obj i)] (f : X ⟶ Y) :
  quasi_compact f ↔ ∀ i, compact_space (pullback f (𝒰.map i)).carrier :=
quasi_compact_eq_affine_property.symm ▸
  quasi_compact.affine_property_is_local.affine_open_cover_iff f 𝒰

lemma quasi_compact.open_cover_iff {X Y : Scheme.{u}} (𝒰 : Scheme.open_cover.{u} Y) (f : X ⟶ Y) :
  quasi_compact f ↔ ∀ i, quasi_compact (pullback.snd : pullback f (𝒰.map i) ⟶ _) :=
quasi_compact_eq_affine_property.symm ▸
  quasi_compact.affine_property_is_local.target_affine_locally_is_local.open_cover_iff f 𝒰

lemma quasi_compact_stable_under_composition :
  morphism_property.stable_under_composition @quasi_compact :=
λ _ _ _ _ _ _ _, by exactI infer_instance

local attribute [-simp] PresheafedSpace.as_coe SheafedSpace.as_coe

lemma quasi_compact.affine_property_stable_under_base_change :
  quasi_compact.affine_property.stable_under_base_change :=
begin
  intros X Y S _ _ f g h,
  rw quasi_compact.affine_property at h ⊢,
  resetI,
  let 𝒰 := Scheme.pullback.open_cover_of_right Y.affine_cover.finite_subcover f g,
  haveI : finite 𝒰.J,
  { dsimp [𝒰], apply_instance },
  haveI : ∀ i, compact_space (𝒰.obj i).carrier,
  { intro i, dsimp, apply_instance },
  exact 𝒰.compact_space,
end

lemma quasi_compact_stable_under_base_change :
  morphism_property.stable_under_base_change @quasi_compact :=
quasi_compact_eq_affine_property.symm ▸
  quasi_compact.affine_property_is_local.stable_under_base_change
    quasi_compact.affine_property_stable_under_base_change

variables {Z : Scheme.{u}}

instance (f : X ⟶ Z) (g : Y ⟶ Z) [quasi_compact g] :
  quasi_compact (pullback.fst : pullback f g ⟶ X) :=
quasi_compact_stable_under_base_change.fst f g infer_instance

instance (f : X ⟶ Z) (g : Y ⟶ Z) [quasi_compact f] :
  quasi_compact (pullback.snd : pullback f g ⟶ Y) :=
quasi_compact_stable_under_base_change.snd f g infer_instance

@[elab_as_eliminator]
lemma compact_open_induction_on {P : opens X.carrier → Prop} (S : opens X.carrier)
  (hS : is_compact S.1)
  (h₁ : P ⊥)
  (h₂ : ∀ (S : opens X.carrier) (hS : is_compact S.1) (U : X.affine_opens), P S → P (S ⊔ U)) :
    P S :=
begin
  classical,
  obtain ⟨s, hs, hs'⟩ := (is_compact_open_iff_eq_finset_affine_union S.1).mp ⟨hS, S.2⟩,
  replace hs' : S = supr (λ i : s, (i : opens X.carrier)) := by { ext1, simpa using hs' },
  subst hs',
  apply hs.induction_on,
  { convert h₁, rw supr_eq_bot, rintro ⟨_, h⟩, exact h.elim },
  { intros x s h₃ hs h₄,
    have : is_compact (⨆ i : s, (i : opens X.carrier)).1,
    { refine ((is_compact_open_iff_eq_finset_affine_union _).mpr _).1, exact ⟨s, hs, by simp⟩ },
    convert h₂ _ this x h₄,
    simp only [coe_coe],
    rw [supr_subtype, sup_comm],
    conv_rhs { rw supr_subtype },
    exact supr_insert }
end

lemma exists_pow_mul_eq_zero_of_res_basic_open_eq_zero_of_is_affine_open (X : Scheme)
  {U : opens X.carrier} (hU : is_affine_open U) (x f : X.presheaf.obj (op U))
  (H : x |_ X.basic_open f = 0) :
  ∃ n : ℕ, f ^ n * x = 0 :=
begin
  rw ← map_zero (X.presheaf.map (hom_of_le $ X.basic_open_le f : X.basic_open f ⟶ U).op) at H,
  have := (is_localization_basic_open hU f).3,
  obtain ⟨⟨_, n, rfl⟩, e⟩ := this.mp H,
  exact ⟨n, by simpa [mul_comm x] using e⟩,
end

/-- If `x : Γ(X, U)` is zero on `D(f)` for some `f : Γ(X, U)`, and `U` is quasi-compact, then
`f ^ n * x = 0` for some `n`. -/
lemma exists_pow_mul_eq_zero_of_res_basic_open_eq_zero_of_is_compact (X : Scheme)
  {U : opens X.carrier} (hU : is_compact U.1) (x f : X.presheaf.obj (op U))
  (H : x |_ X.basic_open f = 0) :
  ∃ n : ℕ, f ^ n * x = 0 :=
begin
  obtain ⟨s, hs, e⟩ := (is_compact_open_iff_eq_finset_affine_union U.1).mp ⟨hU, U.2⟩,
  replace e : U = supr (λ i : s, (i : opens X.carrier)),
  { ext1, simpa using e },
  have h₁ : ∀ i : s, i.1.1 ≤ U,
  { intro i, change (i : opens X.carrier) ≤ U, rw e, exact le_supr _ _ },
  have H' := λ (i : s), exists_pow_mul_eq_zero_of_res_basic_open_eq_zero_of_is_affine_open X i.1.2
    (X.presheaf.map (hom_of_le (h₁ i)).op x) (X.presheaf.map (hom_of_le (h₁ i)).op f) _,
  swap,
  { delta Top.presheaf.restrict_open Top.presheaf.restrict at H ⊢,
    convert congr_arg (X.presheaf.map (hom_of_le _).op) H,
    { simp only [← comp_apply, ← functor.map_comp], congr },
    { rw map_zero },
    { rw X.basic_open_res, exact set.inter_subset_right _ _ } },
  choose n hn using H',
  haveI := hs.to_subtype,
  casesI nonempty_fintype s,
  use finset.univ.sup n,
  suffices : ∀ (i : s), X.presheaf.map (hom_of_le (h₁ i)).op (f ^ (finset.univ.sup n) * x) = 0,
  { subst e,
    apply X.sheaf.eq_of_locally_eq (λ (i : s), (i : opens X.carrier)),
    intro i,
    rw map_zero,
    apply this },
  intro i,
  replace hn := congr_arg
    (λ x, X.presheaf.map (hom_of_le (h₁ i)).op (f ^ (finset.univ.sup n - n i)) * x) (hn i),
  dsimp at hn,
  simp only [← map_mul, ← map_pow] at hn,
  rwa [mul_zero, ← mul_assoc, ← pow_add, tsub_add_cancel_of_le] at hn,
  apply finset.le_sup (finset.mem_univ i)
end

end algebraic_geometry


/-
Copyright (c) 2020 Yakov Pechersky. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Yakov Pechersky
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.data.string.basic
import Mathlib.PostPort

namespace Mathlib

/-!
# Parsers

`parser α` is the type that describes a computation that can ingest a `char_buffer`
and output, if successful, a term of type `α`.
This file expands on the definitions in the core library, proving that all the core library
parsers are `valid`. There are also lemmas on the composability of parsers.

## Main definitions

* `parse_result.pos` : The position of a `char_buffer` at which a `parser α` has finished.
* `parser.valid` : The property that a parser only moves forward within a buffer,
  in both cases of success or failure.

## Implementation details

Lemmas about how parsers are valid are in the `valid` namespace. That allows using projection
notation for shorter term proofs that are parallel to the definitions of the parsers in structure.

-/

/--
For some `parse_result α`, give the position at which the result was provided, in either the
`done` or the `fail` case.
-/
@[simp] def parse_result.pos {α : Type} : parse_result α → ℕ := sorry

namespace parser

/--
A `parser α` is defined to be `valid` if the result `p cb n` it gives,
for some `cb : char_buffer` and `n : ℕ`, (whether `done` or `fail`),
is always at a `parse_result.pos` that is at least `n`. Additionally, if the position of the result
of the parser was within the size of the `cb`, then the input to the parser must have been within
`cb.size` too.
-/
def valid {α : Type} (p : parser α) :=
  ∀ (cb : char_buffer) (n : ℕ),
    n ≤ parse_result.pos (p cb n) ∧
      (parse_result.pos (p cb n) ≤ buffer.size cb → n ≤ buffer.size cb)

theorem fail_iff {α : Type} (p : parser α) (cb : char_buffer) (n : ℕ) :
    (∀ (pos' : ℕ) (result : α), p cb n ≠ parse_result.done pos' result) ↔
        ∃ (pos' : ℕ), ∃ (err : dlist string), p cb n = parse_result.fail pos' err :=
  sorry

theorem success_iff {α : Type} (p : parser α) (cb : char_buffer) (n : ℕ) :
    (∀ (pos' : ℕ) (err : dlist string), p cb n ≠ parse_result.fail pos' err) ↔
        ∃ (pos' : ℕ), ∃ (result : α), p cb n = parse_result.done pos' result :=
  sorry

theorem decorate_errors_fail {α : Type} {msgs : thunk (List string)} {p : parser α}
    {cb : char_buffer} {n : ℕ} {n' : ℕ} {err : dlist string}
    (h : p cb n = parse_result.fail n' err) :
    decorate_errors msgs p cb n =
        parse_result.fail n (dlist.lazy_of_list fun (_ : Unit) => msgs Unit.unit) :=
  sorry

theorem decorate_errors_success {α : Type} {msgs : thunk (List string)} {p : parser α}
    {cb : char_buffer} {n : ℕ} {n' : ℕ} {a : α} (h : p cb n = parse_result.done n' a) :
    decorate_errors msgs p cb n = parse_result.done n' a :=
  sorry

theorem decorate_error_fail {α : Type} {msg : thunk string} {p : parser α} {cb : char_buffer}
    {n : ℕ} {n' : ℕ} {err : dlist string} (h : p cb n = parse_result.fail n' err) :
    decorate_error msg p cb n =
        parse_result.fail n (dlist.lazy_of_list fun (_ : Unit) => [msg Unit.unit]) :=
  decorate_errors_fail h

theorem decorate_error_success {α : Type} {msg : thunk string} {p : parser α} {cb : char_buffer}
    {n : ℕ} {n' : ℕ} {a : α} (h : p cb n = parse_result.done n' a) :
    decorate_error msg p cb n = parse_result.done n' a :=
  decorate_errors_success h

@[simp] theorem decorate_errors_eq_done {α : Type} {msgs : thunk (List string)} {p : parser α}
    {cb : char_buffer} {n : ℕ} {n' : ℕ} {a : α} :
    decorate_errors msgs p cb n = parse_result.done n' a ↔ p cb n = parse_result.done n' a :=
  sorry

@[simp] theorem decorate_error_eq_done {α : Type} {msg : thunk string} {p : parser α}
    {cb : char_buffer} {n : ℕ} {n' : ℕ} {a : α} :
    decorate_error msg p cb n = parse_result.done n' a ↔ p cb n = parse_result.done n' a :=
  decorate_errors_eq_done

@[simp] theorem decorate_errors_eq_fail {α : Type} {msgs : thunk (List string)} {p : parser α}
    {cb : char_buffer} {n : ℕ} {err : dlist string} :
    decorate_errors msgs p cb n = parse_result.fail n err ↔
        (err = dlist.lazy_of_list fun (_ : Unit) => msgs Unit.unit) ∧
          ∃ (np : ℕ), ∃ (err' : dlist string), p cb n = parse_result.fail np err' :=
  sorry

@[simp] theorem decorate_error_eq_fail {α : Type} {msg : thunk string} {p : parser α}
    {cb : char_buffer} {n : ℕ} {err : dlist string} :
    decorate_error msg p cb n = parse_result.fail n err ↔
        (err = dlist.lazy_of_list fun (_ : Unit) => [msg Unit.unit]) ∧
          ∃ (np : ℕ), ∃ (err' : dlist string), p cb n = parse_result.fail np err' :=
  decorate_errors_eq_fail

@[simp] theorem return_eq_pure {α : Type} {a : α} : return a = pure a := rfl

theorem pure_eq_done {α : Type} {a : α} :
    pure a = fun (_x : char_buffer) (n : ℕ) => parse_result.done n a :=
  rfl

@[simp] theorem pure_ne_fail {α : Type} {cb : char_buffer} {n : ℕ} {n' : ℕ} {err : dlist string}
    {a : α} : pure a cb n ≠ parse_result.fail n' err :=
  sorry

@[simp] theorem bind_eq_bind {α : Type} {β : Type} {p : parser α} (f : α → parser β) :
    parser.bind p f = p >>= f :=
  rfl

@[simp] theorem bind_eq_done {α : Type} {β : Type} {p : parser α} {cb : char_buffer} {n : ℕ}
    {n' : ℕ} {b : β} {f : α → parser β} :
    bind p f cb n = parse_result.done n' b ↔
        ∃ (np : ℕ),
          ∃ (a : α), p cb n = parse_result.done np a ∧ f a cb np = parse_result.done n' b :=
  sorry

@[simp] theorem bind_eq_fail {α : Type} {β : Type} {p : parser α} {cb : char_buffer} {n : ℕ}
    {n' : ℕ} {err : dlist string} {f : α → parser β} :
    bind p f cb n = parse_result.fail n' err ↔
        p cb n = parse_result.fail n' err ∨
          ∃ (np : ℕ),
            ∃ (a : α), p cb n = parse_result.done np a ∧ f a cb np = parse_result.fail n' err :=
  sorry

@[simp] theorem and_then_eq_bind {α : Type} {β : Type} {m : Type → Type} [Monad m] (a : m α)
    (b : m β) :
    a >> b =
        do
          a
          b :=
  rfl

theorem and_then_fail {α : Type} {p : parser α} {cb : char_buffer} {n : ℕ} {n' : ℕ}
    {err : dlist string} :
    has_bind.and_then p (return Unit.unit) cb n = parse_result.fail n' err ↔
        p cb n = parse_result.fail n' err :=
  sorry

theorem and_then_success {α : Type} {p : parser α} {cb : char_buffer} {n : ℕ} {n' : ℕ} :
    has_bind.and_then p (return Unit.unit) cb n = parse_result.done n' Unit.unit ↔
        ∃ (a : α), p cb n = parse_result.done n' a :=
  sorry

@[simp] theorem map_eq_done {α : Type} {β : Type} {p : parser α} {cb : char_buffer} {n : ℕ} {n' : ℕ}
    {b : β} {f : α → β} :
    Functor.map f p cb n = parse_result.done n' b ↔
        ∃ (a : α), p cb n = parse_result.done n' a ∧ f a = b :=
  sorry

@[simp] theorem map_eq_fail {α : Type} {β : Type} {p : parser α} {cb : char_buffer} {n : ℕ} {n' : ℕ}
    {err : dlist string} {f : α → β} :
    Functor.map f p cb n = parse_result.fail n' err ↔ p cb n = parse_result.fail n' err :=
  sorry

@[simp] theorem map_const_eq_done {α : Type} {β : Type} {p : parser α} {cb : char_buffer} {n : ℕ}
    {n' : ℕ} {b : β} {b' : β} :
    Functor.mapConst b p cb n = parse_result.done n' b' ↔
        ∃ (a : α), p cb n = parse_result.done n' a ∧ b = b' :=
  sorry

@[simp] theorem map_const_eq_fail {α : Type} {β : Type} {p : parser α} {cb : char_buffer} {n : ℕ}
    {n' : ℕ} {err : dlist string} {b : β} :
    Functor.mapConst b p cb n = parse_result.fail n' err ↔ p cb n = parse_result.fail n' err :=
  sorry

theorem map_const_rev_eq_done {α : Type} {β : Type} {p : parser α} {cb : char_buffer} {n : ℕ}
    {n' : ℕ} {b : β} {b' : β} :
    functor.map_const_rev p b cb n = parse_result.done n' b' ↔
        ∃ (a : α), p cb n = parse_result.done n' a ∧ b = b' :=
  map_const_eq_done

theorem map_rev_const_eq_fail {α : Type} {β : Type} {p : parser α} {cb : char_buffer} {n : ℕ}
    {n' : ℕ} {err : dlist string} {b : β} :
    functor.map_const_rev p b cb n = parse_result.fail n' err ↔ p cb n = parse_result.fail n' err :=
  map_const_eq_fail

@[simp] theorem orelse_eq_orelse {α : Type} {p : parser α} {q : parser α} :
    parser.orelse p q = (p <|> q) :=
  rfl

@[simp] theorem orelse_eq_done {α : Type} {p : parser α} {q : parser α} {cb : char_buffer} {n : ℕ}
    {n' : ℕ} {a : α} :
    has_orelse.orelse p q cb n = parse_result.done n' a ↔
        p cb n = parse_result.done n' a ∨
          q cb n = parse_result.done n' a ∧
            ∃ (err : dlist string), p cb n = parse_result.fail n err :=
  sorry

@[simp] theorem orelse_eq_fail_eq {α : Type} {p : parser α} {q : parser α} {cb : char_buffer}
    {n : ℕ} {err : dlist string} :
    has_orelse.orelse p q cb n = parse_result.fail n err ↔
        (p cb n = parse_result.fail n err ∧
            ∃ (nq : ℕ), ∃ (errq : dlist string), n < nq ∧ q cb n = parse_result.fail nq errq) ∨
          ∃ (errp : dlist string),
            ∃ (errq : dlist string),
              p cb n = parse_result.fail n errp ∧
                q cb n = parse_result.fail n errq ∧ errp ++ errq = err :=
  sorry

theorem orelse_eq_fail_invalid_lt {α : Type} {p : parser α} {q : parser α} {cb : char_buffer}
    {n : ℕ} {n' : ℕ} {err : dlist string} (hn : n' < n) :
    has_orelse.orelse p q cb n = parse_result.fail n' err ↔
        p cb n = parse_result.fail n' err ∨
          q cb n = parse_result.fail n' err ∧
            ∃ (errp : dlist string), p cb n = parse_result.fail n errp :=
  sorry

theorem orelse_eq_fail_of_valid_ne {α : Type} {p : parser α} {q : parser α} {cb : char_buffer}
    {n : ℕ} {n' : ℕ} {err : dlist string} (hv : valid q) (hn : n ≠ n') :
    has_orelse.orelse p q cb n = parse_result.fail n' err ↔ p cb n = parse_result.fail n' err :=
  sorry

@[simp] theorem failure_eq_failure {α : Type} : parser.failure = failure := rfl

@[simp] theorem failure_def {α : Type} {cb : char_buffer} {n : ℕ} :
    failure cb n = parse_result.fail n dlist.empty :=
  rfl

theorem not_failure_eq_done {α : Type} {cb : char_buffer} {n : ℕ} {n' : ℕ} {a : α} :
    ¬failure cb n = parse_result.done n' a :=
  sorry

theorem failure_eq_fail {α : Type} {cb : char_buffer} {n : ℕ} {n' : ℕ} {err : dlist string} :
    failure cb n = parse_result.fail n' err ↔ n = n' ∧ err = dlist.empty :=
  sorry

theorem seq_eq_done {α : Type} {β : Type} {cb : char_buffer} {n : ℕ} {n' : ℕ} {b : β}
    {f : parser (α → β)} {p : parser α} :
    Seq.seq f p cb n = parse_result.done n' b ↔
        ∃ (nf : ℕ),
          ∃ (f' : α → β),
            ∃ (a : α),
              f cb n = parse_result.done nf f' ∧ p cb nf = parse_result.done n' a ∧ f' a = b :=
  sorry

theorem seq_eq_fail {α : Type} {β : Type} {cb : char_buffer} {n : ℕ} {n' : ℕ} {err : dlist string}
    {f : parser (α → β)} {p : parser α} :
    Seq.seq f p cb n = parse_result.fail n' err ↔
        f cb n = parse_result.fail n' err ∨
          ∃ (nf : ℕ),
            ∃ (f' : α → β), f cb n = parse_result.done nf f' ∧ p cb nf = parse_result.fail n' err :=
  sorry

theorem seq_left_eq_done {α : Type} {β : Type} {cb : char_buffer} {n : ℕ} {n' : ℕ} {a : α}
    {p : parser α} {q : parser β} :
    SeqLeft.seqLeft p q cb n = parse_result.done n' a ↔
        ∃ (np : ℕ), ∃ (b : β), p cb n = parse_result.done np a ∧ q cb np = parse_result.done n' b :=
  sorry

theorem seq_left_eq_fail {α : Type} {β : Type} {cb : char_buffer} {n : ℕ} {n' : ℕ}
    {err : dlist string} {p : parser α} {q : parser β} :
    SeqLeft.seqLeft p q cb n = parse_result.fail n' err ↔
        p cb n = parse_result.fail n' err ∨
          ∃ (np : ℕ),
            ∃ (a : α), p cb n = parse_result.done np a ∧ q cb np = parse_result.fail n' err :=
  sorry

theorem seq_right_eq_done {α : Type} {β : Type} {cb : char_buffer} {n : ℕ} {n' : ℕ} {b : β}
    {p : parser α} {q : parser β} :
    SeqRight.seqRight p q cb n = parse_result.done n' b ↔
        ∃ (np : ℕ), ∃ (a : α), p cb n = parse_result.done np a ∧ q cb np = parse_result.done n' b :=
  sorry

theorem seq_right_eq_fail {α : Type} {β : Type} {cb : char_buffer} {n : ℕ} {n' : ℕ}
    {err : dlist string} {p : parser α} {q : parser β} :
    SeqRight.seqRight p q cb n = parse_result.fail n' err ↔
        p cb n = parse_result.fail n' err ∨
          ∃ (np : ℕ),
            ∃ (a : α), p cb n = parse_result.done np a ∧ q cb np = parse_result.fail n' err :=
  sorry

theorem mmap_eq_done {α : Type} {β : Type} {cb : char_buffer} {n : ℕ} {n' : ℕ} {f : α → parser β}
    {a : α} {l : List α} {b : β} {l' : List β} :
    mmap f (a :: l) cb n = parse_result.done n' (b :: l') ↔
        ∃ (np : ℕ), f a cb n = parse_result.done np b ∧ mmap f l cb np = parse_result.done n' l' :=
  sorry

theorem mmap'_eq_done {α : Type} {β : Type} {cb : char_buffer} {n : ℕ} {n' : ℕ} {f : α → parser β}
    {a : α} {l : List α} :
    mmap' f (a :: l) cb n = parse_result.done n' Unit.unit ↔
        ∃ (np : ℕ),
          ∃ (b : β),
            f a cb n = parse_result.done np b ∧ mmap' f l cb np = parse_result.done n' Unit.unit :=
  sorry

theorem guard_eq_done {cb : char_buffer} {n : ℕ} {n' : ℕ} {p : Prop} [Decidable p] :
    guard p cb n = parse_result.done n' Unit.unit ↔ p ∧ n = n' :=
  sorry

theorem guard_eq_fail {cb : char_buffer} {n : ℕ} {n' : ℕ} {err : dlist string} {p : Prop}
    [Decidable p] : guard p cb n = parse_result.fail n' err ↔ ¬p ∧ n = n' ∧ err = dlist.empty :=
  sorry

namespace valid

theorem mono_done {α : Type} {p : parser α} {cb : char_buffer} {n : ℕ} {n' : ℕ} {a : α}
    (hp : valid p) (h : p cb n = parse_result.done n' a) : n ≤ n' :=
  sorry

theorem mono_fail {α : Type} {p : parser α} {cb : char_buffer} {n : ℕ} {n' : ℕ} {err : dlist string}
    (hp : valid p) (h : p cb n = parse_result.fail n' err) : n ≤ n' :=
  sorry

theorem pure {α : Type} {a : α} : valid (pure a) := sorry

@[simp] theorem bind {α : Type} {β : Type} {p : parser α} {f : α → parser β} (hp : valid p)
    (hf : ∀ (a : α), valid (f a)) : valid (p >>= f) :=
  sorry

theorem and_then {α : Type} {β : Type} {p : parser α} {q : parser β} (hp : valid p) (hq : valid q) :
    valid (p >> q) :=
  bind hp fun (_x : α) => hq

@[simp] theorem map {α : Type} {β : Type} {p : parser α} (hp : valid p) {f : α → β} :
    valid (f <$> p) :=
  bind hp fun (_x : α) => pure

@[simp] theorem seq {α : Type} {β : Type} {p : parser α} {f : parser (α → β)} (hf : valid f)
    (hp : valid p) : valid (f <*> p) :=
  bind hf fun (_x : α → β) => map hp

@[simp] theorem mmap {α : Type} {β : Type} {l : List α} {f : α → parser β}
    (h : ∀ (a : α), a ∈ l → valid (f a)) : valid (mmap f l) :=
  sorry

@[simp] theorem mmap' {α : Type} {β : Type} {l : List α} {f : α → parser β}
    (h : ∀ (a : α), a ∈ l → valid (f a)) : valid (mmap' f l) :=
  sorry

@[simp] theorem failure {α : Type} : valid failure := sorry

@[simp] theorem guard {p : Prop} [Decidable p] : valid (guard p) := sorry

@[simp] theorem orelse {α : Type} {p : parser α} {q : parser α} (hp : valid p) (hq : valid q) :
    valid (p <|> q) :=
  sorry

@[simp] theorem decorate_errors {α : Type} {msgs : thunk (List string)} {p : parser α}
    (hp : valid p) : valid (decorate_errors msgs p) :=
  sorry

@[simp] theorem decorate_error {α : Type} {msg : thunk string} {p : parser α} (hp : valid p) :
    valid (decorate_error msg p) :=
  decorate_errors hp

@[simp] theorem any_char : valid any_char := sorry

@[simp] theorem sat {p : char → Prop} [decidable_pred p] : valid (sat p) := sorry

@[simp] theorem eps : valid eps := pure

theorem ch {c : char} : valid (ch c) := decorate_error (and_then sat eps)

theorem char_buf {s : char_buffer} : valid (char_buf s) :=
  decorate_error (mmap' fun (_x : char) (_x_1 : _x ∈ buffer.to_list s) => ch)

theorem one_of {cs : List char} : valid (one_of cs) := decorate_errors sat

theorem one_of' {cs : List char} : valid (one_of' cs) := and_then one_of eps

theorem str {s : string} : valid (str s) :=
  decorate_error (mmap' fun (_x : char) (_x_1 : _x ∈ string.to_list s) => ch)

theorem remaining : valid remaining :=
  fun (_x : char_buffer) (_x_1 : ℕ) =>
    { left := le_refl _x_1,
      right := fun (h : parse_result.pos (remaining _x _x_1) ≤ buffer.size _x) => h }

theorem eof : valid eof := decorate_error (bind remaining fun (_x : ℕ) => guard)

theorem foldr_core_zero {α : Type} {β : Type} {p : parser α} {f : α → β → β} {b : β} :
    valid (foldr_core f p b 0) :=
  failure

theorem foldr_core {α : Type} {β : Type} {p : parser α} {f : α → β → β} {b : β} (hp : valid p)
    {reps : ℕ} : valid (foldr_core f p b reps) :=
  sorry

theorem foldr {α : Type} {β : Type} {p : parser α} {b : β} {f : α → β → β} (hp : valid p) :
    valid (foldr f p b) :=
  fun (_x : char_buffer) (_x_1 : ℕ) => foldr_core hp _x _x_1

theorem foldl_core_zero {α : Type} {β : Type} {p : parser α} {f : β → α → β} {b : β} :
    valid (foldl_core f b p 0) :=
  failure

theorem foldl_core {α : Type} {β : Type} {f : α → β → α} {p : parser β} (hp : valid p) {a : α}
    {reps : ℕ} : valid (foldl_core f a p reps) :=
  sorry

theorem foldl {α : Type} {β : Type} {a : α} {f : α → β → α} {p : parser β} (hp : valid p) :
    valid (foldl f a p) :=
  fun (_x : char_buffer) (_x_1 : ℕ) => foldl_core hp _x _x_1

theorem many {α : Type} {p : parser α} (hp : valid p) : valid (many p) := foldr hp

theorem many_char {p : parser char} (hp : valid p) : valid (many_char p) := map (many hp)

theorem many' {α : Type} {p : parser α} (hp : valid p) : valid (many' p) := and_then (many hp) eps

theorem many1 {α : Type} {p : parser α} (hp : valid p) : valid (many1 p) := seq (map hp) (many hp)

theorem many_char1 {p : parser char} (hp : valid p) : valid (many_char1 p) := map (many1 hp)

theorem sep_by1 {α : Type} {p : parser α} {sep : parser Unit} (hp : valid p) (hs : valid sep) :
    valid (sep_by1 sep p) :=
  seq (map hp) (many (and_then hs hp))

theorem sep_by {α : Type} {p : parser α} {sep : parser Unit} (hp : valid p) (hs : valid sep) :
    valid (sep_by sep p) :=
  orelse (sep_by1 hp hs) pure

theorem fix_core {α : Type} {F : parser α → parser α} (hF : ∀ (p : parser α), valid p → valid (F p))
    (max_depth : ℕ) : valid (fix_core F max_depth) :=
  sorry

theorem digit : valid digit := decorate_error (bind sat fun (_x : char) => pure)

theorem nat : valid nat := decorate_error (bind (many1 digit) fun (_x : List ℕ) => pure)

theorem fix {α : Type} {F : parser α → parser α} (hF : ∀ (p : parser α), valid p → valid (F p)) :
    valid (fix F) :=
  fun (_x : char_buffer) (_x_1 : ℕ) => fix_core hF (buffer.size _x - _x_1 + 1) _x _x_1

end valid

@[simp] theorem orelse_pure_eq_fail {α : Type} {p : parser α} {cb : char_buffer} {n : ℕ} {n' : ℕ}
    {err : dlist string} {a : α} :
    has_orelse.orelse p (pure a) cb n = parse_result.fail n' err ↔
        p cb n = parse_result.fail n' err ∧ n ≠ n' :=
  sorry

theorem any_char_eq_done {cb : char_buffer} {n : ℕ} {n' : ℕ} (hn : n < buffer.size cb) {c : char} :
    any_char cb n = parse_result.done n' c ↔
        n' = n + 1 ∧ buffer.read cb { val := n, property := hn } = c :=
  sorry

theorem sat_eq_done {cb : char_buffer} {n : ℕ} {n' : ℕ} (hn : n < buffer.size cb) {c : char}
    {p : char → Prop} [decidable_pred p] :
    sat p cb n = parse_result.done n' c ↔
        p c ∧ n' = n + 1 ∧ buffer.read cb { val := n, property := hn } = c :=
  sorry

theorem eps_eq_done {cb : char_buffer} {n : ℕ} {n' : ℕ} :
    eps cb n = parse_result.done n' Unit.unit ↔ n = n' :=
  sorry

theorem ch_eq_done {cb : char_buffer} {n : ℕ} {n' : ℕ} (hn : n < buffer.size cb) {c : char} :
    ch c cb n = parse_result.done n' Unit.unit ↔
        n' = n + 1 ∧ buffer.read cb { val := n, property := hn } = c :=
  sorry

-- TODO: add char_buf_eq_done, needs lemmas about matching buffers

theorem one_of_eq_done {cb : char_buffer} {n : ℕ} {n' : ℕ} (hn : n < buffer.size cb) {c : char}
    {cs : List char} :
    one_of cs cb n = parse_result.done n' c ↔
        c ∈ cs ∧ n' = n + 1 ∧ buffer.read cb { val := n, property := hn } = c :=
  sorry

theorem one_of'_eq_done {cb : char_buffer} {n : ℕ} {n' : ℕ} (hn : n < buffer.size cb)
    {cs : List char} :
    one_of' cs cb n = parse_result.done n' Unit.unit ↔
        buffer.read cb { val := n, property := hn } ∈ cs ∧ n' = n + 1 :=
  sorry

theorem remaining_eq_done {cb : char_buffer} {n : ℕ} {n' : ℕ} {r : ℕ} :
    remaining cb n = parse_result.done n' r ↔ n = n' ∧ buffer.size cb - n = r :=
  sorry

theorem eof_eq_done {cb : char_buffer} {n : ℕ} {n' : ℕ} :
    eof cb n = parse_result.done n' Unit.unit ↔ n = n' ∧ buffer.size cb ≤ n :=
  sorry

@[simp] theorem foldr_core_zero_eq_done {α : Type} {β : Type} {cb : char_buffer} {n : ℕ} {n' : ℕ}
    {b : β} {f : α → β → β} {p : parser α} {b' : β} :
    foldr_core f p b 0 cb n ≠ parse_result.done n' b' :=
  sorry

theorem foldr_core_eq_done {α : Type} {β : Type} {cb : char_buffer} {n : ℕ} {n' : ℕ} {b : β}
    {f : α → β → β} {p : parser α} {reps : ℕ} {b' : β} :
    foldr_core f p b (reps + 1) cb n = parse_result.done n' b' ↔
        (∃ (np : ℕ),
            ∃ (a : α),
              ∃ (xs : β),
                p cb n = parse_result.done np a ∧
                  foldr_core f p b reps cb np = parse_result.done n' xs ∧ f a xs = b') ∨
          n = n' ∧
            b = b' ∧
              ∃ (err : dlist string),
                p cb n = parse_result.fail n err ∨
                  ∃ (np : ℕ),
                    ∃ (a : α),
                      p cb n = parse_result.done np a ∧
                        foldr_core f p b reps cb np = parse_result.fail n err :=
  sorry

@[simp] theorem foldr_core_zero_eq_fail {α : Type} {β : Type} {cb : char_buffer} {n : ℕ} {n' : ℕ}
    {b : β} {f : α → β → β} {p : parser α} {err : dlist string} :
    foldr_core f p b 0 cb n = parse_result.fail n' err ↔ n = n' ∧ err = dlist.empty :=
  sorry

theorem foldr_core_succ_eq_fail {α : Type} {β : Type} {cb : char_buffer} {n : ℕ} {n' : ℕ} {b : β}
    {f : α → β → β} {p : parser α} {reps : ℕ} {err : dlist string} :
    foldr_core f p b (reps + 1) cb n = parse_result.fail n' err ↔
        n ≠ n' ∧
          (p cb n = parse_result.fail n' err ∨
            ∃ (np : ℕ),
              ∃ (a : α),
                p cb n = parse_result.done np a ∧
                  foldr_core f p b reps cb np = parse_result.fail n' err) :=
  sorry

theorem foldr_eq_done {α : Type} {β : Type} {cb : char_buffer} {n : ℕ} {n' : ℕ} {b : β}
    {f : α → β → β} {p : parser α} {b' : β} :
    foldr f p b cb n = parse_result.done n' b' ↔
        (∃ (np : ℕ),
            ∃ (a : α),
              ∃ (x : β),
                p cb n = parse_result.done np a ∧
                  foldr_core f p b (buffer.size cb - n) cb np = parse_result.done n' x ∧
                    f a x = b') ∨
          n = n' ∧
            b = b' ∧
              ∃ (err : dlist string),
                p cb n = parse_result.fail n err ∨
                  ∃ (np : ℕ),
                    ∃ (x : α),
                      p cb n = parse_result.done np x ∧
                        foldr_core f p b (buffer.size cb - n) cb np = parse_result.fail n err :=
  sorry

theorem foldr_eq_fail_of_valid_at_end {α : Type} {β : Type} {cb : char_buffer} {n : ℕ} {n' : ℕ}
    {b : β} {f : α → β → β} {p : parser α} {err : dlist string} (hp : valid p)
    (hc : buffer.size cb ≤ n) :
    foldr f p b cb n = parse_result.fail n' err ↔
        n < n' ∧
          (p cb n = parse_result.fail n' err ∨
            ∃ (a : α), p cb n = parse_result.done n' a ∧ err = dlist.empty) :=
  sorry

theorem foldr_eq_fail {α : Type} {β : Type} {cb : char_buffer} {n : ℕ} {n' : ℕ} {b : β}
    {f : α → β → β} {p : parser α} {err : dlist string} :
    foldr f p b cb n = parse_result.fail n' err ↔
        n ≠ n' ∧
          (p cb n = parse_result.fail n' err ∨
            ∃ (np : ℕ),
              ∃ (a : α),
                p cb n = parse_result.done np a ∧
                  foldr_core f p b (buffer.size cb - n) cb np = parse_result.fail n' err) :=
  sorry

@[simp] theorem foldl_core_zero_eq_done {α : Type} {β : Type} {cb : char_buffer} {n : ℕ} {n' : ℕ}
    {b : β} {f : β → α → β} {p : parser α} {b' : β} :
    foldl_core f b p 0 cb n = parse_result.done n' b' ↔ False :=
  sorry

theorem foldl_core_eq_done {α : Type} {β : Type} {cb : char_buffer} {n : ℕ} {n' : ℕ} {b : β}
    {f : β → α → β} {p : parser α} {reps : ℕ} {b' : β} :
    foldl_core f b p (reps + 1) cb n = parse_result.done n' b' ↔
        (∃ (np : ℕ),
            ∃ (a : α),
              p cb n = parse_result.done np a ∧
                foldl_core f (f b a) p reps cb np = parse_result.done n' b') ∨
          n = n' ∧
            b = b' ∧
              ∃ (err : dlist string),
                p cb n = parse_result.fail n err ∨
                  ∃ (np : ℕ),
                    ∃ (a : α),
                      p cb n = parse_result.done np a ∧
                        foldl_core f (f b a) p reps cb np = parse_result.fail n err :=
  sorry

@[simp] theorem foldl_core_zero_eq_fail {α : Type} {β : Type} {cb : char_buffer} {n : ℕ} {n' : ℕ}
    {b : β} {f : β → α → β} {p : parser α} {err : dlist string} :
    foldl_core f b p 0 cb n = parse_result.fail n' err ↔ n = n' ∧ err = dlist.empty :=
  sorry

theorem foldl_core_succ_eq_fail {α : Type} {β : Type} {cb : char_buffer} {n : ℕ} {n' : ℕ} {b : β}
    {f : β → α → β} {p : parser α} {reps : ℕ} {err : dlist string} :
    foldl_core f b p (reps + 1) cb n = parse_result.fail n' err ↔
        n ≠ n' ∧
          (p cb n = parse_result.fail n' err ∨
            ∃ (np : ℕ),
              ∃ (a : α),
                p cb n = parse_result.done np a ∧
                  foldl_core f (f b a) p reps cb np = parse_result.fail n' err) :=
  sorry

theorem foldl_eq_done {α : Type} {β : Type} {cb : char_buffer} {n : ℕ} {n' : ℕ} {b : β}
    {f : β → α → β} {p : parser α} {b' : β} :
    foldl f b p cb n = parse_result.done n' b' ↔
        (∃ (np : ℕ),
            ∃ (a : α),
              p cb n = parse_result.done np a ∧
                foldl_core f (f b a) p (buffer.size cb - n) cb np = parse_result.done n' b') ∨
          n = n' ∧
            b = b' ∧
              ∃ (err : dlist string),
                p cb n = parse_result.fail n err ∨
                  ∃ (np : ℕ),
                    ∃ (a : α),
                      p cb n = parse_result.done np a ∧
                        foldl_core f (f b a) p (buffer.size cb - n) cb np =
                          parse_result.fail n err :=
  sorry

theorem foldl_eq_fail {α : Type} {β : Type} {cb : char_buffer} {n : ℕ} {n' : ℕ} {b : β}
    {f : β → α → β} {p : parser α} {err : dlist string} :
    foldl f b p cb n = parse_result.fail n' err ↔
        n ≠ n' ∧
          (p cb n = parse_result.fail n' err ∨
            ∃ (np : ℕ),
              ∃ (a : α),
                p cb n = parse_result.done np a ∧
                  foldl_core f (f b a) p (buffer.size cb - n) cb np = parse_result.fail n' err) :=
  sorry

theorem many_eq_done_nil {α : Type} {cb : char_buffer} {n : ℕ} {n' : ℕ} {p : parser α} :
    many p cb n = parse_result.done n' [] ↔
        n = n' ∧
          ∃ (err : dlist string),
            p cb n = parse_result.fail n err ∨
              ∃ (np : ℕ),
                ∃ (a : α),
                  p cb n = parse_result.done np a ∧
                    foldr_core List.cons p [] (buffer.size cb - n) cb np =
                      parse_result.fail n err :=
  sorry

theorem many_eq_done {α : Type} {cb : char_buffer} {n : ℕ} {n' : ℕ} {p : parser α} {x : α}
    {xs : List α} :
    many p cb n = parse_result.done n' (x :: xs) ↔
        ∃ (np : ℕ),
          p cb n = parse_result.done np x ∧
            foldr_core List.cons p [] (buffer.size cb - n) cb np = parse_result.done n' xs :=
  sorry

theorem many_eq_fail {α : Type} {cb : char_buffer} {n : ℕ} {n' : ℕ} {p : parser α}
    {err : dlist string} :
    many p cb n = parse_result.fail n' err ↔
        n ≠ n' ∧
          (p cb n = parse_result.fail n' err ∨
            ∃ (np : ℕ),
              ∃ (a : α),
                p cb n = parse_result.done np a ∧
                  foldr_core List.cons p [] (buffer.size cb - n) cb np =
                    parse_result.fail n' err) :=
  sorry

theorem many_char_eq_done_empty {cb : char_buffer} {n : ℕ} {n' : ℕ} {p : parser char} :
    many_char p cb n = parse_result.done n' string.empty ↔
        n = n' ∧
          ∃ (err : dlist string),
            p cb n = parse_result.fail n err ∨
              ∃ (np : ℕ),
                ∃ (c : char),
                  p cb n = parse_result.done np c ∧
                    foldr_core List.cons p [] (buffer.size cb - n) cb np =
                      parse_result.fail n err :=
  sorry

theorem many_char_eq_done_not_empty {cb : char_buffer} {n : ℕ} {n' : ℕ} {p : parser char}
    {s : string} (h : s ≠ string.empty) :
    many_char p cb n = parse_result.done n' s ↔
        ∃ (np : ℕ),
          p cb n = parse_result.done np (string.head s) ∧
            foldr_core List.cons p [] (buffer.size cb - n) cb np =
              parse_result.done n' (string.to_list (string.popn s 1)) :=
  sorry

theorem many_char_eq_many_of_to_list {cb : char_buffer} {n : ℕ} {n' : ℕ} {p : parser char}
    {s : string} :
    many_char p cb n = parse_result.done n' s ↔
        many p cb n = parse_result.done n' (string.to_list s) :=
  sorry

theorem many'_eq_done {α : Type} {cb : char_buffer} {n : ℕ} {n' : ℕ} {p : parser α} :
    many' p cb n = parse_result.done n' Unit.unit ↔
        many p cb n = parse_result.done n' [] ∨
          ∃ (np : ℕ),
            ∃ (a : α),
              ∃ (l : List α),
                many p cb n = parse_result.done n' (a :: l) ∧
                  p cb n = parse_result.done np a ∧
                    foldr_core List.cons p [] (buffer.size cb - n) cb np = parse_result.done n' l :=
  sorry

@[simp] theorem many1_ne_done_nil {α : Type} {cb : char_buffer} {n : ℕ} {n' : ℕ} {p : parser α} :
    many1 p cb n ≠ parse_result.done n' [] :=
  sorry

theorem many1_eq_done {α : Type} {cb : char_buffer} {n : ℕ} {n' : ℕ} {a : α} {p : parser α}
    {l : List α} :
    many1 p cb n = parse_result.done n' (a :: l) ↔
        ∃ (np : ℕ), p cb n = parse_result.done np a ∧ many p cb np = parse_result.done n' l :=
  sorry

theorem many1_eq_fail {α : Type} {cb : char_buffer} {n : ℕ} {n' : ℕ} {p : parser α}
    {err : dlist string} :
    many1 p cb n = parse_result.fail n' err ↔
        p cb n = parse_result.fail n' err ∨
          ∃ (np : ℕ),
            ∃ (a : α), p cb n = parse_result.done np a ∧ many p cb np = parse_result.fail n' err :=
  sorry

@[simp] theorem many_char1_ne_empty {cb : char_buffer} {n : ℕ} {n' : ℕ} {p : parser char} :
    many_char1 p cb n ≠ parse_result.done n' string.empty :=
  sorry

theorem many_char1_eq_done {cb : char_buffer} {n : ℕ} {n' : ℕ} {p : parser char} {s : string}
    (h : s ≠ string.empty) :
    many_char1 p cb n = parse_result.done n' s ↔
        ∃ (np : ℕ),
          p cb n = parse_result.done np (string.head s) ∧
            many_char p cb np = parse_result.done n' (string.popn s 1) :=
  sorry

@[simp] theorem sep_by1_ne_done_nil {α : Type} {cb : char_buffer} {n : ℕ} {n' : ℕ}
    {sep : parser Unit} {p : parser α} : sep_by1 sep p cb n ≠ parse_result.done n' [] :=
  sorry

theorem sep_by1_eq_done {α : Type} {cb : char_buffer} {n : ℕ} {n' : ℕ} {a : α} {sep : parser Unit}
    {p : parser α} {l : List α} :
    sep_by1 sep p cb n = parse_result.done n' (a :: l) ↔
        ∃ (np : ℕ),
          p cb n = parse_result.done np a ∧ many (sep >> p) cb np = parse_result.done n' l :=
  sorry

theorem sep_by_eq_done_nil {α : Type} {cb : char_buffer} {n : ℕ} {n' : ℕ} {sep : parser Unit}
    {p : parser α} :
    sep_by sep p cb n = parse_result.done n' [] ↔
        n = n' ∧ ∃ (err : dlist string), sep_by1 sep p cb n = parse_result.fail n err :=
  sorry

@[simp] theorem fix_core_ne_done_zero {α : Type} {cb : char_buffer} {n : ℕ} {n' : ℕ} {a : α}
    {F : parser α → parser α} : fix_core F 0 cb n ≠ parse_result.done n' a :=
  sorry

theorem fix_core_eq_done {α : Type} {cb : char_buffer} {n : ℕ} {n' : ℕ} {a : α}
    {F : parser α → parser α} {max_depth : ℕ} :
    fix_core F (max_depth + 1) cb n = parse_result.done n' a ↔
        F (fix_core F max_depth) cb n = parse_result.done n' a :=
  sorry

theorem digit_eq_done {cb : char_buffer} {n : ℕ} {n' : ℕ} (hn : n < buffer.size cb) {k : ℕ} :
    digit cb n = parse_result.done n' k ↔
        n' = n + 1 ∧
          k ≤ bit1 (bit0 (bit0 1)) ∧
            char.to_nat (buffer.read cb { val := n, property := hn }) -
                  char.to_nat (char.of_nat (bit0 (bit0 (bit0 (bit0 (bit1 1)))))) =
                k ∧
              char.of_nat (bit0 (bit0 (bit0 (bit0 (bit1 1))))) ≤
                  buffer.read cb { val := n, property := hn } ∧
                buffer.read cb { val := n, property := hn } ≤
                  char.of_nat (bit1 (bit0 (bit0 (bit1 (bit1 1))))) :=
  sorry

end Mathlib